?? 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 mtp$system_helper_r3
*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 := 'cause_error', EJECT ??

    PROCEDURE cause_command
      (    parameter_list: clt$parameter_list;
           command_type: char;
        VAR status: ost$status);


{ PROCEDURE causee_pdt (
{   processor_id, pi: integer 0..1 = $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,
    [100, 5, 19, 12, 39, 41, 39],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['PI                             ',clc$abbreviation_entry, 1],
    ['PROCESSOR_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, 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, 1, 10]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

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

    CONST
      p$processor_id = 1,
      p$status = 2;

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

    VAR
      id: ost$processor_id;

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

    id := pvt [p$processor_id].value^.integer_value.value;

    mtp$system_helper_r3 (id, status);

    PROCEND cause_command;
?? OLDTITLE ??
?? NEWTITLE := 'uutl', EJECT ??

  PROCEDURE [XDCL, #GATE] uutl
    (    program_parameters: pmt$program_parameters;
     VAR status: ost$status);

    CONST
      c$max_commands = 40;

    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],
            ['CAUSEE  ', ' ', ^cause_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;
