1 /* ***********************************************************
   2    *                                                         *
   3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   4    *                                                         *
   5    * Copyright (c) 1972 by Massachusetts Institute of        *
   6    * Technology and Honeywell Information Systems, Inc.      *
   7    *                                                         *
   8    *********************************************************** */
   9 
  10 
  11 eis_tester: et: procedure;
  12 
  13 
  14 /*        This procedure is the main procedure in the  eis  instruction tester.
  15    *      It calls  "et_test"  to parse the statements in the user provided data
  16    *      file.  It translates these statements into the data needed to build and
  17    *      test an eis instruction in the external segment  etx.     After building
  18    *      the instruction this procedure will call  etx  in order to execute the  eis
  19    *      instructuion.  When  etx returns the results of the eis instruction will be
  20    *      examined.   "et"  will continue to build  and test  eis instructions until
  21    *      there is no data left in the input file.
  22    *
  23    *      Each instruction may be tested several times.  Also, the user may specify
  24    *      that variations of the same instruction be tested.  Each variation may be
  25    *      tested several times.
  26    *
  27    *      Note, the failure of one instruction will only cause the termination of that
  28    *      one instruction test.  Any remaining instructions specified in the input
  29    *      file will be processed and tested.
  30    *
  31    *      Created  Oct, 72  by  Bill Silver.
  32    *      Modified Aug, 80 by R. L. Coppola to add the -to control arg, and
  33    *      display_mc_ procedure, also increased declaration of several fixed bin
  34    *      variables to fixed bin (35) to enable processing of the new ets scripts.
  35    *      Modified March 1981 by Rich Coppola for DPS8 history reg support.
  36    *      Modified March 31, 1983 by GA Texada to make the argument processing more Multicious.
  37    *
  38    *
  39    *      ET  has two entries.  Both are called with one command option - a path name.
  40    *
  41    *      1.  et        aaaa            The path name  "aaaa"  refers to a segment which
  42    *                                    contains input script data which defines the
  43    *                                    instruction to test.  This is the main entry.
  44    *
  45    *      2.  et$gen    aaaa            The path name  "aaaa"  refers to a procedure which
  46    *                                    will generate the  ET data needed to test ONE
  47    *                                    instruction.
  48    *
  49    *      In addition each entry may be called with two optional arguments.
  50    *
  51    *           a)  "-bf"      Specifies that BRIEF mode will be entered.  All but identification
  52    *                          and error messages will be suppressed.
  53    *
  54    *           b)  "-nox"     Specifies  NO eXecute mode.  This implies that the instruction
  55    *                          will be set up but not executed.  It is used to test the validity
  56    *                          of the input script.
  57    *
  58    *           c)  "-debug"   Specifies that this test is to be run in a  DEBUGGING  LOOP.
  59    *                          Each instruction will be tested  10  times.  The results from
  60    *                          the test will not be checked.  Each time through the loop the
  61    *                          instruction will be set up completeley including all the
  62    *                          specified page faults.
  63    *
  64    *           d)  "-do" X    X is a positive decimal number which specifies the NUMBER of
  65    *                          the test that is to be processed.  This number has NO
  66    *                          relationship to the  -ns  field in any test.
  67    *
  68    *           e)  "-fm" X    X is the number of the first test that will be processed.  All
  69    *                          remaining tests in the input segment will also be processed
  70    *                          unless the -to option is also selected..
  71 
  72 
  73    *           f)  "-to" X    X is the number of the last test that will be processed.
  74 */
  75 
  76 
  77 
  78 
  79 
  80 
  81 /*                  AUTOMATIC  DATA               */
  82 
  83 
  84 dcl  script_ptr ptr,                                        /* Pointer to the input data file.  */
  85 
  86      script_len fixed bin,                                  /* The length of the input data file.  */
  87 
  88      gen_seg_ptr ptr;                                       /* Pointer to the procedure segment which
  89                                                                *  will generate the input test data.  */
  90 
  91 
  92 
  93 /*        This is the area where the  et_setup_data  resides.  It is declared as pointers
  94    *      so it will begin on an even word boundary.  It is slightly longer than necessary.
  95 */
  96 
  97 dcl  setup_data_area (92) ptr;
  98 
  99 dcl  code fixed bin (35),                                   /* Error code. */
 100 
 101      dup_string char (16),                                  /* Area where the previous line is saved.  */
 102 
 103      debug_loop_flag fixed bin,                             /* Used to specify a tight loop from command
 104                                                                *  level.  Will not even test results of test.  */
 105 
 106      plural char (1),                                       /* Used to add an "s" to the end of words
 107                                                                *  in a print line.  */
 108 
 109      print_string char (16) aligned,                        /* Area where the lines of data are printed. */
 110 
 111      print_pages (14) char (4),                             /* Used to print the names of the pages
 112                                                                *  which this instruction will fault on.  */
 113 
 114      print_ptr ptr,                                         /* Pointer to the line being printed. */
 115 
 116      print_len fixed bin,                                   /* The number of characters still to be printed. */
 117 
 118      long_hregs bit (1) init ("0"b),                        /* prints octal hregs if = 1 */
 119 
 120      num_words fixed bin,                                   /* The number of words in a string to be printed */
 121 
 122 
 123      line_length fixed bin,
 124 
 125      set_indicators bit (36),                               /* Word used to set up the indicators in  etx.  */
 126 
 127      skip_count fixed bin,                                  /* The number of duplicated print lines
 128                                                                *  that have been skipped.  */
 129 
 130      test_num (10) fixed bin,                               /* The number of the special test(s) we are
 131                                                                *  looking for due to a  "-fm" or "-do" option. */
 132 
 133      TEST_INSTR char (6) var init (""),                     /* The type of instruction we want to test */
 134 
 135      stop_num fixed bin,                                    /* The number of the last test we are to run */
 136 
 137      times_to_repeat fixed bin,                             /* The number of times to repeat a set of scripts */
 138 
 139      RPT fixed bin init (1),                                /* itreration var for repeat opt */
 140 
 141     (SEL, SELECT) fixed bin,                                /* used to set up and select a set of tests */
 142 
 143 
 144      temp_seg_name char (32),                               /* name of temp seg being created */
 145      temp_segp ptr,                                         /* pointer to temp seg being created */
 146      copy_segp ptr,                                         /* pointer to segment to copy into temp seg */
 147      copy_bit_count fixed bin (24),                         /* bit count of seg to copy */
 148      type fixed bin (2),
 149      sof_ bit (1) init ("0"b);                              /* stop on test failure */
 150 
 151 dcl  terminate_sel bit (1);
 152 
 153 
 154 dcl (brief_flag, verbose_flag) fixed bin,                   /* Used to suppress printing the data of
 155                                                                *  an instruction.  */
 156 
 157      gen_flag fixed bin,                                    /* Used to call a procedure to generate
 158                                                                *  the test data.  */
 159 
 160      nox_flag fixed bin,                                    /* Used to denote that the instructions are
 161                                                                *  not to be executed.  */
 162 
 163      finished_flag fixed bin,                               /* Indicates when all of the instructions
 164                                                                *  have been tested.  */
 165 
 166      error_flag fixed bin,                                  /* ON when an error has been found.  */
 167 
 168      do_flag fixed bin,                                     /* Indicates that we are looking for one special
 169                                                                *  test to run.  */
 170 
 171      start_flag fixed bin,                                  /* Indicates that we are looking for one special
 172                                                                *  test to start with.  All test following it will
 173                                                                *  be processed unless the stop_ flag is set.  */
 174 
 175      remember_start fixed bin,                              /* need to remember start falg when repeating */
 176 
 177      test_instr_flag fixed bin,                             /* indicates we are looking for a type of instr */
 178 
 179      stop_flag fixed bin;                                   /* indicates we are to look for a test number which will stop our processing */
 180 
 181 
 182 
 183 dcl  arg_ptr ptr,                                           /* Pointer to input argument. */
 184      arg_len fixed bin,                                     /* Length  of input argument. */
 185      num_args fixed bin,                                    /* Number of arguments to ET. */
 186      dir_name char (168),                                   /* Directory containing input file. */
 187      ent_name char (32),                                    /* Entry name of input file. */
 188      bit_count fixed bin (24);                              /* Size of data file in bits. */
 189 
 190 
 191 dcl  print_chars (1:4) char (12),                           /* Used to print a word in octal while
 192                                                                *  doing some of our own editing.  */
 193 
 194      char_word char (4),                                    /* One word of the octal string se are printing. */
 195 
 196      character char (1);                                    /* One character of the octal print string. */
 197 
 198 
 199 dcl (i, j, k, xx, argcount) fixed bin,                      /* Work indexes. */
 200      loopx fixed bin,                                       /* Main test loop index. */
 201      datax fixed bin;                                       /* Index used to print data areas.  */
 202 
 203 dcl  hreg_state bit (1) aligned;                            /* state of this processes hreg switch */
 204 
 205 dcl 1 bug_structure,                                        /* Just here for compiler bug. */
 206    (2 dummy_print_char char (1),                            /* Used to pad data strings for printing so
 207                                                                *  they occupy fill words.  "707" octal. */
 208     2 dummy_test_char char (1),                             /* Used to pad the beginning and end of the
 209                                                                *  test and result fields.  "717" octal. */
 210     2 result_fill_char char (1),                            /* Used to fill in the result field.
 211                                                                *  "000" octal.  */
 212     2 bug_pad char (1)) unaligned;
 213 dcl  touch_word bit (36),                                   /* Used to touch a page in order to bring
 214                                                                *  it into core.  */
 215      workx fixed bin,                                       /* A work variable.  */
 216      wptr ptr;                                              /* A work pointer.  */
 217 dcl  int_cond_name char (32);
 218 
 219 dcl  cond_infop ptr;                                        /* pointer to condition info */
 220 
 221 dcl  instr_ptr ptr,                                         /* Pointer to where the  eis  instruc-
 222                                                                *  tion goes in  etx.  */
 223 
 224      save_data_ptr ptr,                                     /* Used to save a data pointer while printing. */
 225 
 226      our_offset fixed bin;                                  /* The instruction offset after it has been
 227                                                                *  converted from the input version to the
 228                                                                *  version we need internally.  Our offset
 229                                                                *  is from the beginning of the instruction
 230                                                                *  area and not from the end of the page.  */
 231 
 232 dcl 1 akst aligned like kst_attributes;
 233 
 234 
 235 
 236 /*                  BASED  DATA                   */
 237 
 238 
 239 dcl 1 eis_map based,                                        /* Map of the whole  eis  instruction. */
 240     2 instruction bit (36),
 241     2 desc_array (3) bit (36);
 242 
 243 
 244 dcl  instr_overlay (7) bit (36) based;                      /* Used to reference the  etx  instruc-
 245                                                                *  tion area as an array of words. */
 246 
 247 
 248 dcl  word_overlay bit (36) based,                           /* Used to reference an individual word. */
 249 
 250      char_overlay bit (9) based,                            /* Used to reference one character.  */
 251 
 252      based_string char (16) based unaligned,                /* Used to reference one line of input
 253                                                                *  data that is actually in the data
 254                                                                *  string being printed.  */
 255 
 256 /*        These arrays are used to reference the print string as an array of words and
 257    *      and a character as an array of 3 octal digits.
 258 */
 259 
 260      char_words (4) char (4) based (addr (print_string)) aligned,
 261 
 262      char_bits (3) bit (3) based (addr (character)) unaligned;
 263 
 264 
 265 
 266 /*        This array is used to reference a data string as an array of characters.  */
 267 
 268 dcl  data_array (1:4352) char (1) based unaligned,
 269 
 270      ptr_array (8) ptr based,                               /* Used to reference the pointer
 271                                                                *  registers as an array of pointers. */
 272 
 273 /*        reg_array is used to reference the registers as an array of half words.  */
 274 
 275      reg_array (16) fixed bin (17) based unaligned;
 276 
 277 dcl script_path char(501);                                  /* make pathname big enough...                    */
 278 
 279 
 280 dcl  data char (data_len) based,                            /* Used to reference the data areas. */
 281 
 282      data_len fixed bin;                                    /* Size of the data field.  */
 283 
 284 
 285 
 286 /*        used to copy a segment into a temporary segment */
 287 
 288 dcl  copy_seg char (divide (copy_bit_count + 8, 9, 21, 0)) based;
 289 
 290 
 291 
 292 
 293 /*                  INTERNAL  STATIC  DATA        */
 294 
 295 
 296 
 297 /*        This table points to the three set up areas for data in etx.    Entries 4 and 5 are
 298    *      dummy entries.  They make this array correspond to the data_ptrs array.
 299 */
 300 
 301 dcl  set_data_ptrs (5) ptr internal static;
 302 
 303 
 304 /*        Word used to initialize the word we use to set up the indicators.
 305    *      The  BAR MODE indicator bit is always ON
 306 */
 307 dcl  init_indicators bit (36) internal static
 308      init ("000000000000000000000000000010000000"b);
 309 
 310 
 311 
 312 
 313 /*        This table contains static constants which are used to identify data
 314    *      strings when they are typed.  */
 315 
 316 dcl  data_names (5) char (12) internal static
 317      init ("data field 1", "data field 2", "data field 3",
 318      "test  data  ", "result data ");
 319 
 320 
 321 /*        This table contains the names of the pages which are defined by ET. */
 322 
 323 dcl  page_names (14) char (4)
 324      init (" in1", " in2",
 325      " id1", " d11", " d12", " d13",
 326      " id2", " d21", " d22", " d23",
 327      " id3", " d31", " d32", " d33");
 328 
 329 dcl  tx fixed bin internal static init (4),                 /* Index to data arays for */
 330      rx fixed bin internal static init (5);                 /* test and result data fields. */
 331 
 332 
 333 dcl  oct_chars (0:7) char (1) internal static aligned
 334      init ("0", "1", "2", "3", "4", "5", "6", "7");
 335 
 336 dcl  segs_initialized bit (1) internal static init ("0"b);
 337 
 338 dcl  seg_ref_names (7) char (32) internal static options (constant)
 339      init ("etx", "eti1", "eti2", "eti3", "etd1", "etd2", "etd3");
 340 
 341 dcl  condition_label label internal static,
 342      truncation_label label internal static;
 343 dcl (stringsize, quit, et_error) condition;
 344 
 345 
 346 /* ^L */
 347 /*                  EXTERNAL  DATA                */
 348 
 349 
 350 /*        The following declarations reference the dummy programs used to execute
 351    *      the  eis  instructions.
 352 */
 353 
 354 dcl (etx$set_ptrs, etx$set_regs,
 355      etx$set_ind, etx$indicators,
 356      etx$instruction_area,
 357      etx$set_data1, etx$set_data2, etx$set_data3) external;
 358 
 359 
 360 dcl  com_err_ entry options (variable),
 361      cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
 362      cu_$arg_count entry (fixed bin),
 363      cu_$ptr_call entry options (variable),
 364      get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin),
 365      find_condition_info_ entry (ptr, ptr, fixed bin (35)),
 366      continue_to_signal_ entry (fixed bin (35)),
 367      et_util$char_rel entry (ptr, fixed bin),
 368      etx$execute entry options (variable),
 369      expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)),
 370      hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24),
 371      fixed bin (12), ptr, fixed bin (35)),
 372      hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)),
 373      hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)),
 374      hcs_$history_regs_get entry (bit (1) aligned),
 375      hcs_$history_regs_set entry (bit (1) aligned),
 376      hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)),
 377      hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)),
 378      hcs_$terminate_name entry (char (*), fixed bin (35)),
 379      hcs_$terminate_noname entry (ptr, fixed bin (35)),
 380      phcs_$deactivate entry (ptr, fixed bin (35)),
 381      phcs_$set_kst_attributes entry (fixed bin (35), ptr, fixed bin (35)),
 382      ioa_ entry options (variable),
 383      unique_bits_ entry () returns (bit (70)),
 384      unique_chars_ entry (bit (*)) returns (char (15)),
 385      error_table_$badopt fixed bin(35) ext static,
 386      error_table_$bad_arg fixed bin (35) ext static,
 387      et_test entry (ptr, fixed bin, ptr, fixed bin, fixed bin (35));
 388 
 389 %page;
 390 %include kst_attributes;
 391 
 392 dcl 1 cond_info aligned,
 393 % include cond_info;
 394 
 395 
 396      dcl (addr, addrel, baseno, divide, fixed, hbound, null, rtrim, substr, unspec, verify) builtin;
 397 %page;
 398 %include et_setup_data;
 399 %page;
 400 
 401           times_to_repeat = 1;
 402           test_num (*) = -1;
 403           script_path = "";
 404           SELECT = 1;
 405 
 406 
 407 /*         see if there are any optional arguments to  ET.  */
 408 
 409           verbose_flag, brief_flag, nox_flag = 0;           /* Initialize the flags OFF. */
 410 
 411           call cu_$arg_count (num_args);
 412           if num_args <= 0 then goto USAGE;
 413 
 414           debug_loop_flag = 0;                              /* Zero implies we are not going to be
 415                                                                *  in a  debug  loop.  */
 416           remember_start, start_flag, stop_flag, do_flag = 0;
 417                do argcount = 1 to num_args;
 418                call cu_$arg_ptr (argcount, arg_ptr, arg_len, code);
 419 
 420                if code ^= 0
 421                then do;
 422                     call com_err_ (code, "ET", "Can't get command argument ^d", argcount);
 423                     return;
 424                end;
 425 new_arg:
 426                data_len = arg_len;
 427 
 428                if arg_ptr -> data = "-help"
 429                then go to USAGE;
 430 
 431                else if arg_ptr -> data = "-bf"
 432                | arg_ptr -> data = "-brief"
 433                then brief_flag = 1;
 434 
 435 
 436                else if arg_ptr -> data = "-long"
 437                | arg_ptr -> data = "-lg" then
 438                     verbose_flag = 1;
 439 
 440 
 441                else
 442                if arg_ptr -> data = "-nox"
 443                then nox_flag = 1;
 444 
 445                else
 446                if arg_ptr -> data = "-debug"
 447                then debug_loop_flag = 1;
 448 
 449                else
 450                if (arg_ptr -> data = "-fm")
 451                | (arg_ptr -> data = "-from")
 452                then do;
 453 
 454                     start_flag, remember_start = 1;
 455 
 456                     if argcount = num_args
 457                     then do;
 458                          code = error_table_$bad_arg;
 459                          call com_err_ (code, "ET", "No number following ^a option.",
 460                               arg_ptr -> data);
 461                               return;
 462                     end;
 463 
 464                     argcount = argcount + 1;
 465 
 466                     call cu_$arg_ptr (argcount, arg_ptr, arg_len, code);
 467                     if code ^= 0 then goto bad_arg ;
 468 
 469                     test_num (1) = verify (substr (arg_ptr -> data, 1, arg_len), "0123456789");
 470 
 471                     if test_num (1) ^= 0
 472                     then do;
 473                          code = error_table_$bad_arg;
 474                          call com_err_ (code, "ET", "Illegal numeric option argument: ^a",
 475                               arg_ptr -> data);
 476                          return;
 477                     end;
 478                     test_num (1) = fixed (substr (arg_ptr -> data, 1, arg_len), 17);
 479                end;
 480 
 481 
 482                else
 483                if (arg_ptr -> data = "-instruction_type")
 484                | (arg_ptr -> data = "-inst")
 485                then do;
 486 
 487 
 488                     if argcount = num_args
 489                     then do;
 490                          code = error_table_$bad_arg;
 491                          call com_err_ (code, "ET", "No instruction type following ^a option.",
 492                               arg_ptr -> data);
 493                          return;
 494                     end;
 495 
 496                     argcount = argcount + 1;
 497 
 498                     call cu_$arg_ptr (argcount, arg_ptr, arg_len, code);
 499                     if code ^= 0 then go to bad_arg;
 500 
 501                     TEST_INSTR = substr (arg_ptr -> data, 1, arg_len);
 502                     test_instr_flag = 1;
 503                     if substr (TEST_INSTR, 1, 1) = "-"
 504                     then do;
 505                          code = error_table_$bad_arg;
 506                          call com_err_ (code, "ET", "An instruction type does not follow argument: ^a",
 507                               arg_ptr -> data);
 508                          return;
 509                     end;
 510                end;
 511 
 512 
 513                else if arg_ptr -> data = "-to"
 514                then do;
 515 
 516                     stop_flag = 1;
 517 
 518                     if argcount = num_args then do;
 519                          code = error_table_$bad_arg;
 520                          call com_err_ (code, "ET", "No number following ^a option.", arg_ptr -> data);
 521                          return;
 522                     end;
 523 
 524                     argcount = argcount + 1;
 525                     call cu_$arg_ptr (argcount, arg_ptr, arg_len, code);
 526                     if code ^= 0 then go to bad_arg;
 527                     stop_num = verify (substr (arg_ptr -> data, 1, arg_len), "0123456789");
 528                     if stop_num ^= 0 then do;
 529                          code = error_table_$bad_arg;
 530                          call com_err_ (code, "ET", "Illegal numeric option argument: ^a", arg_ptr -> data);
 531                          return;
 532                     end;
 533 
 534                     stop_num = fixed (substr (arg_ptr -> data, 1, arg_len), 17);
 535                end;
 536 
 537 
 538                else
 539                if (arg_ptr -> data = "-do")
 540                | (arg_ptr -> data = "-select")
 541                | (arg_ptr -> data = "-sel")
 542                then do;
 543 
 544                     do_flag = 1;
 545 
 546                     if argcount = num_args
 547                     then do;
 548                          code = error_table_$bad_arg;
 549                          call com_err_ (code, "ET", "No number following ^a option.",
 550                               arg_ptr -> data);
 551                          return;
 552                     end;
 553 
 554                     terminate_sel = "0"b;
 555                     SELECT = 0;
 556                     do SEL = 1 to 10 while (^terminate_sel); /* get the set to run */
 557                          argcount = argcount + 1;
 558 
 559                          call cu_$arg_ptr (argcount, arg_ptr, arg_len, code);
 560 
 561                          if code ^= 0 then do;
 562                               if SEL = 1 then do;
 563 bad_sel_arg:                       call com_err_ (code, "ET", "No number following the select arg.");
 564                                    return;
 565                               end;
 566                               terminate_sel = "1"b;
 567                               go to set_up_sel;
 568                          end;
 569 
 570                          if substr (arg_ptr -> data, 1, 1) = "-" then do;
 571 
 572                               if SEL = 1 then do;
 573                                    code = error_table_$bad_arg;
 574                                    go to bad_sel_arg;
 575                               end;
 576                               argcount = argcount -1;
 577                               terminate_sel = "1"b;
 578                               go to set_up_sel;
 579                          end;
 580 
 581                          test_num (SEL) = verify (substr (arg_ptr -> data, 1, arg_len), "0123456789");
 582 
 583                          if test_num (SEL) ^= 0
 584                          then do;
 585                               if (SEL >1) & ((substr(arg_ptr->data, 1, 1) ="-")
 586                                    | (script_path = "")) then goto new_arg;
 587                               code = error_table_$bad_arg;
 588                               call com_err_ (code, "ET", "Illegal numeric option argument: ^a",
 589                                    arg_ptr -> data);
 590                               return;
 591                          end;
 592                          test_num (SEL) = fixed (substr (arg_ptr -> data, 1, arg_len), 17);
 593 
 594                     end;
 595                     SELECT = SELECT + 1;
 596 set_up_sel:
 597                end;
 598 
 599                else if arg_ptr -> data = "-stop_on_failure"
 600                | arg_ptr -> data = "-sof"
 601                then sof_ = "1"b;
 602 
 603                else if arg_ptr -> data = "-repeat"
 604                | arg_ptr -> data = "-rpt" then do;
 605                     if argcount = num_args then do;
 606                          code = error_table_$bad_arg;
 607                          call com_err_ (code, "ET", "No number following ^a option.", arg_ptr -> data);
 608                          return;
 609                     end;
 610 
 611                     argcount = argcount + 1;
 612                     call cu_$arg_ptr (argcount, arg_ptr, arg_len, code);
 613                     if code ^= 0 then go to bad_arg;
 614                     times_to_repeat = verify (substr (arg_ptr -> data, 1, arg_len), "0123456789");
 615 
 616                     if times_to_repeat ^= 0 then do;
 617                          code = error_table_$bad_arg;
 618                          call com_err_ (code, "ET", "Illegal numeric option argument: ^a", arg_ptr -> data);
 619                          return;
 620                     end;
 621 
 622                     times_to_repeat = fixed (substr (arg_ptr -> data, 1, arg_len), 17);
 623 
 624                end;
 625                else
 626 use_as_script_path:
 627                if script_path = "" then script_path = arg_ptr -> data;
 628                else do;
 629                     if substr(arg_ptr -> data, 1, 1) = "-" then code = error_table_$badopt;
 630                     else
 631 bad_arg:            code = error_table_$bad_arg;
 632 ARG_ERROR:          call com_err_ (code, "ET", "^a.", arg_ptr -> data);
 633                     return;
 634 USAGE:              call ioa_ ("ET: Usage is: et path {-control_args}");
 635                     call ioa_ ("Valid control args: -brief, -bf^/^-^--debug");
 636                     call ioa_ ("^-^--from TEST_NUM,-fm TEST_NUM^/^-^--instruction_type INSTR, -inst INSTR");
 637                     call ioa_ ("^-^--long, -lg^/^-^--nox^/^-^--repeat NUM, -rpt NUM");
 638                     call ioa_ ("^-^--select TEST_NUM, -sel TEST_NUM^/^-^--stop_on_failure, -sof^/^-^--to TEST_NUM");
 639 
 640 incons_arg:
 641                     if ^hreg_state then                     /* if they were off when we started.. */
 642                          call hcs_$history_regs_set ("0"b); /* turn off hregs */
 643                     return;
 644                end;
 645 
 646           end;
 647 %page;
 648 
 649 
 650 
 651 /*        "eis_tester" (ET) is called with one command option - the path name of a
 652    *      segment containing input script data or the path name of a procedure which will
 653    *      be called to set up the input data.
 654 */
 655 
 656 
 657           gen_flag = 0;                                     /* This is the normal entry.  */
 658 
 659           goto join;
 660 
 661 
 662 
 663 gen:      entry;
 664 
 665           gen_flag = 1;
 666 
 667 
 668 
 669 join:
 670 
 671           line_length = get_line_length_$switch (null (), code);
 672           if line_length < 132 then long_hregs = "0"b;
 673           else long_hregs = "1"b;
 674 
 675 
 676           call hcs_$history_regs_get (hreg_state);          /* get state of processes save hreg switch */
 677 
 678           if ^hreg_state then
 679                call hcs_$history_regs_set ("1"b);           /* turn on for testing */
 680 
 681           if (gen_flag = 1) then do;                        /* for this we have to get one and only one argument*/
 682                call cu_$arg_ptr(1, arg_ptr, arg_len, code); /* no other checking is done                      */
 683                if code ^= 0 then goto ARG_ERROR;
 684                data_len = arg_len;
 685                script_path = arg_ptr -> data;
 686                end;
 687 
 688 /*        Now expand this path name  so we can initiate the segment.
 689 */
 690 
 691           call expand_pathname_ (script_path, dir_name, ent_name, code);
 692 
 693           if code ^= 0
 694           then do;
 695                call com_err_ (code, "ET", "Can't expand path name of input segment ^a.", script_path);
 696                return;
 697           end;
 698 
 699 
 700 
 701 /*        If we have a script segment then get a pointer to the base of this segment.
 702    *      Also get the length of the segment in characters.
 703 */
 704 
 705           do RPT = 1 to times_to_repeat;                    /* repeat set x times */
 706 
 707                if remember_start = 1 then                   /* reset starting test indicator */
 708                     start_flag = 1;
 709 
 710                SELECT = 1;
 711                if gen_flag = 0                              /* Is there script input?  */
 712 
 713 
 714                then do;
 715 
 716                     call hcs_$initiate_count (dir_name, ent_name, "", bit_count, 1,
 717                          script_ptr, code);
 718 
 719                     if script_ptr = null ()
 720                     then do;
 721                          call com_err_ (code, "ET", "Cannot initiate data segment ^a^[>^]^a.", dir_name, (dir_name ^= ">"), ent_name);
 722                          return;
 723                     end;
 724 
 725                     code = 0;
 726 
 727                     bit_count = bit_count + 8;
 728 
 729                     script_len = bit_count / 9;             /* Get size in chars. */
 730 
 731                end;
 732 
 733 
 734 
 735                else do;                                     /* The input is a path name of a procedure
 736                                                                *  segment.  Get a pointer to the entry
 737                                                                *  point of this procedure.  */
 738 
 739                     call hcs_$make_ptr (null (), ent_name, ent_name, gen_seg_ptr, code);
 740 
 741                     if code ^= 0
 742                     then do;
 743                          call com_err_ (code, "ET", "Can't get pointer to entry point of gen seg ^a^[>^]^a.",
 744                               dir_name, (dir_name ^= ">"), ent_name);
 745                          return;
 746                     end;
 747 
 748                end;
 749 
 750 %page;
 751 /*        Create the temporary segments we will use, if they have not been
 752    created in a prior invocation.  Before touching them, make them
 753    deactivatable explicitly */
 754 
 755                if ^segs_initialized then do;
 756                     do i = 1 to hbound (seg_ref_names, 1);
 757                          call hcs_$terminate_name (seg_ref_names (i), code); /* get rid of residual */
 758                          call hcs_$make_ptr (null (), seg_ref_names (i), "", copy_segp, code);
 759                          if code ^= 0 then do;
 760                               call com_err_ (code, "ET", seg_ref_names (i));
 761                               return;
 762                          end;
 763                          call hcs_$status_mins (copy_segp, type, copy_bit_count, code);
 764                          if code ^= 0 then do;
 765                               call com_err_ (code, "ET", seg_ref_names (i));
 766                               return;
 767                          end;
 768                          temp_seg_name = unique_chars_ (unique_bits_ ()) || "." || rtrim (seg_ref_names (i));
 769                          call hcs_$make_seg ("", temp_seg_name, "", 01110b, temp_segp, code);
 770                          if code ^= 0 then do;
 771                               call com_err_ (code, "ET", "Creating [pd]>^a", temp_seg_name);
 772                               return;
 773                          end;
 774                          unspec (akst) = "0"b;
 775                          akst.set.explicit_deactivate_ok,
 776                               akst.value.explicit_deactivate_ok = "1"b;
 777                          call phcs_$set_kst_attributes (fixed (baseno (temp_segp), 17), addr (akst), code);
 778                          if code ^= 0 then do;
 779                               call com_err_ (code, "ET", "Setting KST attributes for [pd]>^a", temp_seg_name);
 780                               return;
 781                          end;
 782                          temp_segp -> copy_seg = copy_segp -> copy_seg;
 783                          call hcs_$terminate_name (seg_ref_names (i), code);
 784                          call hcs_$make_seg ("", temp_seg_name, seg_ref_names (i), 01110b, (null ()), code);
 785                          call hcs_$set_bc_seg (temp_segp, copy_bit_count, code);
 786                          if code ^= 0 then do;
 787                               call com_err_ (code, "ET", "Setting bit count for [pd]>^a", temp_seg_name);
 788                               return;
 789                          end;
 790                     end;
 791                     segs_initialized = "1"b;
 792                end;
 793           call ioa_ ("^/ET");
 794 %page;
 795 /*        Initialize those arguments that have to be initialized only once */
 796 
 797                condition_label = condition_restart;
 798 
 799                set_data_ptrs (1) = addr (etx$set_data1);
 800                set_data_ptrs (2) = addr (etx$set_data2);
 801                set_data_ptrs (3) = addr (etx$set_data3);
 802                set_data_ptrs (4),
 803                     set_data_ptrs (5) = null ();
 804 
 805                et_data_ptr = addr (setup_data_area);
 806 
 807                page_ptrs (*) = null ();
 808 
 809                next_instruction_x = 0;
 810 
 811                finished_flag = 0;
 812 
 813                test_count = 0;
 814 
 815                addr (result_fill_char) -> char_overlay = "000000000"b;
 816                addr (dummy_print_char) -> char_overlay = "111000111"b;
 817                addr (dummy_test_char) -> char_overlay = "111001111"b;
 818 
 819 /*        Note, the dummy value for the registers is 8191 decimal.  This value is used
 820    *      because it is greater than any number we will use in a register and is equal
 821    *      to  17777 octal.
 822 */
 823 
 824                do i = 12 to 15;
 825                     addr (regs) -> reg_array (i) = 8191;
 826                end;
 827 
 828 
 829 /*        We must reference the location in  etx  where we transfer to so we will not take
 830    *      a linkage fault when we actually call  etx$execute.
 831 */
 832 
 833                touch_word = addr (etx$execute) -> word_overlay;
 834                                                             /* ^L     */
 835 
 836 /*        The input script segment may contian data for more than one instruction.
 837    *      We will process one instruction at a time until we are told to stop.
 838    *      ( finished_flag will be  on ).  */
 839 
 840 
 841                do while (finished_flag = 0);
 842 
 843                     call test_instruction;
 844 
 845 condition_restart:
 846                end;                                         /* End the main  do  loop. */
 847 
 848           end;                                              /* end RPT loop */
 849 
 850 
 851 /*        We are all done so clean up input script if there was any.  */
 852 
 853           if gen_flag = 0
 854 
 855           then call hcs_$terminate_noname (script_ptr, code);
 856 
 857 
 858 
 859 /*        Logical end of  eis_tester.  */
 860 
 861           if ^hreg_state then
 862                call hcs_$history_regs_set ("0"b);           /* turn off hregs */
 863           return;
 864 
 865 /* ^L */
 866 test_instruction: procedure;
 867 
 868 
 869 /*        This procedure is called from the main  eis_tester  procedure.  It will set up
 870    *      and test one  eis  instruction.  Once it has parsed the input data describing this
 871    *      instruction it will set up the external segments and actually execute the
 872    *      instruction.  Before returning it will test the results of the instruction.
 873 */
 874 
 875                code = 0;
 876                error_flag = 0;
 877                name = " ";
 878                note = " ";
 879 
 880                test_count = test_count + 1;
 881 
 882 
 883 
 884 /*        Now we will set up to handle a truncation fault.
 885 */
 886 
 887 
 888 
 889 /*        Initialize the instruction area in  etx to all  nop  instructions. */
 890 
 891                do i = 1 to 7;
 892                     addr (etx$instruction_area) -> instr_overlay (i) =
 893                          "000000000000000000000001001000000000"b;
 894                end;
 895 
 896 
 897 
 898 /*        Now test the  "gen_flag" to see how we are getting our input.  */
 899 
 900 
 901                if gen_flag = 0
 902 
 903 
 904                then do;
 905 
 906                     call et_test (script_ptr, script_len, et_data_ptr, finished_flag, code);
 907 
 908                     if code ^= 0                            /* If anything is wrong don't bother
 909                                                                *  to test this instruction. */
 910                     then do;
 911                          call com_err_ (0, "ET", "Error in input statement for test:  ^d  -  ^a", test_count, name);
 912                          return;
 913                     end;
 914                end;
 915 
 916 
 917                else do;
 918 
 919                     call cu_$ptr_call (gen_seg_ptr, et_data_ptr);
 920 
 921                     finished_flag = 1;
 922 
 923                end;
 924 
 925 
 926 
 927 
 928 
 929 /*        See if we are to check for a special test to start with.
 930    *      If so we will count the number of tests we have parsed so far.  If this
 931    *      is not the one we want we will return and thus not process this test.
 932    *      If the start_flag is OFF then the do_flag must be ON and thus we will
 933    *      only do this one test.   If the start_flag is ON then we will stop counting
 934    *      the test and just do all the rest of the tests.  NOTE, if both flags
 935    *      are ON the  start_flag will override the do_flag.
 936 */
 937 
 938                if test_instr_flag = 1 then
 939                     if TEST_INSTR ^= name then return;
 940 
 941                if start_flag = 1
 942                then do;
 943                     if test_count ^= test_num (1)
 944                     then return;
 945 
 946                     else do;
 947                          start_flag = 0;
 948                          do_flag = 0;
 949                     end;
 950                end;
 951 
 952 
 953                if do_flag = 1 then do;
 954                     if test_num (SELECT) = -1 then do;
 955                          finished_flag = 1;
 956                          return;
 957                     end;
 958                     if test_count ^= test_num (SELECT)
 959                     then return;
 960                     else
 961                     SELECT = SELECT +1;
 962                end;
 963 
 964 
 965                if stop_flag = 1 then do;                    /* check for end test */
 966                     if test_count = stop_num then
 967                          finished_flag = 1;
 968                end;
 969 
 970                if brief_flag = 0 then
 971                     call ioa_ ("TEST ^3d (^a)", test_count, name);
 972 
 973 
 974 
 975 /*        First set up  the instruction in the  etx  segment.  */
 976 
 977 
 978 /*        Get a pointer to where we must place the instruction.  Note, the instruction
 979    *      area words that are not used are left as  nops.  Once we have the pointer
 980    *      we will move the instruction word.  Note, the instruction offset defined by
 981    *      the user is backwards as far as we are concerned.  We need the offset from the
 982    *      beginning of the instruction area.  We will convert it.
 983 */
 984 
 985                our_offset = (instr_offset - 3)* (-1);
 986 
 987                instr_ptr = addrel (addr (etx$instruction_area), our_offset);
 988 
 989                instr_ptr -> eis_map.instruction = instr_word;
 990 
 991 
 992 /*        Now set up the descriptor words.  If there is an indirect word it will take
 993    *      the place of a descriptor word.   In that case we must put the descriptor
 994    *      word somewhere else.
 995 */
 996 
 997                do i = 1 to 3;
 998 
 999                     if descriptors (i) ^= "0"b              /* Check to see if we must move this
1000                                                                *  descriptor. */
1001 
1002                     then do;                                /* Descriptor present - set it up. */
1003 
1004                          if ind_words (i) = "0"b            /* Check for indirect descriptor. */
1005 
1006 /*        If there is no indirect word just move the descriptor into the instruction
1007    *      in  etx.  */
1008                          then instr_ptr -> eis_map.desc_array (i) = descriptors (i);
1009 
1010 /*        If there is an indirect word then the indirect word will replace the
1011    *      descriptor in the  eis  instruction.  The descriptor will be move into
1012    *      a word as specified by the pointer in the desc_ptrs array. */
1013 
1014                          else do;
1015                               instr_ptr -> eis_map.desc_array (i) = ind_words (i);
1016                               desc_ptrs (i) -> word_overlay = descriptors (i);
1017                          end;
1018 
1019                     end;
1020 
1021                end;                                         /* End of descriptor move do loop.  */
1022 
1023 
1024 
1025 /*        Initialize the set_indicators word.  By default we will just have the  BAR MODE
1026    *      indicator ON.  If the user has specified that the instruction is to turn ON
1027    *      the  -  overflow, exponent overflow, or exponent underflow  -  indicators then
1028    *      we will turn  ON  the overflow mask so we will not get an overflow type fault
1029    *      from the test instruction.
1030 */
1031 
1032                set_indicators = init_indicators;
1033 
1034                if (substr (ir_word, 22, 1) = "1"b) |
1035                (substr (ir_word, 23, 1) = "1"b) |
1036                (substr (ir_word, 24, 1) = "1"b)
1037                then do;
1038                     substr (set_indicators, 25, 1) = "1"b;
1039                     substr (ir_word, 25, 1) = "1"b;
1040                end;
1041 
1042 
1043 
1044 /*        If there is test and result data we want to put special characters at the
1045    *      beginning and end of these data strings.  Thus if the  EIS  instruction
1046    *      incorrectly stores into words beyond the bounds of the result data string
1047    *      we will be able to recognize the error.  Eight special characters ("717" octal)
1048    *      will be stored at the beginning and end of these two strings.
1049 */
1050 
1051                if data_lens (tx) = 0 then goto print_instr_data;
1052 
1053 
1054                do i = tx to rx;
1055 
1056                     call et_util$char_rel (data_ptrs (i), -8);
1057                     data_lens (i) = data_lens (i) + 16;
1058 
1059                     do j = 1 to 8;
1060                          data_ptrs (i) -> data_array (j),
1061                               data_ptrs (i) -> data_array (data_lens (i) +1 -j) = dummy_test_char;
1062                     end;
1063 
1064                end;
1065 
1066 
1067 
1068 
1069 
1070 /*        Now if we are in VERBOSE mode we will print all of the data involved with
1071    *      this test.  We will start with the instruction itself
1072 */
1073 
1074 print_instr_data:
1075 
1076                if RPT > 1 then verbose_flag = 0;
1077 
1078 
1079                if verbose_flag = 0 then goto check_execute;
1080 
1081                call ioa_ ("^/Test Description:  ^a", note);
1082 
1083                call ioa_ ("^/Eis instruction:^-( ^p )   Ind  Desc.", instr_ptr);
1084 
1085                if instr_offset = 0
1086                then call ioa_ ("^4x- - - -- - - -");
1087 
1088                call ioa_ ("^5x^w", instr_ptr -> eis_map.instruction);
1089 
1090 
1091                do i = 1 to 3;
1092 
1093                     if instr_offset = i
1094                     then call ioa_ ("^4x- - - -- - - -");
1095 
1096                     if (i = 3) & (descriptors (3) = "0"b)
1097                     then goto print_ptrs;
1098 
1099                     if ind_words (i) = "0"b
1100 
1101                     then call ioa_ ("^5x^w", instr_ptr -> eis_map.desc_array (i));
1102 
1103                     else call ioa_ ("^5x^w^8x->      ^w   ( ^p )",
1104                          instr_ptr -> eis_map.desc_array (i),
1105                          descriptors (i), desc_ptrs (i));
1106                end;
1107 
1108 
1109 /*        Now print the pointer registers if any of them are being used.  */
1110 
1111 print_ptrs:
1112 
1113                do i = 0 to 7;
1114 
1115                     if pointers (i) ^= null ()
1116 
1117                     then do;
1118                          call ioa_ ("^/Pointer Registers:^-( ^p )", addr (etx$set_ptrs));
1119                          call ioa_ ("^5xpr0 - pr3    ^p  ^p  ^p  ^p",
1120                               pointers (0), pointers (1), pointers (2), pointers (3));
1121                          call ioa_ ("^5xpr4 - pr7    ^p  ^p  ^p  ^p",
1122                               pointers (4), pointers (5), pointers (6), pointers (7));
1123                          goto print_regs;
1124                     end;
1125                end;
1126 
1127 
1128 /*        If any of the index registers of the A or Q have been used then we will print out
1129    *      all of the index registers includeing A and Q.
1130 */
1131 
1132 print_regs:
1133 
1134                do i = 0 to 7;
1135                     if regs.x (i) ^= 8191
1136                     then goto found_used_regs;
1137                end;
1138 
1139                if (regs.A ^= 8191) | (regs.Q ^= 8191)
1140                then goto found_used_regs;
1141                else goto print_indicators;
1142 
1143 
1144 found_used_regs:
1145                call ioa_ ("^/Index Registers:^-( ^p  )", addr (etx$set_regs));
1146                call ioa_ ("^5x X0 - X7     ^6o ^6o ^6o ^6o ^6o ^6o ^6o ^6o",
1147                     regs.x (0), regs.x (1), regs.x (2), regs.x (3),
1148                     regs.x (4), regs.x (5), regs.x (6), regs.x (7));
1149                call ioa_ ("^5x    A  ^w      Q  ^w", regs.A, regs.Q);
1150 
1151 
1152 
1153 print_indicators:
1154 
1155                call ioa_ ("^/Test Indicators:^-( ^p )", addr (etx$indicators));
1156                call ioa_ ("^5x^w", ir_word);
1157 
1158 
1159 
1160 /*        Now print out the names of the pages which we will take faults on.  */
1161 
1162                workx = 0;                                   /* Initialize count of page faults.  */
1163 
1164                do i = 1 to 14;
1165 
1166                     print_pages (i) = " ";
1167 
1168                     if (page_faults (i) = "1"b) & (page_ptrs (i) ^= null)
1169 
1170                     then do;
1171                          workx = workx + 1;
1172                          print_pages (workx) = page_names (i);
1173                     end;
1174                end;
1175 
1176                if workx = 1
1177                then plural = " ";
1178                else plural = "s";
1179 
1180                call ioa_ ("^/This test will take  ^d  page fault^a.", workx, plural);
1181 
1182                if workx ^= 0
1183                then call ioa_ ("^4x^a^a^a^a^a^a^a^a^a^a^a^a^a^a",
1184                     print_pages (1), print_pages (2), print_pages (3), print_pages (4),
1185                     print_pages (5), print_pages (6), print_pages (7), print_pages (8),
1186                     print_pages (9), print_pages (10), print_pages (11),
1187                     print_pages (12), print_pages (13), print_pages (14));
1188 
1189 
1190 /*        Now print the data referenced by the descriptors.  We will print it only if the
1191    *      descriptor actually has data.
1192 */
1193 
1194                do datax = 1 to 3;
1195 
1196                     if data_ptrs (datax) ^= null () then call print_data;
1197                end;
1198 
1199 
1200 /*        Now print the test data.  */
1201 
1202                if data_lens (tx) ^= 0
1203 
1204                then do;
1205                     datax = tx;
1206                     call print_data;
1207                end;
1208 
1209 
1210 
1211 /*        We will test to see if we really are going to execute this instruction.
1212    *      If not we will just return.
1213 */
1214 
1215 check_execute:
1216 
1217                if nox_flag ^= 0 then return;
1218 
1219 
1220 /*        Now execute the instruction.  It will be executed the number of times
1221    *      specified in  loop_count.   Before each execution we must reset the data fields
1222    *      and set up the page faults.  After each test we will compare the data results
1223    *      and the settings of the indicator registers.  If the debug loop flag is  ON
1224    *      then we will override any loop count specified by the user and set the loop
1225    *      count to  10.
1226 */
1227 
1228 
1229                if debug_loop_flag = 1
1230                then loop_count = 10;
1231 
1232                do loopx = 1 to loop_count;
1233 
1234 
1235 /*        If there is a result area we will initialize it to the special fill characters.  */
1236 
1237                     if data_lens (rx) ^= 0
1238 
1239                     then do i = 9 to data_lens (rx) - 8;
1240                          data_ptrs (rx) -> data_array (i) = result_fill_char;
1241                     end;
1242 
1243 
1244 /*        Now move all the data fields into position.  */
1245 
1246                     do j = 1 to 3;
1247 
1248                          if (data_ptrs (j) ^= null ()) & (data_lens (j) ^= 0)
1249 
1250                          then do;
1251                               data_len = data_lens (j);
1252                               data_ptrs (j) -> data = set_data_ptrs (j) -> data;
1253                          end;
1254 
1255                     end;                                    /* End of the data set up loop.  */
1256 
1257 
1258 /*        Now set up the pointer registers,  registers, and the indicator word in
1259    *      etx.  Before we store the index registers which  etx  will use we must put
1260    *      our instruction offset in  X0.   etx uses X0 so it can transfer directly to the
1261    *      first word of the eis instruction and not just the beginning of the instruction
1262    *      area.
1263 */
1264 
1265                     regs.x (0) = our_offset;
1266 
1267                     addr (etx$set_ptrs) -> ptr_array = pointers;
1268 
1269                     addr (etx$set_regs) -> reg_array = addr (regs) -> reg_array;
1270 
1271                     addr (etx$set_ind) -> word_overlay = set_indicators;
1272                     addr (etx$indicators) -> word_overlay = "0"b;
1273 
1274 /*        Now set up the handlers for possible conditions */
1275 
1276                     truncation_label = check_errors;
1277                     on stringsize begin;                    /* truncation handler */
1278 
1279 
1280 /*        If the truncation flag is not  ON  then we took an illegal truncation fault.
1281 */
1282 
1283                          if truncation_flag = 0
1284                          then do;
1285                               error_flag = 1;
1286                               call com_err_ (0, "ET", "Unexpected truncation fault for test:  ^d  -  ^a", test_count, name);
1287                               call display_mc_;
1288                               go to truncation_label;
1289                          end;
1290 
1291 
1292 /*        This truncation fault is OK.  We will trun off the truncation flag so that the
1293    *      error checking code will not think that there is an error.
1294 */
1295 
1296 
1297                          else truncation_flag = 2;
1298                          go to truncation_label;
1299                     end;
1300 
1301                     if ^sof_ then go to SETUP;              /* just run like old unless told otherwise */
1302 
1303 
1304                     on condition (et_error) begin;
1305                          cond_infop = addr (cond_info);
1306                          call find_condition_info_ (null (), cond_infop, code);
1307                          int_cond_name = cond_info.condition_name;
1308                          call display_mc_;
1309                          call continue_to_signal_ (code);
1310                     end;                                    /* end any_other */
1311 SETUP:
1312 
1313 
1314 
1315 /*        Now we will flush out all of the pages used by this process.
1316    *      Then we can bring back the ones we want - thus leaving faults
1317    *      set in the pages that we want to take faults on.  */
1318 
1319 
1320 
1321 LOOP:               call DEACTIVATE;
1322 
1323 
1324 /*        Look through the page_fault table.  Those entries that are ON represent
1325    *      pages that should take faults during the execution of the  eis  instruction.
1326    *      We will leave them alone since after the  flush we will assume that they
1327    *      are not in core.  Those entries that are still  OFF we will touch so that
1328    *      we can be sure that they are in core and will not take a page fault during
1329    *      the execution of the  eis  instruction.  We assume, of course, that there
1330    *      is not enough paging going on to drive these pages out before we can
1331    *      execute the  eis  instruction.
1332 */
1333 
1334                     do i = 1 to 14;
1335 
1336                          if (page_faults (i) = "0"b) & (page_ptrs (i) ^= null ())
1337 
1338                          then touch_word = page_ptrs (i) -> word_overlay;
1339 
1340                     end;
1341 
1342 
1343 /*        Now we can execute the  eis  instruction.  */
1344 
1345 
1346                     call etx$execute;
1347                     revert stringsize;
1348 
1349 
1350 /*        Once we have returned from  etx  we must test the resulting data and the
1351    *      resulting indicator word.  Note, some instructions do not actually move any
1352    *      data and thus there is no result data to test.  Note, if the debug loop
1353    *      flag is  ON  then we will not test the results.  We will just go back and
1354    *      and do the test again.
1355 */
1356 
1357 
1358 check_errors:
1359 
1360                     if debug_loop_flag = 1
1361                     then goto end_test_loop;
1362 
1363                     data_len = data_lens (rx);
1364 
1365                     if data_len ^= 0
1366 
1367                     then if data_ptrs (tx) -> data ^= data_ptrs (rx) -> data
1368 
1369                          then do;                           /* Print  data fields in octal. */
1370                               call ioa_ ("^/Data resulting from test ( ^d - ^a ) is incorrect.", test_count, name);
1371                               datax = rx;
1372                               call print_data;              /* Print the invalid result data. */
1373                               error_flag = 1;
1374                          end;
1375 
1376 
1377 /*        If we took a truncation fault we will not check the indicators since the
1378    *      sti  instruction in  etx  was not executed.
1379 */
1380 
1381                     if truncation_flag = 2
1382                     then goto check_for_trun;
1383 
1384                     if addr (etx$indicators) -> word_overlay ^= ir_word
1385 
1386                     then do;
1387                          call ioa_ ("^/Indicators not set correctly for test:  ^d  -  ^a", test_count, name);
1388                          call ioa_ ("^/Test   indicator word is: ^w", ir_word);
1389                          call ioa_ ("Result indicator word is: ^w",
1390                               addr (etx$indicators) -> word_overlay);
1391                          error_flag = 1;
1392                     end;
1393 
1394 
1395 /*        If the truncation flag is ON then we were expecting a truncation fault but none
1396    *      occurred.  If one had occurred the handler would have set the flag to  2.
1397 */
1398 
1399 check_for_trun:
1400 
1401                     if truncation_flag = 1
1402                     then do;
1403                          call com_err_ (0, "ET", "^/Expected truncation fault did not occur.");
1404                          error_flag = 1;
1405                     end;
1406 
1407                     if error_flag = 1 then
1408                          call ioa_ ("^/*** TEST NOTES: ^a ***^/", note);
1409 
1410                     if (error_flag = 1) & (sof_ = "1"b) then
1411                          signal et_error;
1412 
1413 end_test_loop:
1414                end;                                         /* End of the  test  loop.  */
1415 
1416 
1417 /*        This is the logical end of   test_instructions    */
1418 /* ^L */
1419 print_data:    procedure;
1420 
1421 
1422 
1423 /*        This procedure is called to print out a data field.  the data field will be
1424    *      printed in octal words, four words to the line.  The first line printed
1425    *      will contain the name of the data field and a pointer to the data field.
1426    *      Note, the special fill characters will be converted so they will not be printed
1427    *      out as octal digits.  They will be converted to:
1428    *      dummy_print_char  -  3 blanks  "   "
1429    *      dummy_fill_char   -  3 x's     "xxx"
1430 */
1431 
1432 
1433                     call ioa_ ("^/^a^-( ^p )", data_names (datax), data_ptrs (datax));
1434 
1435 
1436 /*        If the length of this data is zero then this data field must be a result field.
1437    *      We will print a message telling the user this and  also print what the fill character
1438    *      will be.
1439 */
1440 
1441                     if data_lens (datax) = 0
1442 
1443                     then do;
1444                          call ioa_ ("^5xResult data field initialized to all zero bits.");
1445                          return;
1446                     end;
1447 
1448 
1449 /*        Get a pointer to the data to print.  We also need its length.  If we are printing
1450    *      the data for a descriptor we will use the data in the set up areas of  etx.
1451 */
1452 
1453                     if set_data_ptrs (datax) = null ()
1454 
1455                     then print_ptr = data_ptrs (datax);
1456                     else print_ptr = set_data_ptrs (datax);
1457 
1458                     print_len = data_lens (datax);
1459 
1460 
1461 /*        Since we will be printing full words we must set the unused characters in the
1462    *      first word to a special value.  We must also adjust the print pointer so that
1463    *      it points to what we now consider the beginning of the first word of the
1464    *      string.  Note, this may not actually be on a word boundary.
1465 */
1466 
1467                     call et_util$char_rel (print_ptr, -data_offsets (datax));
1468                     print_len = print_len + data_offsets (datax);
1469 
1470                     do i = 1 to data_offsets (datax);
1471                          print_ptr -> data_array (i) = dummy_print_char;
1472                     end;
1473 
1474 
1475 /*        Now we must fill in the unused characters of the last word of the string.  They
1476    *      will be set to the same dummy character.
1477 */
1478 
1479                     workx = print_len - 1;
1480                     workx = 4 - (print_len - (divide (workx, 4, 17, 0))*4);
1481 
1482                     do i = 1 to workx;
1483                          print_len = print_len + 1;
1484                          print_ptr -> data_array (print_len) = dummy_print_char;
1485                     end;
1486 
1487 
1488 /*        Now we will print the data string.   A maximum of   4  words of data will be
1489    *      printed on each line.  Duplicate lines will be suppressed.
1490 */
1491 
1492                     skip_count = 0;                         /* Initialize count of the duplicate lines. */
1493 
1494                     dup_string = "_$<-+;*><)(:|||";
1495 
1496                     num_words = divide (print_len, 4, 17, 0);
1497 
1498 
1499 
1500 
1501                     do while (num_words > 0);               /* Each iteration prints 1 line. */
1502 
1503                          if num_words > 3                   /* Get number of words in this line. */
1504                          then workx = 4;
1505                          else workx = num_words;
1506 
1507                          num_words = num_words - 4;
1508 
1509                          if (num_words > 0) & (print_ptr -> based_string = dup_string)
1510 
1511 
1512                          then do;                           /* This line is a duplicate of the previous
1513                                                                *  line.  If it is not the last line we will
1514                                                                *  skip it.  The last line is always printed.  */
1515                               skip_count = skip_count + 1;
1516                               print_ptr = addr (print_ptr -> data_array (17));
1517                               goto end_line;
1518                          end;
1519 
1520 
1521 /*        This is the last line or it is not the same as the previous line.  */
1522 
1523                          if skip_count ^= 0                 /* Were there duplicate lines before? */
1524 
1525                          then do;                           /* YES. */
1526                               if skip_count = 1
1527                               then plural = " ";
1528                               else plural = "s";
1529                               call ioa_ ("^5xPrevious line repeated  ^d  time^a.", skip_count, plural);
1530                               skip_count = 0;
1531                          end;
1532 
1533 /*        Move the line to be printed to an aligned area so it can be printed as an array
1534    *      of words.  Save it in the duplicate string so we can test the next line.
1535    *      Then we must update the print pointer to reference the next line.
1536 */
1537 
1538                          print_string = print_ptr -> based_string;
1539 
1540                          dup_string = print_ptr -> based_string;
1541 
1542                          print_ptr = addr (print_ptr -> data_array (17));
1543 
1544 
1545 /*        Now convert the string of octal words to the character representation for these
1546    *      octal digits.  This is done just so the special dummy characters will not be
1547    *      printed in octal.
1548 */
1549 
1550                          do i = 1 to workx;                 /* One iteration for each word in the line. */
1551 
1552                               char_word = char_words (i);
1553 
1554                               do j = 1 to 4;                /* One iteration for each character in
1555                                                                *  the word.  */
1556 
1557                                    character = substr (char_word, j, 1);
1558 
1559                                    if character = dummy_print_char
1560                                    then do;
1561                                         xx = 1 + (j-1)*3;
1562                                         substr (print_chars (i), xx, 3) = "   ";
1563                                         goto end_char;
1564                                    end;
1565 
1566                                    if character = dummy_test_char
1567                                    then do;
1568                                         xx = 1 + (j-1)*3;
1569                                         substr (print_chars (i), xx, 3) = "xxx";
1570                                         goto end_char;
1571                                    end;
1572 
1573                                    do k = 1 to 3;
1574                                         xx = k + (j-1)*3;
1575                                         substr (print_chars (i), xx, 1) =
1576                                              oct_chars (fixed (char_bits (k), 3));
1577                                    end;
1578 
1579 end_char:
1580                               end;
1581                          end;
1582 
1583 
1584 /*        Use the  "ioa_" call for the number of words in this line.  If the
1585    *      number is less than 4 we know this is the last line.
1586 */
1587 
1588                          goto print_line (workx);
1589 
1590 
1591 
1592 print_line (1):
1593 
1594                          call ioa_ ("^5x^a", print_chars (1));
1595 
1596                          return;
1597 
1598 
1599 print_line (2):
1600 
1601                          call ioa_ ("^5x^a  ^a", print_chars (1), print_chars (2));
1602 
1603                          return;
1604 
1605 
1606 print_line (3):
1607 
1608                          call ioa_ ("^5x^a  ^a  ^a", print_chars (1),
1609                               print_chars (2), print_chars (3));
1610 
1611                          return;
1612 
1613 
1614 print_line (4):
1615 
1616                          call ioa_ ("^5x^a  ^a  ^a  ^a", print_chars (1), print_chars (2),
1617                               print_chars (3), print_chars (4));
1618 
1619 
1620 end_line:
1621 
1622                     end;                                    /* This is the end of the print  do  loop. */
1623 
1624 
1625                end print_data;
1626 
1627 
1628 
1629 
1630 
1631           end test_instruction;
1632                                                             /* ^L     */
1633 display_mc_: proc;
1634 
1635 dcl  cu_$stack_frame_ptr entry (ptr);
1636 dcl  find_condition_frame_ entry (ptr) returns (ptr);
1637 dcl  find_condition_info_ entry (ptr, ptr, fixed bin (35));
1638 dcl  dump_machine_cond_ entry (ptr, ptr, char (32) aligned, fixed bin);
1639 dcl  hran_$hranl entry (ptr, ptr, bit (1));
1640 dcl  hreg_ptr ptr;
1641 
1642 
1643 dcl 1 condinfo aligned,
1644 % include cond_info;
1645 
1646      dcl (stackp, faultsp) ptr;
1647 dcl (null, addr) builtin;
1648 dcl  ec fixed bin (35);
1649 
1650 
1651                call cu_$stack_frame_ptr (stackp);           /* get current stack pointer */
1652                faultsp = find_condition_frame_ (stackp);    /*  is this the condition frame? */
1653                if faultsp = null then do;                   /* no */
1654                     call ioa_ (" No condition frame.");
1655                     return;
1656                end;
1657                else call find_condition_info_ (faultsp, addr (condinfo), ec); /* get a pointer to the machine conditions */
1658                if condinfo.mcptr = null () then
1659                     return;
1660                call ioa_ ("^/MACHINE CONDITIONS AT ^p:^/", condinfo.mcptr);
1661 
1662                call dump_machine_cond_ (addr (condinfo), faultsp, "user_output", 2); /* print the MC */
1663                if mcptr ^= null then
1664                     hreg_ptr = addrel (mcptr, 96);
1665                if hreg_ptr = null then do;                  /* no history regs to dump */
1666                     call ioa_ ("History Registers are not available");
1667                     return;
1668                end;
1669                else do;
1670                     call ioa_ ("CPU HISTORY REGISTERS AT TIME OF FAULT");
1671                     call hran_$hranl (hreg_ptr, null, long_hregs);
1672                end;
1673 
1674                return;
1675           end display_mc_;
1676 
1677 %page;
1678 DEACTIVATE: proc;
1679 dcl  i fixed bin;
1680 
1681 /* Deactivate each segment.  This will force its pages out of memory. */
1682 
1683 
1684                do i = 1 to 14;
1685                     if page_ptrs (i) ^= null () then
1686                          if baseno (page_ptrs (i)) ^= "077777"b3 then
1687                               call phcs_$deactivate (page_ptrs (i), code);
1688                end;
1689 
1690 
1691                return;
1692 
1693           end DEACTIVATE;
1694 
1695 
1696 
1697      end eis_tester;