?? 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 clt$block
*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
?? 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;

