



		    et.pl1                          05/19/83  0955.5rew 05/19/83  0953.1      438975



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


eis_tester: et: procedure;


/*	This procedure is the main procedure in the  eis  instruction tester.
   *	It calls  "et_test"  to parse the statements in the user provided data
   *	file.  It translates these statements into the data needed to build and
   *	test an eis instruction in the external segment  etx.     After building
   *	the instruction this procedure will call  etx  in order to execute the  eis
   *	instructuion.  When  etx returns the results of the eis instruction will be
   *	examined.   "et"  will continue to build  and test  eis instructions until
   *	there is no data left in the input file.
   *
   *	Each instruction may be tested several times.  Also, the user may specify
   *	that variations of the same instruction be tested.  Each variation may be
   *	tested several times.
   *
   *	Note, the failure of one instruction will only cause the termination of that
   *	one instruction test.  Any remaining instructions specified in the input
   *	file will be processed and tested.
   *
   *	Created  Oct, 72  by  Bill Silver.
   *	Modified Aug, 80 by R. L. Coppola to add the -to control arg, and
   *	display_mc_ procedure, also increased declaration of several fixed bin
   *	variables to fixed bin (35) to enable processing of the new ets scripts.
   *      Modified March 1981 by Rich Coppola for DPS8 history reg support.
   *	Modified March 31, 1983 by GA Texada to make the argument processing more Multicious.
   *
   *
   *	ET  has two entries.  Both are called with one command option - a path name.
   *
   *	1.  et        aaaa		The path name  "aaaa"  refers to a segment which
   *				contains input script data which defines the
   *				instruction to test.  This is the main entry.
   *
   *	2.  et$gen    aaaa		The path name  "aaaa"  refers to a procedure which
   *				will generate the  ET data needed to test ONE
   *				instruction.
   *
   *	In addition each entry may be called with two optional arguments.
   *
   *	     a)  "-bf"	Specifies that BRIEF mode will be entered.  All but identification
   *			and error messages will be suppressed.
   *
   *	     b)  "-nox"	Specifies  NO eXecute mode.  This implies that the instruction
   *			will be set up but not executed.  It is used to test the validity
   *			of the input script.
   *
   *	     c)  "-debug"	Specifies that this test is to be run in a  DEBUGGING  LOOP.
   *			Each instruction will be tested  10  times.  The results from
   *			the test will not be checked.  Each time through the loop the
   *			instruction will be set up completeley including all the
   *			specified page faults.
   *
   *	     d)  "-do" X	X is a positive decimal number which specifies the NUMBER of
   *			the test that is to be processed.  This number has NO
   *			relationship to the  -ns  field in any test.
   *
   *	     e)  "-fm" X	X is the number of the first test that will be processed.  All
   *			remaining tests in the input segment will also be processed
   *			unless the -to option is also selected..


   *	     f)  "-to" X	X is the number of the last test that will be processed.
*/






/*		AUTOMATIC  DATA		*/


dcl  script_ptr ptr,				/* Pointer to the input data file.  */

     script_len fixed bin,				/* The length of the input data file.  */

     gen_seg_ptr ptr;				/* Pointer to the procedure segment which
						   *  will generate the input test data.  */



/*	This is the area where the  et_setup_data  resides.  It is declared as pointers
   *	so it will begin on an even word boundary.  It is slightly longer than necessary.
*/

dcl  setup_data_area (92) ptr;

dcl  code fixed bin (35),				/* Error code. */

     dup_string char (16),				/* Area where the previous line is saved.  */

     debug_loop_flag fixed bin,			/* Used to specify a tight loop from command
						   *  level.  Will not even test results of test.  */

     plural char (1),				/* Used to add an "s" to the end of words
						   *  in a print line.  */

     print_string char (16) aligned,			/* Area where the lines of data are printed. */

     print_pages (14) char (4),			/* Used to print the names of the pages
						   *  which this instruction will fault on.  */

     print_ptr ptr,					/* Pointer to the line being printed. */

     print_len fixed bin,				/* The number of characters still to be printed. */

     long_hregs bit (1) init ("0"b),			/* prints octal hregs if = 1 */

     num_words fixed bin,				/* The number of words in a string to be printed */


     line_length fixed bin,

     set_indicators bit (36),				/* Word used to set up the indicators in  etx.  */

     skip_count fixed bin,				/* The number of duplicated print lines
						   *  that have been skipped.  */

     test_num (10) fixed bin,				/* The number of the special test(s) we are
						   *  looking for due to a  "-fm" or "-do" option. */

     TEST_INSTR char (6) var init (""),			/* The type of instruction we want to test */

     stop_num fixed bin,				/* The number of the last test we are to run */

     times_to_repeat fixed bin,			/* The number of times to repeat a set of scripts */

     RPT fixed bin init (1),				/* itreration var for repeat opt */

    (SEL, SELECT) fixed bin,				/* used to set up and select a set of tests */


     temp_seg_name char (32),				/* name of temp seg being created */
     temp_segp ptr,					/* pointer to temp seg being created */
     copy_segp ptr,					/* pointer to segment to copy into temp seg */
     copy_bit_count fixed bin (24),			/* bit count of seg to copy */
     type fixed bin (2),
     sof_ bit (1) init ("0"b);			/* stop on test failure */

dcl  terminate_sel bit (1);


dcl (brief_flag, verbose_flag) fixed bin,		/* Used to suppress printing the data of
						   *  an instruction.  */

     gen_flag fixed bin,				/* Used to call a procedure to generate
						   *  the test data.  */

     nox_flag fixed bin,				/* Used to denote that the instructions are
						   *  not to be executed.  */

     finished_flag fixed bin,				/* Indicates when all of the instructions
						   *  have been tested.  */

     error_flag fixed bin,				/* ON when an error has been found.  */

     do_flag fixed bin,				/* Indicates that we are looking for one special
						   *  test to run.  */

     start_flag fixed bin,				/* Indicates that we are looking for one special
						   *  test to start with.  All test following it will
						   *  be processed unless the stop_ flag is set.  */

     remember_start fixed bin,			/* need to remember start falg when repeating */

     test_instr_flag fixed bin,			/* indicates we are looking for a type of instr */

     stop_flag fixed bin;				/* indicates we are to look for a test number which will stop our processing */



dcl  arg_ptr ptr,					/* Pointer to input argument. */
     arg_len fixed bin,				/* Length  of input argument. */
     num_args fixed bin,				/* Number of arguments to ET. */
     dir_name char (168),				/* Directory containing input file. */
     ent_name char (32),				/* Entry name of input file. */
     bit_count fixed bin (24);			/* Size of data file in bits. */


dcl  print_chars (1:4) char (12),			/* Used to print a word in octal while
						   *  doing some of our own editing.  */

     char_word char (4),				/* One word of the octal string se are printing. */

     character char (1);				/* One character of the octal print string. */


dcl (i, j, k, xx, argcount) fixed bin,			/* Work indexes. */
     loopx fixed bin,				/* Main test loop index. */
     datax fixed bin;				/* Index used to print data areas.  */

dcl  hreg_state bit (1) aligned;			/* state of this processes hreg switch */

dcl 1 bug_structure,				/* Just here for compiler bug. */
   (2 dummy_print_char char (1),			/* Used to pad data strings for printing so
						   *  they occupy fill words.  "707" octal. */
    2 dummy_test_char char (1),			/* Used to pad the beginning and end of the
						   *  test and result fields.  "717" octal. */
    2 result_fill_char char (1),			/* Used to fill in the result field.
						   *  "000" octal.  */
    2 bug_pad char (1)) unaligned;
dcl  touch_word bit (36),				/* Used to touch a page in order to bring
						   *  it into core.  */
     workx fixed bin,				/* A work variable.  */
     wptr ptr;					/* A work pointer.  */
dcl  int_cond_name char (32);

dcl  cond_infop ptr;				/* pointer to condition info */

dcl  instr_ptr ptr,					/* Pointer to where the  eis  instruc-
						   *  tion goes in  etx.  */

     save_data_ptr ptr,				/* Used to save a data pointer while printing. */

     our_offset fixed bin;				/* The instruction offset after it has been
						   *  converted from the input version to the
						   *  version we need internally.  Our offset
						   *  is from the beginning of the instruction
						   *  area and not from the end of the page.  */

dcl 1 akst aligned like kst_attributes;



/*		BASED  DATA		*/


dcl 1 eis_map based,				/* Map of the whole  eis  instruction. */
    2 instruction bit (36),
    2 desc_array (3) bit (36);


dcl  instr_overlay (7) bit (36) based;			/* Used to reference the  etx  instruc-
						   *  tion area as an array of words. */


dcl  word_overlay bit (36) based,			/* Used to reference an individual word. */

     char_overlay bit (9) based,			/* Used to reference one character.  */

     based_string char (16) based unaligned,		/* Used to reference one line of input
						   *  data that is actually in the data
						   *  string being printed.  */

/*	These arrays are used to reference the print string as an array of words and
   *	and a character as an array of 3 octal digits.
*/

     char_words (4) char (4) based (addr (print_string)) aligned,

     char_bits (3) bit (3) based (addr (character)) unaligned;



/*	This array is used to reference a data string as an array of characters.  */

dcl  data_array (1:4352) char (1) based unaligned,

     ptr_array (8) ptr based,				/* Used to reference the pointer
						   *  registers as an array of pointers. */

/*	reg_array is used to reference the registers as an array of half words.  */

     reg_array (16) fixed bin (17) based unaligned;

dcl script_path char(501);				/* make pathname big enough...		*/


dcl  data char (data_len) based,			/* Used to reference the data areas. */

     data_len fixed bin;				/* Size of the data field.  */



/*        used to copy a segment into a temporary segment */

dcl  copy_seg char (divide (copy_bit_count + 8, 9, 21, 0)) based;




/*		INTERNAL  STATIC  DATA	*/



/*	This table points to the three set up areas for data in etx.    Entries 4 and 5 are
   *	dummy entries.  They make this array correspond to the data_ptrs array.
*/

dcl  set_data_ptrs (5) ptr internal static;


/*	Word used to initialize the word we use to set up the indicators.
   *	The  BAR MODE indicator bit is always ON
*/
dcl  init_indicators bit (36) internal static
     init ("000000000000000000000000000010000000"b);




/*	This table contains static constants which are used to identify data
   *	strings when they are typed.  */

dcl  data_names (5) char (12) internal static
     init ("data field 1", "data field 2", "data field 3",
     "test  data  ", "result data ");


/*	This table contains the names of the pages which are defined by ET. */

dcl  page_names (14) char (4)
     init (" in1", " in2",
     " id1", " d11", " d12", " d13",
     " id2", " d21", " d22", " d23",
     " id3", " d31", " d32", " d33");

dcl  tx fixed bin internal static init (4),		/* Index to data arays for */
     rx fixed bin internal static init (5);		/* test and result data fields. */


dcl  oct_chars (0:7) char (1) internal static aligned
     init ("0", "1", "2", "3", "4", "5", "6", "7");

dcl  segs_initialized bit (1) internal static init ("0"b);

dcl  seg_ref_names (7) char (32) internal static options (constant)
     init ("etx", "eti1", "eti2", "eti3", "etd1", "etd2", "etd3");

dcl  condition_label label internal static,
     truncation_label label internal static;
dcl (stringsize, quit, et_error) condition;


/*  */
/*		EXTERNAL  DATA		*/


/*	The following declarations reference the dummy programs used to execute
   *	the  eis  instructions.
*/

dcl (etx$set_ptrs, etx$set_regs,
     etx$set_ind, etx$indicators,
     etx$instruction_area,
     etx$set_data1, etx$set_data2, etx$set_data3) external;


dcl  com_err_ entry options (variable),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     cu_$arg_count entry (fixed bin),
     cu_$ptr_call entry options (variable),
     get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin),
     find_condition_info_ entry (ptr, ptr, fixed bin (35)),
     continue_to_signal_ entry (fixed bin (35)),
     et_util$char_rel entry (ptr, fixed bin),
     etx$execute entry options (variable),
     expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)),
     hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24),
     fixed bin (12), ptr, fixed bin (35)),
     hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)),
     hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)),
     hcs_$history_regs_get entry (bit (1) aligned),
     hcs_$history_regs_set entry (bit (1) aligned),
     hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)),
     hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)),
     hcs_$terminate_name entry (char (*), fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35)),
     phcs_$deactivate entry (ptr, fixed bin (35)),
     phcs_$set_kst_attributes entry (fixed bin (35), ptr, fixed bin (35)),
     ioa_ entry options (variable),
     unique_bits_ entry () returns (bit (70)),
     unique_chars_ entry (bit (*)) returns (char (15)),
     error_table_$badopt fixed bin(35) ext static,
     error_table_$bad_arg fixed bin (35) ext static,
     et_test entry (ptr, fixed bin, ptr, fixed bin, fixed bin (35));

%page;
%include kst_attributes;

dcl 1 cond_info aligned,
% include cond_info;


     dcl (addr, addrel, baseno, divide, fixed, hbound, null, rtrim, substr, unspec, verify) builtin;
%page;
%include et_setup_data;
%page;

	times_to_repeat = 1;
	test_num (*) = -1;
	script_path = "";
	SELECT = 1;
	

/*	 see if there are any optional arguments to  ET.  */

	verbose_flag, brief_flag, nox_flag = 0;		/* Initialize the flags OFF. */

	call cu_$arg_count (num_args);
	if num_args <= 0 then goto USAGE;

	debug_loop_flag = 0;			/* Zero implies we are not going to be
						   *  in a  debug  loop.  */
	remember_start, start_flag, stop_flag, do_flag = 0;
               do argcount = 1 to num_args;
	     call cu_$arg_ptr (argcount, arg_ptr, arg_len, code);

	     if code ^= 0
	     then do;
		call com_err_ (code, "ET", "Can't get command argument ^d", argcount);
		return;
	     end;
new_arg:
	     data_len = arg_len;

	     if arg_ptr -> data = "-help"
	     then go to USAGE;

	     else if arg_ptr -> data = "-bf"
	     | arg_ptr -> data = "-brief"
	     then brief_flag = 1;


	     else if arg_ptr -> data = "-long"
	     | arg_ptr -> data = "-lg" then
		verbose_flag = 1;


	     else
	     if arg_ptr -> data = "-nox"
	     then nox_flag = 1;

	     else
	     if arg_ptr -> data = "-debug"
	     then debug_loop_flag = 1;

	     else
	     if (arg_ptr -> data = "-fm")
	     | (arg_ptr -> data = "-from")
	     then do;

		start_flag, remember_start = 1;

		if argcount = num_args
		then do;
		     code = error_table_$bad_arg;
		     call com_err_ (code, "ET", "No number following ^a option.",
			arg_ptr -> data);
			return;
		end;

		argcount = argcount + 1;

		call cu_$arg_ptr (argcount, arg_ptr, arg_len, code);
		if code ^= 0 then goto bad_arg ;

		test_num (1) = verify (substr (arg_ptr -> data, 1, arg_len), "0123456789");

		if test_num (1) ^= 0
		then do;
		     code = error_table_$bad_arg;
		     call com_err_ (code, "ET", "Illegal numeric option argument: ^a",
			arg_ptr -> data);
		     return;
		end;
		test_num (1) = fixed (substr (arg_ptr -> data, 1, arg_len), 17);
	     end;


	     else
	     if (arg_ptr -> data = "-instruction_type")
	     | (arg_ptr -> data = "-inst")
	     then do;


		if argcount = num_args
		then do;
		     code = error_table_$bad_arg;
		     call com_err_ (code, "ET", "No instruction type following ^a option.",
			arg_ptr -> data);
		     return;
		end;

		argcount = argcount + 1;

		call cu_$arg_ptr (argcount, arg_ptr, arg_len, code);
		if code ^= 0 then go to bad_arg;

		TEST_INSTR = substr (arg_ptr -> data, 1, arg_len);
		test_instr_flag = 1;
		if substr (TEST_INSTR, 1, 1) = "-"
		then do;
		     code = error_table_$bad_arg;
		     call com_err_ (code, "ET", "An instruction type does not follow argument: ^a",
			arg_ptr -> data);
		     return;
		end;
	     end;


	     else if arg_ptr -> data = "-to"
	     then do;

		stop_flag = 1;

		if argcount = num_args then do;
		     code = error_table_$bad_arg;
		     call com_err_ (code, "ET", "No number following ^a option.", arg_ptr -> data);
		     return;
		end;

		argcount = argcount + 1;
		call cu_$arg_ptr (argcount, arg_ptr, arg_len, code);
		if code ^= 0 then go to bad_arg;
		stop_num = verify (substr (arg_ptr -> data, 1, arg_len), "0123456789");
		if stop_num ^= 0 then do;
		     code = error_table_$bad_arg;
		     call com_err_ (code, "ET", "Illegal numeric option argument: ^a", arg_ptr -> data);
		     return;
		end;

		stop_num = fixed (substr (arg_ptr -> data, 1, arg_len), 17);
	     end;


	     else
	     if (arg_ptr -> data = "-do")
	     | (arg_ptr -> data = "-select")
	     | (arg_ptr -> data = "-sel")
	     then do;

		do_flag = 1;

		if argcount = num_args
		then do;
		     code = error_table_$bad_arg;
		     call com_err_ (code, "ET", "No number following ^a option.",
			arg_ptr -> data);
		     return;
		end;

		terminate_sel = "0"b;
		SELECT = 0;
		do SEL = 1 to 10 while (^terminate_sel); /* get the set to run */
		     argcount = argcount + 1;

		     call cu_$arg_ptr (argcount, arg_ptr, arg_len, code);

		     if code ^= 0 then do;
			if SEL = 1 then do;
bad_sel_arg:		     call com_err_ (code, "ET", "No number following the select arg.");
			     return;
			end;
			terminate_sel = "1"b;
			go to set_up_sel;
		     end;

		     if substr (arg_ptr -> data, 1, 1) = "-" then do;

			if SEL = 1 then do;
			     code = error_table_$bad_arg;
			     go to bad_sel_arg;
			end;
			argcount = argcount -1;
			terminate_sel = "1"b;
			go to set_up_sel;
		     end;

		     test_num (SEL) = verify (substr (arg_ptr -> data, 1, arg_len), "0123456789");

		     if test_num (SEL) ^= 0
		     then do;
			if (SEL >1) & ((substr(arg_ptr->data, 1, 1) ="-")
			     | (script_path = "")) then goto new_arg;
			code = error_table_$bad_arg;
			call com_err_ (code, "ET", "Illegal numeric option argument: ^a",
			     arg_ptr -> data);
			return;
		     end;
		     test_num (SEL) = fixed (substr (arg_ptr -> data, 1, arg_len), 17);

		end;
		SELECT = SELECT + 1;
set_up_sel:
	     end;

	     else if arg_ptr -> data = "-stop_on_failure"
	     | arg_ptr -> data = "-sof"
	     then sof_ = "1"b;

	     else if arg_ptr -> data = "-repeat"
	     | arg_ptr -> data = "-rpt" then do;
		if argcount = num_args then do;
		     code = error_table_$bad_arg;
		     call com_err_ (code, "ET", "No number following ^a option.", arg_ptr -> data);
		     return;
		end;

		argcount = argcount + 1;
		call cu_$arg_ptr (argcount, arg_ptr, arg_len, code);
		if code ^= 0 then go to bad_arg;
		times_to_repeat = verify (substr (arg_ptr -> data, 1, arg_len), "0123456789");

		if times_to_repeat ^= 0 then do;
		     code = error_table_$bad_arg;
		     call com_err_ (code, "ET", "Illegal numeric option argument: ^a", arg_ptr -> data);
		     return;
		end;

		times_to_repeat = fixed (substr (arg_ptr -> data, 1, arg_len), 17);

	     end;
	     else
use_as_script_path:
	     if script_path = "" then script_path = arg_ptr -> data;
	     else do;
		if substr(arg_ptr -> data, 1, 1) = "-" then code = error_table_$badopt;
		else
bad_arg:	          code = error_table_$bad_arg;
ARG_ERROR:	call com_err_ (code, "ET", "^a.", arg_ptr -> data);
		return;
USAGE:		call ioa_ ("ET: Usage is: et path {-control_args}");
		call ioa_ ("Valid control args: -brief, -bf^/^-^--debug");
		call ioa_ ("^-^--from TEST_NUM,-fm TEST_NUM^/^-^--instruction_type INSTR, -inst INSTR");
		call ioa_ ("^-^--long, -lg^/^-^--nox^/^-^--repeat NUM, -rpt NUM");
		call ioa_ ("^-^--select TEST_NUM, -sel TEST_NUM^/^-^--stop_on_failure, -sof^/^-^--to TEST_NUM");

incons_arg:
		if ^hreg_state then			/* if they were off when we started.. */
		     call hcs_$history_regs_set ("0"b); /* turn off hregs */
		return;
	     end;

	end;
%page;



/*	"eis_tester" (ET) is called with one command option - the path name of a
   *	segment containing input script data or the path name of a procedure which will
   *	be called to set up the input data.
*/


	gen_flag = 0;				/* This is the normal entry.  */

	goto join;



gen:	entry;

	gen_flag = 1;



join:

	line_length = get_line_length_$switch (null (), code);
	if line_length < 132 then long_hregs = "0"b;
	else long_hregs = "1"b;


	call hcs_$history_regs_get (hreg_state);	/* get state of processes save hreg switch */

	if ^hreg_state then
	     call hcs_$history_regs_set ("1"b);		/* turn on for testing */

          if (gen_flag = 1) then do;			/* for this we have to get one and only one argument*/
	     call cu_$arg_ptr(1, arg_ptr, arg_len, code); /* no other checking is done			*/
	     if code ^= 0 then goto ARG_ERROR;
	     data_len = arg_len;
	     script_path = arg_ptr -> data;
	     end;

/*	Now expand this path name  so we can initiate the segment.
*/

	call expand_pathname_ (script_path, dir_name, ent_name, code);

	if code ^= 0
	then do;
	     call com_err_ (code, "ET", "Can't expand path name of input segment ^a.", script_path);
	     return;
	end;



/*	If we have a script segment then get a pointer to the base of this segment.
   *	Also get the length of the segment in characters.
*/

	do RPT = 1 to times_to_repeat;		/* repeat set x times */

	     if remember_start = 1 then		/* reset starting test indicator */
		start_flag = 1;

	     SELECT = 1;
	     if gen_flag = 0			/* Is there script input?  */


	     then do;

		call hcs_$initiate_count (dir_name, ent_name, "", bit_count, 1,
		     script_ptr, code);

		if script_ptr = null ()
		then do;
		     call com_err_ (code, "ET", "Cannot initiate data segment ^a^[>^]^a.", dir_name, (dir_name ^= ">"), ent_name);
		     return;
		end;

		code = 0;

		bit_count = bit_count + 8;

		script_len = bit_count / 9;		/* Get size in chars. */

	     end;



	     else do;				/* The input is a path name of a procedure
						   *  segment.  Get a pointer to the entry
						   *  point of this procedure.  */

		call hcs_$make_ptr (null (), ent_name, ent_name, gen_seg_ptr, code);

		if code ^= 0
		then do;
		     call com_err_ (code, "ET", "Can't get pointer to entry point of gen seg ^a^[>^]^a.", 
			dir_name, (dir_name ^= ">"), ent_name);
		     return;
		end;

	     end;

%page;
/*        Create the temporary segments we will use, if they have not been
   created in a prior invocation.  Before touching them, make them
   deactivatable explicitly */

	     if ^segs_initialized then do;
		do i = 1 to hbound (seg_ref_names, 1);
		     call hcs_$terminate_name (seg_ref_names (i), code); /* get rid of residual */
		     call hcs_$make_ptr (null (), seg_ref_names (i), "", copy_segp, code);
		     if code ^= 0 then do;
			call com_err_ (code, "ET", seg_ref_names (i));
			return;
		     end;
		     call hcs_$status_mins (copy_segp, type, copy_bit_count, code);
		     if code ^= 0 then do;
			call com_err_ (code, "ET", seg_ref_names (i));
			return;
		     end;
		     temp_seg_name = unique_chars_ (unique_bits_ ()) || "." || rtrim (seg_ref_names (i));
		     call hcs_$make_seg ("", temp_seg_name, "", 01110b, temp_segp, code);
		     if code ^= 0 then do;
			call com_err_ (code, "ET", "Creating [pd]>^a", temp_seg_name);
			return;
		     end;
		     unspec (akst) = "0"b;
		     akst.set.explicit_deactivate_ok,
			akst.value.explicit_deactivate_ok = "1"b;
		     call phcs_$set_kst_attributes (fixed (baseno (temp_segp), 17), addr (akst), code);
		     if code ^= 0 then do;
			call com_err_ (code, "ET", "Setting KST attributes for [pd]>^a", temp_seg_name);
			return;
		     end;
		     temp_segp -> copy_seg = copy_segp -> copy_seg;
		     call hcs_$terminate_name (seg_ref_names (i), code);
		     call hcs_$make_seg ("", temp_seg_name, seg_ref_names (i), 01110b, (null ()), code);
		     call hcs_$set_bc_seg (temp_segp, copy_bit_count, code);
		     if code ^= 0 then do;
			call com_err_ (code, "ET", "Setting bit count for [pd]>^a", temp_seg_name);
			return;
		     end;
		end;
		segs_initialized = "1"b;
	     end;
	call ioa_ ("^/ET");
%page;
/*	Initialize those arguments that have to be initialized only once */

	     condition_label = condition_restart;

	     set_data_ptrs (1) = addr (etx$set_data1);
	     set_data_ptrs (2) = addr (etx$set_data2);
	     set_data_ptrs (3) = addr (etx$set_data3);
	     set_data_ptrs (4),
		set_data_ptrs (5) = null ();

	     et_data_ptr = addr (setup_data_area);

	     page_ptrs (*) = null ();

	     next_instruction_x = 0;

	     finished_flag = 0;

	     test_count = 0;

	     addr (result_fill_char) -> char_overlay = "000000000"b;
	     addr (dummy_print_char) -> char_overlay = "111000111"b;
	     addr (dummy_test_char) -> char_overlay = "111001111"b;

/*	Note, the dummy value for the registers is 8191 decimal.  This value is used
   *	because it is greater than any number we will use in a register and is equal
   *	to  17777 octal.
*/

	     do i = 12 to 15;
		addr (regs) -> reg_array (i) = 8191;
	     end;


/*	We must reference the location in  etx  where we transfer to so we will not take
   *	a linkage fault when we actually call  etx$execute.
*/

	     touch_word = addr (etx$execute) -> word_overlay;
						/* 	*/

/*	The input script segment may contian data for more than one instruction.
   *	We will process one instruction at a time until we are told to stop.
   *	( finished_flag will be  on ).  */


	     do while (finished_flag = 0);

		call test_instruction;

condition_restart:
	     end;					/* End the main  do  loop. */

	end;					/* end RPT loop */


/*	We are all done so clean up input script if there was any.  */

	if gen_flag = 0

	then call hcs_$terminate_noname (script_ptr, code);



/*	Logical end of  eis_tester.  */

	if ^hreg_state then
	     call hcs_$history_regs_set ("0"b);		/* turn off hregs */
	return;

/*  */
test_instruction: procedure;


/*	This procedure is called from the main  eis_tester  procedure.  It will set up
   *	and test one  eis  instruction.  Once it has parsed the input data describing this
   *	instruction it will set up the external segments and actually execute the
   *	instruction.  Before returning it will test the results of the instruction.
*/

	     code = 0;
	     error_flag = 0;
	     name = " ";
	     note = " ";

	     test_count = test_count + 1;



/*	Now we will set up to handle a truncation fault.
*/



/*	Initialize the instruction area in  etx to all  nop  instructions. */

	     do i = 1 to 7;
		addr (etx$instruction_area) -> instr_overlay (i) =
		     "000000000000000000000001001000000000"b;
	     end;



/*	Now test the  "gen_flag" to see how we are getting our input.  */


	     if gen_flag = 0


	     then do;

		call et_test (script_ptr, script_len, et_data_ptr, finished_flag, code);

		if code ^= 0			/* If anything is wrong don't bother
						   *  to test this instruction. */
		then do;
		     call com_err_ (0, "ET", "Error in input statement for test:  ^d  -  ^a", test_count, name);
		     return;
		end;
	     end;


	     else do;

		call cu_$ptr_call (gen_seg_ptr, et_data_ptr);

		finished_flag = 1;

	     end;





/*	See if we are to check for a special test to start with.
   *	If so we will count the number of tests we have parsed so far.  If this
   *	is not the one we want we will return and thus not process this test.
   *	If the start_flag is OFF then the do_flag must be ON and thus we will
   *	only do this one test.   If the start_flag is ON then we will stop counting
   *	the test and just do all the rest of the tests.  NOTE, if both flags
   *	are ON the  start_flag will override the do_flag.
*/

	     if test_instr_flag = 1 then
		if TEST_INSTR ^= name then return;

	     if start_flag = 1
	     then do;
		if test_count ^= test_num (1)
		then return;

		else do;
		     start_flag = 0;
		     do_flag = 0;
		end;
	     end;


	     if do_flag = 1 then do;
		if test_num (SELECT) = -1 then do;
		     finished_flag = 1;
		     return;
		end;
		if test_count ^= test_num (SELECT)
		then return;
		else
		SELECT = SELECT +1;
	     end;


	     if stop_flag = 1 then do;		/* check for end test */
		if test_count = stop_num then
		     finished_flag = 1;
	     end;

	     if brief_flag = 0 then
		call ioa_ ("TEST ^3d (^a)", test_count, name);



/*	First set up  the instruction in the  etx  segment.  */


/*	Get a pointer to where we must place the instruction.  Note, the instruction
   *	area words that are not used are left as  nops.  Once we have the pointer
   *	we will move the instruction word.  Note, the instruction offset defined by
   *	the user is backwards as far as we are concerned.  We need the offset from the
   *	beginning of the instruction area.  We will convert it.
*/

	     our_offset = (instr_offset - 3)* (-1);

	     instr_ptr = addrel (addr (etx$instruction_area), our_offset);

	     instr_ptr -> eis_map.instruction = instr_word;


/*	Now set up the descriptor words.  If there is an indirect word it will take
   *	the place of a descriptor word.   In that case we must put the descriptor
   *	word somewhere else.
*/

	     do i = 1 to 3;

		if descriptors (i) ^= "0"b		/* Check to see if we must move this
						   *  descriptor. */

		then do;				/* Descriptor present - set it up. */

		     if ind_words (i) = "0"b		/* Check for indirect descriptor. */

/*	If there is no indirect word just move the descriptor into the instruction
   *	in  etx.  */
		     then instr_ptr -> eis_map.desc_array (i) = descriptors (i);

/*	If there is an indirect word then the indirect word will replace the
   *	descriptor in the  eis  instruction.  The descriptor will be move into
   *	a word as specified by the pointer in the desc_ptrs array. */

		     else do;
			instr_ptr -> eis_map.desc_array (i) = ind_words (i);
			desc_ptrs (i) -> word_overlay = descriptors (i);
		     end;

		end;

	     end;					/* End of descriptor move do loop.  */



/*	Initialize the set_indicators word.  By default we will just have the  BAR MODE
   *	indicator ON.  If the user has specified that the instruction is to turn ON
   *	the  -  overflow, exponent overflow, or exponent underflow  -  indicators then
   *	we will turn  ON  the overflow mask so we will not get an overflow type fault
   *	from the test instruction.
*/

	     set_indicators = init_indicators;

	     if (substr (ir_word, 22, 1) = "1"b) |
	     (substr (ir_word, 23, 1) = "1"b) |
	     (substr (ir_word, 24, 1) = "1"b)
	     then do;
		substr (set_indicators, 25, 1) = "1"b;
		substr (ir_word, 25, 1) = "1"b;
	     end;



/*	If there is test and result data we want to put special characters at the
   *	beginning and end of these data strings.  Thus if the  EIS  instruction
   *	incorrectly stores into words beyond the bounds of the result data string
   *	we will be able to recognize the error.  Eight special characters ("717" octal)
   *	will be stored at the beginning and end of these two strings.
*/

	     if data_lens (tx) = 0 then goto print_instr_data;


	     do i = tx to rx;

		call et_util$char_rel (data_ptrs (i), -8);
		data_lens (i) = data_lens (i) + 16;

		do j = 1 to 8;
		     data_ptrs (i) -> data_array (j),
			data_ptrs (i) -> data_array (data_lens (i) +1 -j) = dummy_test_char;
		end;

	     end;





/*	Now if we are in VERBOSE mode we will print all of the data involved with
   *	this test.  We will start with the instruction itself
*/

print_instr_data:

	     if RPT > 1 then verbose_flag = 0;


	     if verbose_flag = 0 then goto check_execute;

	     call ioa_ ("^/Test Description:  ^a", note);

	     call ioa_ ("^/Eis instruction:^-( ^p )   Ind  Desc.", instr_ptr);

	     if instr_offset = 0
	     then call ioa_ ("^4x- - - -- - - -");

	     call ioa_ ("^5x^w", instr_ptr -> eis_map.instruction);


	     do i = 1 to 3;

		if instr_offset = i
		then call ioa_ ("^4x- - - -- - - -");

		if (i = 3) & (descriptors (3) = "0"b)
		then goto print_ptrs;

		if ind_words (i) = "0"b

		then call ioa_ ("^5x^w", instr_ptr -> eis_map.desc_array (i));

		else call ioa_ ("^5x^w^8x->      ^w   ( ^p )",
		     instr_ptr -> eis_map.desc_array (i),
		     descriptors (i), desc_ptrs (i));
	     end;


/* 	Now print the pointer registers if any of them are being used.  */

print_ptrs:

	     do i = 0 to 7;

		if pointers (i) ^= null ()

		then do;
		     call ioa_ ("^/Pointer Registers:^-( ^p )", addr (etx$set_ptrs));
		     call ioa_ ("^5xpr0 - pr3    ^p  ^p  ^p  ^p",
			pointers (0), pointers (1), pointers (2), pointers (3));
		     call ioa_ ("^5xpr4 - pr7    ^p  ^p  ^p  ^p",
			pointers (4), pointers (5), pointers (6), pointers (7));
		     goto print_regs;
		end;
	     end;


/*	If any of the index registers of the A or Q have been used then we will print out
   *	all of the index registers includeing A and Q.
*/

print_regs:

	     do i = 0 to 7;
		if regs.x (i) ^= 8191
		then goto found_used_regs;
	     end;

	     if (regs.A ^= 8191) | (regs.Q ^= 8191)
	     then goto found_used_regs;
	     else goto print_indicators;


found_used_regs:
	     call ioa_ ("^/Index Registers:^-( ^p  )", addr (etx$set_regs));
	     call ioa_ ("^5x X0 - X7     ^6o ^6o ^6o ^6o ^6o ^6o ^6o ^6o",
		regs.x (0), regs.x (1), regs.x (2), regs.x (3),
		regs.x (4), regs.x (5), regs.x (6), regs.x (7));
	     call ioa_ ("^5x    A  ^w      Q  ^w", regs.A, regs.Q);



print_indicators:

	     call ioa_ ("^/Test Indicators:^-( ^p )", addr (etx$indicators));
	     call ioa_ ("^5x^w", ir_word);



/*	Now print out the names of the pages which we will take faults on.  */

	     workx = 0;				/* Initialize count of page faults.  */

	     do i = 1 to 14;

		print_pages (i) = " ";

		if (page_faults (i) = "1"b) & (page_ptrs (i) ^= null)

		then do;
		     workx = workx + 1;
		     print_pages (workx) = page_names (i);
		end;
	     end;

	     if workx = 1
	     then plural = " ";
	     else plural = "s";

	     call ioa_ ("^/This test will take  ^d  page fault^a.", workx, plural);

	     if workx ^= 0
	     then call ioa_ ("^4x^a^a^a^a^a^a^a^a^a^a^a^a^a^a",
		print_pages (1), print_pages (2), print_pages (3), print_pages (4),
		print_pages (5), print_pages (6), print_pages (7), print_pages (8),
		print_pages (9), print_pages (10), print_pages (11),
		print_pages (12), print_pages (13), print_pages (14));


/*	Now print the data referenced by the descriptors.  We will print it only if the
   *	descriptor actually has data.
*/

	     do datax = 1 to 3;

		if data_ptrs (datax) ^= null () then call print_data;
	     end;


/*	Now print the test data.  */

	     if data_lens (tx) ^= 0

	     then do;
		datax = tx;
		call print_data;
	     end;



/*	We will test to see if we really are going to execute this instruction.
   *	If not we will just return.
*/

check_execute:

	     if nox_flag ^= 0 then return;


/*	Now execute the instruction.  It will be executed the number of times
   *	specified in  loop_count.   Before each execution we must reset the data fields
   *	and set up the page faults.  After each test we will compare the data results
   *	and the settings of the indicator registers.  If the debug loop flag is  ON
   *	then we will override any loop count specified by the user and set the loop
   *	count to  10.
*/


	     if debug_loop_flag = 1
	     then loop_count = 10;

	     do loopx = 1 to loop_count;


/*	If there is a result area we will initialize it to the special fill characters.  */

		if data_lens (rx) ^= 0

		then do i = 9 to data_lens (rx) - 8;
		     data_ptrs (rx) -> data_array (i) = result_fill_char;
		end;


/*	Now move all the data fields into position.  */

		do j = 1 to 3;

		     if (data_ptrs (j) ^= null ()) & (data_lens (j) ^= 0)

		     then do;
			data_len = data_lens (j);
			data_ptrs (j) -> data = set_data_ptrs (j) -> data;
		     end;

		end;				/* End of the data set up loop.  */


/*	Now set up the pointer registers,  registers, and the indicator word in
   *	etx.  Before we store the index registers which  etx  will use we must put
   *	our instruction offset in  X0.   etx uses X0 so it can transfer directly to the
   *	first word of the eis instruction and not just the beginning of the instruction
   *	area.
*/

		regs.x (0) = our_offset;

		addr (etx$set_ptrs) -> ptr_array = pointers;

		addr (etx$set_regs) -> reg_array = addr (regs) -> reg_array;

		addr (etx$set_ind) -> word_overlay = set_indicators;
		addr (etx$indicators) -> word_overlay = "0"b;

/*	Now set up the handlers for possible conditions */

		truncation_label = check_errors;
		on stringsize begin;		/* truncation handler */


/*	If the truncation flag is not  ON  then we took an illegal truncation fault.
*/

		     if truncation_flag = 0
		     then do;
			error_flag = 1;
			call com_err_ (0, "ET", "Unexpected truncation fault for test:  ^d  -  ^a", test_count, name);
			call display_mc_;
			go to truncation_label;
		     end;


/*	This truncation fault is OK.  We will trun off the truncation flag so that the
   *	error checking code will not think that there is an error.
*/


		     else truncation_flag = 2;
		     go to truncation_label;
		end;

		if ^sof_ then go to SETUP;		/* just run like old unless told otherwise */


		on condition (et_error) begin;
		     cond_infop = addr (cond_info);
		     call find_condition_info_ (null (), cond_infop, code);
		     int_cond_name = cond_info.condition_name;
		     call display_mc_;
		     call continue_to_signal_ (code);
		end;				/* end any_other */
SETUP:



/*	Now we will flush out all of the pages used by this process.
   *	Then we can bring back the ones we want - thus leaving faults
   *	set in the pages that we want to take faults on.  */



LOOP:		call DEACTIVATE;


/*	Look through the page_fault table.  Those entries that are ON represent
   *	pages that should take faults during the execution of the  eis  instruction.
   *	We will leave them alone since after the  flush we will assume that they
   *	are not in core.  Those entries that are still  OFF we will touch so that
   *	we can be sure that they are in core and will not take a page fault during
   *	the execution of the  eis  instruction.  We assume, of course, that there
   *	is not enough paging going on to drive these pages out before we can
   *	execute the  eis  instruction.
*/

		do i = 1 to 14;

		     if (page_faults (i) = "0"b) & (page_ptrs (i) ^= null ())

		     then touch_word = page_ptrs (i) -> word_overlay;

		end;


/*	Now we can execute the  eis  instruction.  */


		call etx$execute;
		revert stringsize;


/*	Once we have returned from  etx  we must test the resulting data and the
   *	resulting indicator word.  Note, some instructions do not actually move any
   *	data and thus there is no result data to test.  Note, if the debug loop
   *	flag is  ON  then we will not test the results.  We will just go back and
   *	and do the test again.
*/


check_errors:

		if debug_loop_flag = 1
		then goto end_test_loop;

		data_len = data_lens (rx);

		if data_len ^= 0

		then if data_ptrs (tx) -> data ^= data_ptrs (rx) -> data

		     then do;			/* Print  data fields in octal. */
			call ioa_ ("^/Data resulting from test ( ^d - ^a ) is incorrect.", test_count, name);
			datax = rx;
			call print_data;		/* Print the invalid result data. */
			error_flag = 1;
		     end;


/*	If we took a truncation fault we will not check the indicators since the
   *	sti  instruction in  etx  was not executed.
*/

		if truncation_flag = 2
		then goto check_for_trun;

		if addr (etx$indicators) -> word_overlay ^= ir_word

		then do;
		     call ioa_ ("^/Indicators not set correctly for test:  ^d  -  ^a", test_count, name);
		     call ioa_ ("^/Test   indicator word is: ^w", ir_word);
		     call ioa_ ("Result indicator word is: ^w",
			addr (etx$indicators) -> word_overlay);
		     error_flag = 1;
		end;


/*	If the truncation flag is ON then we were expecting a truncation fault but none
   *	occurred.  If one had occurred the handler would have set the flag to  2.
*/

check_for_trun:

		if truncation_flag = 1
		then do;
		     call com_err_ (0, "ET", "^/Expected truncation fault did not occur.");
		     error_flag = 1;
		end;

		if error_flag = 1 then
		     call ioa_ ("^/*** TEST NOTES: ^a ***^/", note);

		if (error_flag = 1) & (sof_ = "1"b) then
		     signal et_error;

end_test_loop:
	     end;					/* End of the  test  loop.  */


/*	This is the logical end of   test_instructions	*/
/*  */
print_data:    procedure;



/*	This procedure is called to print out a data field.  the data field will be
   *	printed in octal words, four words to the line.  The first line printed
   *	will contain the name of the data field and a pointer to the data field.
   *	Note, the special fill characters will be converted so they will not be printed
   *	out as octal digits.  They will be converted to:
   *	dummy_print_char  -  3 blanks  "   "
   *	dummy_fill_char   -  3 x's     "xxx"
*/


		call ioa_ ("^/^a^-( ^p )", data_names (datax), data_ptrs (datax));


/*	If the length of this data is zero then this data field must be a result field.
   *	We will print a message telling the user this and  also print what the fill character
   *	will be.
*/

		if data_lens (datax) = 0

		then do;
		     call ioa_ ("^5xResult data field initialized to all zero bits.");
		     return;
		end;


/*	Get a pointer to the data to print.  We also need its length.  If we are printing
   *	the data for a descriptor we will use the data in the set up areas of  etx.
*/

		if set_data_ptrs (datax) = null ()

		then print_ptr = data_ptrs (datax);
		else print_ptr = set_data_ptrs (datax);

		print_len = data_lens (datax);


/*	Since we will be printing full words we must set the unused characters in the
   *	first word to a special value.  We must also adjust the print pointer so that
   *	it points to what we now consider the beginning of the first word of the
   *	string.  Note, this may not actually be on a word boundary.
*/

		call et_util$char_rel (print_ptr, -data_offsets (datax));
		print_len = print_len + data_offsets (datax);

		do i = 1 to data_offsets (datax);
		     print_ptr -> data_array (i) = dummy_print_char;
		end;


/*	Now we must fill in the unused characters of the last word of the string.  They
   *	will be set to the same dummy character.
*/

		workx = print_len - 1;
		workx = 4 - (print_len - (divide (workx, 4, 17, 0))*4);

		do i = 1 to workx;
		     print_len = print_len + 1;
		     print_ptr -> data_array (print_len) = dummy_print_char;
		end;


/*	Now we will print the data string.   A maximum of   4  words of data will be
   *	printed on each line.  Duplicate lines will be suppressed.
*/

		skip_count = 0;			/* Initialize count of the duplicate lines. */

		dup_string = "_$<-+;*><)(:|||";

		num_words = divide (print_len, 4, 17, 0);




		do while (num_words > 0);		/* Each iteration prints 1 line. */

		     if num_words > 3		/* Get number of words in this line. */
		     then workx = 4;
		     else workx = num_words;

		     num_words = num_words - 4;

		     if (num_words > 0) & (print_ptr -> based_string = dup_string)


		     then do;			/* This line is a duplicate of the previous
						   *  line.  If it is not the last line we will
						   *  skip it.  The last line is always printed.  */
			skip_count = skip_count + 1;
			print_ptr = addr (print_ptr -> data_array (17));
			goto end_line;
		     end;


/*	This is the last line or it is not the same as the previous line.  */

		     if skip_count ^= 0		/* Were there duplicate lines before? */

		     then do;			/* YES. */
			if skip_count = 1
			then plural = " ";
			else plural = "s";
			call ioa_ ("^5xPrevious line repeated  ^d  time^a.", skip_count, plural);
			skip_count = 0;
		     end;

/*	Move the line to be printed to an aligned area so it can be printed as an array
   *	of words.  Save it in the duplicate string so we can test the next line.
   *	Then we must update the print pointer to reference the next line.
*/

		     print_string = print_ptr -> based_string;

		     dup_string = print_ptr -> based_string;

		     print_ptr = addr (print_ptr -> data_array (17));


/*	Now convert the string of octal words to the character representation for these
   *	octal digits.  This is done just so the special dummy characters will not be
   *	printed in octal.
*/

		     do i = 1 to workx;		/* One iteration for each word in the line. */

			char_word = char_words (i);

			do j = 1 to 4;		/* One iteration for each character in
						   *  the word.  */

			     character = substr (char_word, j, 1);

			     if character = dummy_print_char
			     then do;
				xx = 1 + (j-1)*3;
				substr (print_chars (i), xx, 3) = "   ";
				goto end_char;
			     end;

			     if character = dummy_test_char
			     then do;
				xx = 1 + (j-1)*3;
				substr (print_chars (i), xx, 3) = "xxx";
				goto end_char;
			     end;

			     do k = 1 to 3;
				xx = k + (j-1)*3;
				substr (print_chars (i), xx, 1) =
				     oct_chars (fixed (char_bits (k), 3));
			     end;

end_char:
			end;
		     end;


/*	Use the  "ioa_" call for the number of words in this line.  If the
   *	number is less than 4 we know this is the last line.
*/

		     goto print_line (workx);



print_line (1):

		     call ioa_ ("^5x^a", print_chars (1));

		     return;


print_line (2):

		     call ioa_ ("^5x^a  ^a", print_chars (1), print_chars (2));

		     return;


print_line (3):

		     call ioa_ ("^5x^a  ^a  ^a", print_chars (1),
			print_chars (2), print_chars (3));

		     return;


print_line (4):

		     call ioa_ ("^5x^a  ^a  ^a  ^a", print_chars (1), print_chars (2),
			print_chars (3), print_chars (4));


end_line:

		end;				/* This is the end of the print  do  loop. */


	     end print_data;





	end test_instruction;
						/* 	*/
display_mc_: proc;

dcl  cu_$stack_frame_ptr entry (ptr);
dcl  find_condition_frame_ entry (ptr) returns (ptr);
dcl  find_condition_info_ entry (ptr, ptr, fixed bin (35));
dcl  dump_machine_cond_ entry (ptr, ptr, char (32) aligned, fixed bin);
dcl  hran_$hranl entry (ptr, ptr, bit (1));
dcl  hreg_ptr ptr;


dcl 1 condinfo aligned,
% include cond_info;

     dcl (stackp, faultsp) ptr;
dcl (null, addr) builtin;
dcl  ec fixed bin (35);


	     call cu_$stack_frame_ptr (stackp);		/* get current stack pointer */
	     faultsp = find_condition_frame_ (stackp);	/*  is this the condition frame? */
	     if faultsp = null then do;		/* no */
		call ioa_ (" No condition frame.");
		return;
	     end;
	     else call find_condition_info_ (faultsp, addr (condinfo), ec); /* get a pointer to the machine conditions */
	     if condinfo.mcptr = null () then
		return;
	     call ioa_ ("^/MACHINE CONDITIONS AT ^p:^/", condinfo.mcptr);

	     call dump_machine_cond_ (addr (condinfo), faultsp, "user_output", 2); /* print the MC */
	     if mcptr ^= null then
		hreg_ptr = addrel (mcptr, 96);
	     if hreg_ptr = null then do;		/* no history regs to dump */
		call ioa_ ("History Registers are not available");
		return;
	     end;
	     else do;
		call ioa_ ("CPU HISTORY REGISTERS AT TIME OF FAULT");
		call hran_$hranl (hreg_ptr, null, long_hregs);
	     end;

	     return;
	end display_mc_;

%page;
DEACTIVATE: proc;
dcl  i fixed bin;

/* Deactivate each segment.  This will force its pages out of memory. */


	     do i = 1 to 14;
		if page_ptrs (i) ^= null () then
		     if baseno (page_ptrs (i)) ^= "077777"b3 then
			call phcs_$deactivate (page_ptrs (i), code);
	     end;


	     return;

	end DEACTIVATE;



     end eis_tester;




		    et_data.pl1                     06/03/82  1651.3rew 06/03/82  1020.5      205407



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


et_data: procedure (statement, arg_et_data_ptr, code);



/*	This procedure will parse the data in a  "data"  statement that is part of the
   *	input script to the  eis_tester  program.
   *
   *	Created  Jan, 73  by  Bill Silver.
   *
   *
   *	A  "data"  statement has the following format:
   *
   *	data    num    -option    data_field ... data_field;
   *
   *	1.  The first field in the statement  MUST  be   "data".
   *
   *	2.  The second field in the statement  MUST  be the number of the data field.
   *	    It must be either  "1", "2", or "3".  Note, in some cases a  "data 3" statement
   *	    is valid even when there is no third descriptor.  In this case it will be used
   *	    to input test data.
   *
   *	3.  The following option field may occur anywhere after the number field.
   *	    -do  X     The  X  field must be a decimal integer from  -128 to +4096.
   *		     It represents a CHARACTER offset from character 0 of the middle page
   *	    of the data area.  Note, if the descriptor which points to this dat does not
   *	    use AR or REG modification then only offsets that are a multiple of  4  will
   *	    be accepted.
   *
   *	4.  Data may be defined by the following types of data fields.  They may be
   *	    intermixed.  The maximum size of the data is  1088  words ( 4352 characters ).
   *	    Note, the data used by  EIS  instructions is always  STRING type data and thus
   *	    the input modes are limited to the 2 described below.
   *
   *	    a)	ASCII - Input data may be an ASCII string.  It must be enclosed in
   *		quotes.  The maximum size of any one field is  256 characters.
   *		Quote characters may be entered in the string by expressing
   *		them as double quotes.  ("")
   *
   *	    b)	OCTAL - Data may be entered as a string of octal digits.  The first non
   *		octal digit type character found will indicate the end of the string
   *		of octal data.  The converted octal string will be padded on the  RIGHT
   *		with zero bits to make it an integral number of 9 bit characters.
   *
   *	5.  Repetition Factor  ( XX )  -  An unsigned decimal number enclosed in parenthesis
   *	    may be used to specify the repetition of a field.  Only the data field
   *	    immediately following the repetition field will be repeated.
*/
/* 	*/
/*		PARAMETERS  to   et_data.		*/


dcl  statement char (*),				/* The input string containing the   "data"
						   *  statement to be parsed. */

     arg_et_data_ptr ptr,				/* Input pointer to the  et  data.  */

     code fixed bin (35);				/* Error code.  */






/*		AUTOMATIC  DATA		*/


/*	The following data items are used in calls to  et_util. */

dcl  state_ptr ptr,					/* Pointer to the   "data"   input statement. */

     start fixed bin (35),				/* The number of characters allready
						   *  processed in this   "data"   statement.
						   *  The next character is the start of
						   *  the window.  */

     size fixed bin (35),				/* The current size ( in characters )
						   *  of the window on the  "data"  statement. */

     next_statement_x fixed bin;			/* Index of the last character in the
						   *  statement - in effect the number of
						   *  characters in the statement.  */



/*	These are some temporary variables. */

dcl  dec_num fixed bin,				/* Holds converted decimal number. */

     dx fixed bin (17),				/* Index to those tables that are dependent
						   *  on the data statements associated with
						   *  the three descriptors.  */

     i fixed bin,					/* Index.  */

     len fixed bin,					/* Length of a field. */

     rep_num fixed bin (17),				/* The number of times a data field is to
						   *  be repeated.  */

     result_x fixed bin,				/* The number of the descriptor which references
						   *  the result data for this instruction.  */

     save_offset fixed bin,				/* Used to save term from  "-do" option. */

     test_x fixed bin;				/* The number of the data statement used to
						   *  enter test data for this instruction.  */


dcl  data_ptr ptr;					/* Points to the current data area.  */



dcl  temp_buf char (256) aligned,			/* A temporary buffer used in processing the
						   *  input data fields.  */

     temp_buf_len fixed bin,				/* The number of characters currently in
						   *  this buffer.  */

     temp_buf_start fixed bin;			/* The indext to the next unused character
						   *  position in this buffer.  */





/*		BASED  DATA		*/


/*	This is an overlay of the input   "data"   statement.  */

dcl 1 data_statement based (state_ptr),			/* Used to access the input data statement
						   *  as a stream of characters. */

    2 offset char (start),				/* The part of the  "data"  statement which we have
						   *  allready processed. */

    2 window char (size);				/* The part of the  "data"  statement which we are
						   *  currently accessing.  */




/*	This is an overlay of the data areas where the input data will be moved.  */

dcl  data_area char (4352) based (data_ptr) aligned;



/*	This array defines a sting of real octal digits.  This string is placed in
   *	the temporary buffer.
*/
dcl  oct_array (1:768) bit (3) based unaligned;


/*	This is an overlay of one word.  It is used to move decimal and octal words.  */

dcl  char_word char (4) based aligned;



/*	This is an overlay of a descriptor word.  We are only interested in the address
   *	field in the descriptor.
*/

dcl 1 desc_map based,

   (2 pad1 bit (3),

    2 y fixed bin (14),

    2 pad2 bit (18)) unaligned;


/*	This is an overlay of an  mf  field.  */

dcl 1 mf_map based unaligned,
    2 ar bit (1),
    2 rl bit (1),
    2 id bit (1),
    2 reg bit (4);






/*		INTERNAL  STATIC  DATA		*/


/*	These indexes reference the test and result entries in the data_ptrs,
   *	data_lens, and data_offsets  arrays.
*/

dcl (tx fixed bin init (4),

     rx fixed bin init (5)) internal static;


/*	This constant consists of  one  quote character.  */

dcl  quote char (1) internal static init ("""");


/*	These arrays define octal digits and their bit values.  */

dcl  oct_chars (0:7) char (1) internal static
     init ("0", "1", "2", "3", "4", "5", "6", "7");


dcl  oct_bits (0:7) bit (3) internal static
     init ("000"b, "001"b, "010"b, "011"b,
     "100"b, "101"b, "110"b, "111"b);



/*	This array points to the three set up areas in  etx.  This is where the input
   *	data will be placed.
*/

dcl  set_data_ptrs (3) ptr internal static,

     init_flag fixed bin internal static init (0);






/*		EXTERNAL  DATA		*/


/*	The following declarations reference the procedures called by  et_data.
*/

dcl  com_err_ entry options (variable),

     et_util$skip entry (ptr, fixed bin (35), fixed bin (35)),
     et_util$convert_decimal entry (ptr, fixed bin (35), fixed bin (35), fixed bin, fixed bin (35)),
     et_util$char_rel entry (ptr, fixed bin),

     etx$set_data1 external,
     etx$set_data2 external,
     etx$set_data3 external;


dcl (addr,
     addrel,
     divide,
     fixed,
     length,
     null,
     search,
     substr,
     verify) builtin;
						/*  */
%include et_instr_data_map;
/* 	*/
%include et_setup_data;
/* 	*/
/*	Set up the window on the input   "data"   statement.  We will skip the
   *	"data"  field at the beginning of the statement.
*/

	state_ptr = addr (statement);
	next_statement_x = length (statement);

	et_data_ptr = arg_et_data_ptr;		/* Copy this argument.  */

	start = 4;
	size = next_statement_x - 4;

	save_offset = 0;


/*	Get the  num  field which must be next. */

	call et_util$skip (state_ptr, start, size);


/*	Validate and convert the num  field.  */

	len = verify (substr (window, 1, 1), "123");

	if len = 0

	then do;
	     dx = fixed (substr (window, 1, 1), 17);
	     start = start + 1;
	     size = size - 1;
	end;

	else do;
	     code = 401;
	     call com_err_ (0, "ET", "^d Illegal data num  field: ^a", code, substr (window, 1, 1));
	     return;
	end;


/*	Before we do anything more we will retrieve the test and result indexes for this
   *	instruction.  These values are needed in several places.  Also if this is
   *	the first time this procedure in the process we will initialize some
   *	pointers that we need.
*/

	test_x = et_instr_data$instructions (instr_num).test_x;

	result_x = et_instr_data$instructions (instr_num).result_x;

	temp_buf = " ";				/* Initialize mainly for debugging. */

	rep_num = 1;				/* It is reset after each data field is
						   *  moved into the setup area.  */


	if init_flag = 0

	then do;
	     set_data_ptrs (1) = addr (etx$set_data1);
	     set_data_ptrs (2) = addr (etx$set_data2);
	     set_data_ptrs (3) = addr (etx$set_data3);
	     init_flag = 1;
	end;


/*	Now check to see if this data statement is legal.  Only data 3 statements can be
   *	illegal.  They are illegal only if this instruction has no third descriptor and
   *	the  data 3  statement is not used to input test data.
*/

	if dx = 3

	then if (^et_instr_data$instructions (instr_num).desc_3_flag) &

	     (test_x ^= 3)

	     then do;
		code = 403;
		call com_err_ (0, "ET", "^d Illegal  data 3  statement.", code);
		return;
	     end;


/*	Now initialize the pointer to the set up data area in   etx  where this input data
   *	will be placed.
*/

	data_ptr = set_data_ptrs (dx);



/*	Now we can start processing the optional terms in the data statement.  We will continue to
   *	process these terms until we find an error or until there is no more input in this
   *	data statement.
*/


input_loop:


/*	Get the first character of the next field.  If there is no more input for this
   *	statement we will go to the  end of data  to perform some necessary finishing
   *	touches for this data statement.
*/

	call et_util$skip (state_ptr, start, size);

	if substr (window, 1, 1) = ";"
	then goto end_of_data;


/*	There is another field.  The first character of the field tells us what to
   *	do with this field.
*/

	if substr (window, 1, 1) = "("

	then call get_repetition_num;


	else if substr (window, 1, 1) = "-"

	then call get_data_off;


	else if substr (window, 1, 1) = quote

	then call get_ascii_data;


	else call get_octal_data;			/* This is the default.  */


/*	Regardless of which internal procedure was called it will return here.  We must
   *	check the error code it returns.  If there was an error we will print out the whole
   *	data statement and then return.
*/

	if code ^= 0

	then do;
	     start = 0;
	     size = next_statement_x;
	     call com_err_ (0, "ET", "^d data statement:  ^a", code, window);
	     return;
	end;


	goto input_loop;				/* This is the end of the  loop.  Each
						   *  iteration will process 1 input field.  */
						/* 	*/
						/*	We have finished processing all of the  data in this statement.  Now we must
						   *	perform a little special processing that can only be done when all the
						   *	data from this  data  statement are known.
						   *
						   *	The first thing we must do is to set up the  page_ptrs  for this data area.
						   *	Only the pages that are actually used will have non null entries.
						   */

end_of_data:

	if save_offset < 0				/* String starts in page 1. */

	then page_ptrs (3 + (dx-1)*4 + 1) = data_ptrs (dx);


	save_offset = save_offset + data_lens (dx);


	if save_offset > 0				/* String extends into page 2. */

	then page_ptrs (3 + (dx-1)*4 + 2) = addrel (data_ptrs (dx), 64);


	if save_offset > 4096			/* String extends into page 3. */

	then page_ptrs (3 + (dx-1)*4 + 3) = addrel (data_ptrs (dx), 1088);



/*	Now we must see if this statement is used to input  test or result  data.
   *	If so we must set up the array entries that are associated with test and
   *	result data.
*/

	if dx = test_x

	then do;					/* This statement inputs test data. */

	     data_ptrs (tx) = data_ptr;		/* Test data is in setup area. */

	     data_lens (tx) = data_lens (dx);		/* This is both test and result len. */
	     data_lens (rx) = data_lens (dx);

	     data_lens (dx) = 0;			/* This data is NOT set up before
						   *  the instruction is executed. */
	end;


	if dx = result_x

	then do;

	     data_ptrs (rx) = data_ptrs (dx);

	     data_offsets (rx) = data_offsets (dx);

	end;



/*	This is the logical end of the  et_data  procedure.	*/
/* 	*/
get_repetition_num: procedure;


/*	This procedure is called to parse a repetitions number field.  The repetition number
   *	must be enclosed in parenthesis and it must be a positive decimal number.
   *	It will be returned in the variable  "rep_num".
*/



	     start = start + 1;			/* Move the window past the  "(".  */
	     size = size - 1;


/*	Skip to the first decimal digit.  There may be blanks before and after the
   *	repetition number.
*/

	     call et_util$skip (state_ptr, start, size);


/*	Now find the number of digits in the repetition number.  We will also verify that
   *	it is a valiid decimal number.  Note, if the value returned in  "len"  is  0  then
   *	all characters in the rest of the statement are decimal digits.  If   "len"   is
   *	1 then the first character of the decimal number is not a decimal digit.
*/

	     len = verify (window, "0123456789");

	     if len < 2

	     then goto error_missing_right_paren;


	     len = len - 1;				/* Adjust  "len"  to get actual number of
						   *  decimal digits.  */

	     rep_num = fixed (substr (window, 1, len), 17); /* Convert repetition number.  */


	     start = start + len;			/* Move window past decimal number.  */
	     size = size - len;


/*	Now look for right parenthesis.   */

	     call et_util$skip (state_ptr, start, size);

	     if substr (window, 1, 1) ^= ")"
	     then goto error_missing_right_paren;


	     start = start + 1;			/* Move window past the ")".  */
	     size = size - 1;


	     return;




error_missing_right_paren:

	     code = 411;

	     call com_err_ (0, "ET", "^d Error in repetition factor - right parenthesis missing.", code);


	end get_repetition_num;
						/* 	*/
get_data_off: procedure;


/*	This procedure is called to process the  "-do"  option.  The field after the
   *	"-do" must be a decimal number from -128 to +7.  This number will be used to
   *	begin the data string at the CHARACTER which is offset the specified number of
   *	characters from character 0 of the first word of the second page of the data area.
   *	The number may be signed or unsigned.  We will convert and validate this number
   *	and if it is OK we will:
   *	1.  Determine the effective character position in the first word of daata.
   *	    This is stored in the corresponding  data_offsets  entry.
   *	2.  Adjust OUR data pointer for this data field.
   *	3.  Adjust the effective address of the descriptor which points to the data field.
   *	    How this is done depends upon the modification used in this descriptor.
*/



	     if substr (window, 1, 3) ^= "-do"

	     then do;
		code = 421;
		call com_err_ (0, "ET", "^d Unknown data statement option:  ^a",
		     code, substr (window, 1, 5));
		return;
	     end;


	     if save_offset ^= 0

	     then do;
		code = 422;
		call com_err_ (0, "ET", "^d ""-do"" option entered twice.", code);
		return;
	     end;


	     start = start + 3;			/* Move window past the option name.  */
	     size = size - 3;


	     call et_util$skip (state_ptr, start, size);


	     call et_util$convert_decimal (state_ptr, start, size, dec_num, code);

	     if code ^= 0 then return;


	     if (dec_num < -128) | (dec_num > 4096)

	     then do;
		code = 423;
		call com_err_ (0, "ET", "^d Illegal data offset:  ^d", code, dec_num);
		return;
	     end;


/*	Now check to be sure that this data statement may have a  "-do" option field.
   *	Some  data 3  statements are only used to input test data.
*/

	     if (^et_instr_data$instructions (instr_num).desc_3_flag) &
	     (dx = 3) & (test_x = 3)

	     then do;
		code = 424;
		call com_err_ (0, "ET", "^d -do  option not allowed in this  data 3  statement.", code);
		return;
	     end;


	     save_offset = dec_num;			/* Save offset value.  Needed at end. */


/*	Figure out offset of string in first word.  */
	     if dec_num > -1

	     then data_offsets (dx) = dec_num - (divide (dec_num, 4, 17, 0) * 4);

	     else do;
		i = - dec_num;
		data_offsets (dx) = 4 - (i - (divide (i, 4, 17, 0) * 4));
		if data_offsets (dx) = 4
		then data_offsets (dx) = 0;
	     end;


/*	Adjust our own data pointer.  */

	     call et_util$char_rel (data_ptrs (dx), dec_num);


/*	We must adjust the effective address of this data's descriptor.  Note, the offset
   *	is  dec_num  is a character offset.
*/

	     if mf_ptrs (dx) ^= null ()		/* Is there an  mf  field for this descriptor? */


	     then do;				/* YES, see if  AR  modification specified. */

		if mf_ptrs (dx) -> mf_map.ar
		then do;				/* AR mod, adjust pointer. */
		     call et_util$char_rel (pointers (dx), dec_num);
		     return;
		end;
	     end;


/*	Either there was no  mf  field or the mf field did not specify AR or REG modification.
   *	In either case we will have to adjust the word offset field in the descriptor itself.
   *	This implies that the character offset specified by the user must be a multiple
   *	of 4.  If it isn't then there is an error.
*/

	     len = divide (dec_num, 4, 17, 0);

	     if (dec_num - len * 4) ^= 0

	     then do;
		code = 425;
		call com_err_ (0, "ET", "^d Data offset must be multiple of 4 - only word modification possible.", code);
		return;
	     end;

/*	Offset is a multiple of the word size so we will adjust the descriptor offset field.  */

	     addr (descriptors (dx)) -> desc_map.y =
		addr (descriptors (dx)) -> desc_map.y + len;


	end get_data_off;
						/*  */
get_ascii_data: procedure;


/*	This procedure is called to move ASCII type input data into a set up data area in
   *	etx.  It will move all of the data into a temporary buffer.  Then using the
   *	repetiton factor it will move this string into the set up data area.
*/



	     temp_buf_len = 0;			/* Initialize values dealing with  */
	     temp_buf_start = 1;			/* temporary buffer.  */



ascii_loop:					/* This loop will get all the character up to
						   *  then next quote and move them into the
						   *  temporary buffer.  */


	     start = start + 1;			/* Move window past the left quote.  */
	     size = size - 1;


	     len = search (window, quote);		/* Look for the right hand quote.  */

	     if len = 0				/* Did we find a quote?  */
	     then do;				/* NO.  */
		code = 421;
		call com_err_ (0, "ET", "^d Missing right quote in ASCII input string.", code);
		return;
	     end;


	     len = len - 1;				/* Get the actual number of characters in
						   *  the string.  */


/*	If the string is not null and the input buffer will not be overflowed then
   *	we will move the string into the temporary buffer.
*/

	     if temp_buf_len + len > 256		/* Is the input string too long? */

	     then do;				/* YES. */
		code = 422;
		call com_err_ (0, "ET", "^d ASCII input field qreater than 256 characters.", code);
		return;
	     end;


	     if len ^= 0

	     then substr (temp_buf, temp_buf_start, len) = substr (window, 1, len);


/*	Now that the data has been moved add to the temporary totals.  */

	     temp_buf_start = temp_buf_start + len;
	     temp_buf_len = temp_buf_len + len;

	     start = start + len + 1;			/* Move window past the end of this string */
	     size = size - len - 1;			/* and past the right quote.  */


/*	Now look for an embedded quote.  It will be expressed as a dbouble quote.
   *	Thus if the next character is a quote we will move this one character into the
   *	temporary buffer and then go back to the beginning of the loop to finish processing
   *	the rest of the string.
*/

	     if substr (window, 1, 1) = quote

	     then do;

		substr (temp_buf, temp_buf_start, 1) = quote;

		temp_buf_start = temp_buf_start + 1;
		temp_buf_len = temp_buf_len+ 1;

		start = start + 1;
		size = size - 1;

		goto ascii_loop;			/* The loop is set up just to look for
						   *  embedded quotes.  */
	     end;



/*	We have finished processing the whole input ASCII string for the field.  Now using
   *	the repetition factor we will move it into the set up data area.
*/

	     call move_data;


	end get_ascii_data;
						/* 	*/
get_octal_data: procedure;


/*	This procedure is called to process a STRING  of octal digit characters.  The
   *	converted string will be moved into the set up data area using the repition
   *	factor.
*/



	     len = 1;				/* Start converted string at the beginning
						   *  of the temporary buffer.  */


octal_loop:					/* Each iteration of this loop will process
						   *  1 octal digit character.  */

	     do i = 0 to 7;

		if substr (window, len, 1) = oct_chars (i)

		then do;
		     addr (temp_buf) -> oct_array (len) = oct_bits (i);
		     len = len + 1;
		     goto octal_loop;
		end;
	     end;

	     len = len - 1;				/* Get the actual number of octal digits
						   *  found in this string.  */

	     if len < 1
	     then do;
		code = 431;
		call com_err_ (0, "ET", "^d No octal digit found in octal field: ^a",
		     code, substr (window, len, 1));
		return;
	     end;


	     do i = 1 to 2;
		addr (temp_buf) -> oct_array (len+i) = oct_bits (0);
	     end;

	     start = start + len;			/* Move window to after the octal string. */
	     size = size - len;

	     len = len + 2;				/* Get number of characters to move. */
	     temp_buf_len = divide (len, 3, 17, 0);

	     call move_data;



	end get_octal_data;
						/*  */
move_data: procedure;


/*	This procedure is called to move the data in the temporary buffer into the
   *	set up data area for this statement.  This operation will be performed as many
   *	times as specified in the repetiton factor for this field.
*/


	     do i = 1 to rep_num;

		data_lens (dx) = data_lens (dx) + 1;	/* Get starting position in data area. */

		substr (data_area, data_lens (dx), temp_buf_len) =

		     substr (temp_buf, 1, temp_buf_len);

		data_lens (dx) = data_lens (dx) -1 + temp_buf_len;

	     end;


	     rep_num = 1;				/* Reset the repitition number for the
						   *  next field that is input.  The repitition
						   *  number is valid for only one field at
						   *  a time.  */


	end move_data;



     end et_data;




		    et_desc.pl1                     06/03/82  1651.3rew 06/03/82  1021.4      144495



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


et_desc: procedure (statement, arg_et_data_ptr, code);



/*	This procedure will parse the data in a "desc" statement that is part of
   *	the input script to the  eis_tester  program.
   *
   *	Originally coded  Nov, 72  by  Bill Silver
   *
   *
   *	A  desc  statement has the following format.
   *
   *	desc	num	-option . . . -option  ;
   *
   *	1.  The first field in the statement MUST be "desc".
   *
   *	2.  The second field in the statement MUST be the number of the
   *	    descriptor.  It MUST be either "1", "2", or "3".
   *
   *	3.  Any number of valid  "desc"  statement options may follow.
   *	    The format is the same for all desc options.  It is:
   *
   *	    -name	  term
   *
   *	4.  name is the two character name of the option and term is the data
   *	    associated with this option.  The valid option names are:
   *
   *	    a)	cp	The original character position within a word of
   *			9 bit characters.  It is used in bit string instructions.
   *			Its term must be a number from  0 - 3.
   *
   *	    b)  	bp	The original bit position within a  9  bit character.
   *			Its term must be a number from  0 - 8.
   *
   *	    c)	cn	The original character number within the data word
   *			referenced by the original data word address.
   *			It is used in character string instructions.  Its term must be
   *			a number from  0 - 7.  The meaning of this term is defined by
   *			the  "ta" and "tn" fields.  NOTE, if the instruction is:
   *			CMPC, SCD, SCDR, SCM,  or  SCMR  then the  "desc 2"  statement
   *			may NOT specify a "ta" field.  Descriptor 2 must use the value
   *			specified in descriptor 1.  To use this feature the  "desc 1"
   *			statement MUST PRECEED the  "desc 2" statement.
   *
   *	    d)	ta	Defines the alphanumeric character type.
   *			Its term must be either:  9, 6, or 4.
   *
   *	    e)	tn	Defines the type of numeric character.
   *			Its term must be either  9 or 4.
   *
   *	    f)	sd	The  sign and decimal  type.
   *			Its term must be one of the following characters:
   *			  f  -  Floating point, leading sign
   *			  l  -  Leading sign,  scaled
   *			  t  -  Trailing sign, scaled
   *			  n  -  No sign,  scaled
   *
   *	    g)	sf	The scaling factor.
   *			Its term is a signed (or unsigned) decimal number.
   *
   *	    h)	ns	The number of characters or bits in a string.
   *			Its term is an unsigned decimal number.
   *
   *	    i)	nn	The number of characters in a numeric string.
   *			Its term is an unsigned decimal number which must not
   *			be greater than  64.
*/









/*		PARAMETER  DATA		*/


dcl  statement char (*),				/* The input string containing the  "desc"
						   *  statement to be parsed. */

     arg_et_data_ptr ptr,				/* Input pointer to the  et  data.  */

     code fixed bin (35);				/* Error code.  */






/*		AUTOMATIC  DATA		*/


/*	The following data items are used in calls to  et_util.  */

dcl  state_ptr ptr,					/* Pointer to the  "desc"  input statement. */

     start fixed bin (35),				/* The number of characters allready
						   *  processed in this  "desc"  statement.
						   *  The next character is the start of
						   *  the window.  */

     size fixed bin (35),				/* The current size ( in characters )
						   *  of the window on the "desc" statement. */

     next_statement_x fixed bin;			/* Index of the last character in the
						   *  statement - in effect the number of
						   *  characters in the statement.  */


/*	These are some temporary variables. */

dcl  dec_num fixed bin,				/* Holds converted decimal number. */

     i fixed bin,

     len fixed bin,					/* Length of a field. */

     desc_ptr ptr,					/* Work pointer to a descriptor word. */

     option_name char (3),				/* Used to temporarily hold option name. */

     option_num fixed bin;				/* Option index.  */


/*	The following data items are used when processing descriptors.  */

dcl  dx fixed bin (17),				/* Index to  those tables
						   *  that are dependent on the three
						   *  descriptors or indirect words. */

     cn_value fixed bin;				/* Character position. */





/*		BASED  DATA		*/


/*	This is an overlay of the input  "desc"  statement.  */

dcl 1 desc_statement based (state_ptr),			/* Used to access the input data statement
						   *  as a stream of characters. */

    2 offset char (start),				/* The part of the "desc" statement which we have
						   *  allready processed. */

    2 window char (size);				/* The part of the "desc" statement which we are
						   *  currently accessing.  */


/*	An overlay of the decimal numbers which hold the input data terms.  */

dcl  bit_word bit (36) based (addr (dec_num)) aligned;


/*	An overlay of an  mf  field.  */

dcl 1 mf_map based unaligned,
    2 ar bit (1),
    2 rl bit (1),
    2 id bit (1),
    2 reg bit (4);


/*	The following three declarations are used to reference fields in the three
   *	types of descriptors  - bit string, alphanumeric, and numeric.
*/

dcl 1 desc_bit_map based aligned,
   (2 pad1 bit (18),
    2 c bit (2),
    2 b bit (4),
    2 n bit (12)) unaligned;

dcl 1 desc_alpha_map based aligned,
   (2 pad1 bit (18),
    2 cn bit (3),
    2 ta bit (2),
    2 pad2 bit (1),
    2 n bit (12)) unaligned;

dcl 1 desc_num_map based aligned,
   (2 pad1 bit (18),
    2 cn bit (3),
    2 tn bit (1),
    2 s bit (2),
    2 sf bit (6),
    2 n bit (6)) unaligned;




/*		INTERNAL  STATIC  DATA	*/


dcl  option_names (9) char (3) internal static
     init ("-cp", "-bp", "-cn", "-ta", "-tn", "-sd", "-sf", "-ns", "-nn");


dcl  sd_table (0:3) char (1) internal static
     init ("f", "l", "t", "n");


/*	This table is a list of the names of the  4  types of  eis  instruction.  */

dcl  instr_type_names (4) char (12) aligned internal static
     init ("alphanumeric", "numeric     ",
     "bit  string ", "conversion  ");





/*		EXTERNAL  DATA		*/


/*	The following declarations reference the procedures called by  et_desc.  */

dcl  com_err_ entry options (variable),

     et_util$get_next entry (ptr, fixed bin (35), fixed bin (35), char (*), fixed bin),
     et_util$skip entry (ptr, fixed bin (35), fixed bin (35)),
     et_util$convert_decimal entry (ptr, fixed bin (35), fixed bin (35), fixed bin,
     fixed bin (35));


dcl (addr,
     fixed,
     length,
     null,
     substr,
     verify) builtin;
						/*  */
%include et_instr_data_map;
/* 	*/
%include et_setup_data;
/* 	*/
/*	Set up the window on the input  "desc"  statement.  We will skip the
   *	"desc" field at the beginning of the statement.
*/

	state_ptr = addr (statement);
	next_statement_x = length (statement);

	et_data_ptr = arg_et_data_ptr;		/* Copy this argument.  */


	start = 4;
	size = next_statement_x - 4;


/*	Get the  num  field which must be next. */

	call et_util$skip (state_ptr, start, size);


/*	Validate and convert the num  field.  */

	len = verify (substr (window, 1, 1), "123");

	if len = 0				/* 0 => number found in string "123".  */

	then dx = fixed (substr (window, 1, 1), 17);

	else do;
	     code = 301;
	     call com_err_ (0, "ET", "^d Illegal desc num  field: ^a",
		code, substr (window, 1, 1));
	     return;
	end;


/*	Now test to see if we should process this descriptor.  Only descriptor 3  is in
   *	question.  If this  num field  is a  3  then check to see if this instruction has
   *	3  descriptors.
*/

	if dx = 3

	then if ^ et_instr_data$instructions (instr_num).desc_3_flag

	     then do;
		code = 302;
		call com_err_ (0, "ET", "^d desc 3 statement invalid - instruction has only 2 descriptors.", code);
		return;
	     end;


/*	Get a pointer to the descriptor we will be working with.  */

	desc_ptr = addr (descriptors (dx));


	start = start + 1;				/* Move window past  num  field. */
	size = size - 1;

	cn_value = -1;				/* Indicate no  cn  option specified.  */




/*	Now start to process the options.  We will test for each possible
   *	option name.  Each iteration of the loop will process one option.
*/


option_loop:


/*	Get the next option name.  If there are no more options then we have processed
   *	all of the options in this  "desc" statement.  Before we return we must set up
   *	the  "cn"  field.
*/

	call et_util$get_next (state_ptr, start, size, "-", len);

	if len = 0
	then goto setup_cn_field;


/*	We will try to find this option name in our list of valid names.  */

	option_name = substr (window, 1, 3);

	do option_num = 1 to 9;
	     if option_names (option_num) = option_name
	     then goto found_option;
	end;

/*	We did not find a valid option name.  There must be an input error.  */

	code = 303;

	call com_err_ (0, "ET", "^d Illegal option ""^a"" in ""desc ^d"" statment.",
	     code, option_name, dx);

	return;


/*	We have found a valid option name.  We will position the window to the beginning
   *	of the term field.  For all but the  "-sd" option the term will be a decimal number.
   *	We will get the decimal term.  Then we will go to the code which processes this
   *	option.
*/

found_option:

	start = start + 3;
	size = size - 3;

	call et_util$skip (state_ptr, start, size);

	if option_name = "-sd"
	then goto option_routine (option_num);

	call et_util$convert_decimal (state_ptr, start, size, dec_num, code);

	if code ^= 0
	then do;
	     call com_err_ (0, "ET", "^d Illegal term for ""^a"" option in ""desc ^d"" statement.",
		code, option_name, dx);
	     return;
	end;

	goto option_routine (option_num);
						/*  */
option_routine (1):					/*  -cp  */

	if instr_type ^= 3				/* Must be  bit string  type. */
	then goto illegal_option;

	if (dec_num < 0) | (dec_num > 3)
	then goto illegal_term;

	desc_ptr -> desc_bit_map.c = substr (bit_word, 35, 2);

	goto option_loop;



option_routine (2):					/*  -bp  */

	if instr_type ^= 3				/* Must be  bit string  type.  */
	then goto illegal_option;

	if (dec_num < 0) | (dec_num > 8)
	then goto illegal_term;

	desc_ptr -> desc_bit_map.b = substr (bit_word, 33, 4);

	goto option_loop;



option_routine (3):					/*  -cn  */

	if instr_type = 3				/* All but bit string type. */
	then goto illegal_option;

	if (dec_num < 0) | (dec_num > 8)
	then goto illegal_term;

	cn_value = dec_num;				/* Save character number.  We don't know
						   *  character size yet.  */
	goto option_loop;



option_routine (4):					/*  -ta  */

	if instr_type ^= 1				/* Must be  alphanumeric  type.  */
	then goto illegal_option;

/*	Check to see if it is legal to specify a character size.  */

	if num_chars (dx) = -1
	then do;
	     code = 305;
	     call com_err_ (0, "ET", "^d ""-ta"" option illegal - must use ""ta"" from descriptor 1.",
		code);
	     return;
	end;

	if num_chars (dx) = 1
	then do;
	     code = 306;
	     call com_err_ (0, "ET", "^d ""-ta"" option illegal - descriptor may only reference words.",
		code);
	     return;
	end;

/*	We will wet up the  "ta" field in the descriptor now.  We will check for valid
   *	input and convert the character size to the correct bits.   We must also change the
   *	num_chars entry if the character size is not the default:  9 bits.
*/

	if dec_num = 9				/* 9 is the default value.  */
	then goto option_loop;

	if dec_num = 6
	then do;					/* 6  6 bit  characters per word. */
	     num_chars (dx) = 6;
	     desc_ptr -> desc_alpha_map.ta = "01"b;
	     goto option_loop;
	end;

	if dec_num = 4
	then do;					/* 8  4 bit  characters per word. */
	     num_chars (dx) = 8;
	     desc_ptr -> desc_alpha_map.ta = "10"b;
	     goto option_loop;
	end;

	goto illegal_term;				/* "ta" term must be 9,6, or 4. */



option_routine (5):					/*  -tn  */

/*	Must be type  numeric or conversion.  */

	if (instr_type = 1) | (instr_type = 3)
	then goto illegal_option;

	num_chars (dx) = dec_num;

	if dec_num = 9
	then goto option_loop;

	if dec_num = 4
	then do;
	     desc_ptr -> desc_num_map.tn = "1"b;
	     goto option_loop;
	end;

	goto illegal_term;




option_routine (6):					/*  -sd  */

/*	Must be  numeric or conversion type.  */

	if (instr_type = 1) | (instr_type = 3)
	then goto illegal_option;

	do dec_num = 0 to 3;			/* Look for a valid term. */

	     if sd_table (dec_num) = substr (window, 1, 1)

	     then do;				/* Found valid term. */
		desc_ptr -> desc_num_map.s = substr (bit_word, 35, 2);
		goto option_loop;
	     end;
	end;

	code = 307;
	call com_err_ (0, "ET", "^d Illegal term for option ""-sd"": ^a", code, substr (window, 1, 1));

	return;



option_routine (7):					/*  -sf  */

/*	Must be  numeric or conversion  type.  */

	if (instr_type = 1) | (instr_type = 3)
	then goto illegal_option;

	if (dec_num < -32) | (dec_num > 31)
	then goto illegal_term;

	desc_ptr -> desc_num_map.sf = substr (bit_word, 31, 6);

	goto option_loop;



option_routine (8):					/*  -ns  */

/*	Must be  alphanumeric or bit string  type.  */

	if (instr_type = 2) | (instr_type = 4)
	then goto illegal_option;

	if (dec_num < 0) | (dec_num > 4096)
	then goto illegal_term;

	desc_ptr -> desc_bit_map.n = substr (bit_word, 25, 12);

	goto check_rl_mod;



option_routine (9):					/*  -nn  */

/*	Must be  numeric or conversion  type.  */

	if (instr_type = 1) | (instr_type = 3)
	then goto illegal_option;

	if (dec_num < 0) | (dec_num > 63)
	then goto illegal_term;

	desc_ptr -> desc_num_map.n = substr (bit_word, 31, 6);


/*	For options  "ns" and "nn" we will check that the user has not also specified
   *	RL  modification.
*/

check_rl_mod:

	if mf_ptrs (dx) ^= null ()

	then if mf_ptrs (dx) -> mf_map.rl

	     then do;
		code = 308;
		call com_err_ (0, "ET", "^d An ""^a"" option is illegal with RL modification.",
		     code, option_name);
		return;
	     end;
	goto option_loop;
						/* 	*/
						/*	We come here when all of the options have been processed.  If a  "-cn" option was
						   *	entered we will figure out what value we should put in the descriptor  "cn"  field.
						   *	It depends upon the character size.
						   */

setup_cn_field:


/*	If the  "cn"  field was never specified then we don't have to set it up.
   *	Either it is not used for this type of instruction or the user wants the default
   *	value.  An exception, however, must be made if this is descriptor 2 of one
   *	of the instructions that must use the  "ta" value from descriptor 1.  If we find
   *	this to be the case we will just change to use the values for descriptor 1.
*/

	if cn_value = - 1				/* No  -cn  option entered. */
	then return;


	if num_chars (dx) = -1
	then dx = 1;


	dec_num = cn_value;				/* Move value to where bit_word will
						   *  reference it.  */

	if num_chars (dx) = 4			/* "ta" or "tn" fields specify 9 bit characters.
						   *  This is the default value.  */
	then do;
	     if cn_value > 3
	     then goto illegal_cn_term;
	     dec_num = dec_num * 2;
	end;

	else if num_chars (dx) = 6

	then if cn_value > 5
	     then goto illegal_cn_term;

/*	If  4 bit characters  we just come here.  Any  cn  value from  0 - 7  is
   *	valid.
*/

	desc_ptr -> desc_alpha_map.cn = substr (bit_word, 34, 3);

	return;





illegal_option:

	code = 320 + option_num;

	call com_err_ (0, "ET", "^d "" ^a "" option is illegal for ^a type instruction.",
	     code, option_name, instr_type_names (instr_type));

	return;




illegal_term:

	code = 330 + option_num;

	call com_err_ (0, "ET", "^d Decimal term  ^d  not valid for option ""^a"".",
	     code, dec_num, option_name);

	return;



illegal_cn_term:

	code = 312;

	call com_err_ (0, "ET", "^d cn value  ^d  illegal for character size ^d",
	     code, cn_value, num_chars (dx));



     end et_desc;




		    et_inst.pl1                     06/03/82  1651.3rew 06/03/82  1022.7      196011



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


et_inst: procedure (statement, arg_et_data_ptr, code);



/*	This procedure will parse the data in an  "inst"  statement.
   *
   *	Created  Nov, 72  by Bill Silver.
   *
   *
   *
   *	An  "inst"  statement has the following format:
   *
   *	inst	opcode_mnemonic	-option ... -option ... ;
   *
   *	1.  The first field in the statement MUST be  "inst".
   *
   *	2.  The second field in the statement MUST be the mnemonic name
   *	    of a storage type  eis  instruction.  (As opposed to address
   *	    register type  eis  instructions which are not tested by  ET.
   *
   *	3.  Any number of valid  "inst"  statement  option fields may follow.  They may
   *	    be in any order.  Each must begin with a  "-".  The options allowed in an
   *	    "inst"  statement  are:
   *
   *	    a)  -tbA	Used to turn  ON  the  Truncation Bit.
   *			A is either  "y" or "n" and signifies whether or not the instruction
   *			is to take a truncation fault.
   *			"y"  =>  yes,   "n"  =>  no.
   *
   *	    b)  -fb	Used to turn  ON  the  Fill Bit.
   *
   *	    c)  -pb	Used to turn  ON  the  Plus sign Bit.
   *
   *	    d)  -rb	Used to turn  ON  the  Rounding Bit.
   *
   *	    e)  -fcA	Defines the  Fill Character.  A  is the character which will
   *			be used.
   *
   *	    f)  -mcA	Defines the  Mask Character.  A is the character which will
   *			be used.  Note, for both "fc" and "mc" options the character
   *			immediately following the option name will be used.
   *
   *	    g)  -ln X	X defines the  Loop Number.  This is the number of times this
   *			instruction test will be performed.  The default is  1.
   *			The maximum value of  X  is  4.
   *
   *	    h)  -io X	X defines the  Instruction Offset.  It is used to position
   *			the instruction on a page boundary.  The default is  0.  This
   *			will place the instruction at word 0 of the second page
   *			of the instruction area.   X indicates the number of words of
   *			the instruction which will be placed in the first page of the
   *			instruction area.  The maximum value of  X  is  3.
   *
   *	    i)  -nt "A...A" This option defines a  Note.    It can be used to
   *			define each test.  The term consists of a character string
   *			between quotes.  Up to 64 characters may be used.  No embedded
   *			quotes are allowed.
   *
   *	    j)  -bo AAA	This option defines a  Boolean Operator.   AAA is the name of
   *			the operator.  These names are given in the routine which
   *			processes this operator.
   *
   *	    k)  -ir	A  multi-field option which defines the correct state of the
   *			indicator registers after the  eis  instruction has been
   *			executed.  A list of the indicator names is given  in the
   *			routine which processes this option.
   *
   *	    l)  -mfX	A multi-field option which defines the  MF  fields of the instruction.
   *			X  denotes which  MF  field is being defined.  It must be from
   *			1 - 3.  The terms for this option are defined in  et_mf.pl1
*/
/* 	*/
/*	The   PARAMETERS  to  et_inst.	*/


dcl  statement char (*),				/* The input string containing the
						   *  "inst"  statement to be parsed.  */

     arg_et_data_ptr ptr,				/* The input pointer to   et_data. */

     code fixed bin (35);				/* Error code.  */






/*		AUTOMATIC  DATA		*/


/*	The following data items are used in calls to  et_util.  */

dcl  state_ptr ptr,					/* Pointer to the  "inst"  input statement. */

     start fixed bin (35),				/* The number of characters allready
						   *  processed in the  "inst"  statement.
						   *  The next character is the start of
						   *  the window.  */

     size fixed bin (35),				/* The current size ( in characters )
						   *  of the window on the  "inst"  statement.  */

     next_statement_x fixed bin;			/* Index of the last character in the
						   *  statement - in effect the number of
						   *  characters in the statement.  */



/*	These are some temporary variables. */

dcl  dec_num fixed bin,				/* Holds converted decimal number.  */

     i fixed bin,					/* Index */

     len fixed bin,					/* Length of a field. */

     num_descs fixed bin,				/* Number of descriptors in the instruction. */

     option_name char (3),				/* Used to save an option name.  */

     option_num fixed bin;				/* Index used when processing options. */





/*		BASED  DATA		*/



/*	This is an overlay of the input  "inst"  statement.  It is used to access the input
   *	statement as a stream of characters.  */


dcl 1 inst_statement based (state_ptr),

    2 offset char (start),				/* The part of the  "inst"  statement which
						   *  we have already processed. */

    2 window char (size);				/* The part of the  "inst"  statement which
						   *  we are currently accessing.  */




/*	The following overlays are used to fill in the op code word of the
   *	eis  instruction.  Three are needed because of overlapping fields.
*/

dcl 1 instr_map_1 based (addr (instr_word)) aligned,
   (2 fill_mask char (1),				/* Defines both  fill and mask field. */
    2 t bit (1),
    2 pad1 bit (1),
    2 mf2 bit (7),
    2 opcode bit (10),
    2 pad2 bit (1),
    2 mf1 bit (7)) unaligned;


dcl 1 instr_map_2 based (addr (instr_word)) aligned,
   (2 p_f bit (1),					/* Defines both  f  and  p  bits. */
    2 pad1 bit (1),
    2 mf3 bit (7),
    2 pad2 bit (1),
    2 rd bit (1),
    2 pad3 bit (25)) unaligned;


dcl 1 instr_map_3 based (addr (instr_word)) aligned,
   (2 pad1 bit (5),
    2 bolr bit (4),
    2 pad2 bit (27)) unaligned;




/*	This is an overlay of a  descriptor  word.   We are only interested in the
   *	address field and the  mf field.
*/

dcl 1 desc_map based aligned,
   (2 pad1 bit (3),
    2 y fixed bin (14),				/* Address field.  */
    2 pad2 bit (11),
    2 mf bit (7)) unaligned;


/*	This overlay is used to reference a fixed bin word as a bit word.  */

dcl  bit_word bit (36) aligned based (addr (dec_num));





/*		INTERNAL  STATIC  DATA	*/


/*	The following table is a list of the option names allowed in an
   *	"inst"  statement.
*/

dcl  option_names (1:12) char (3) internal static
     init ("-tb", "-fb", "-pb", "-rb",
     "-fc", "-mc", "-ln", "-io",
     "-nt", "-bo", "-ir", "-mf");


dcl  quote char (1) init ("""") internal static;



/*	This table contains the names of the boolean (BOLR) operations.
   *	The position in the array corresponds to the actual  BOLR  code.
*/

dcl  bolr_names (0:15) char (3) internal static
     init ("zer", "and", "axr", "mov",
     "xra", "ra2", "xor", "or ",
     "nor", "nox", "iv2", "xrx",
     "inv", "xxr", "nan", "set");



/*	The following table is used to parse the terms of the  "ir"  option.
   *	These are the names by which the various indicators are known to  ET.
   *	The position within the table corresponds to the bit position of the indicator
   *	in the word that is used to load and store the indicators.
*/


dcl  ir_names (14) char (2) internal static
     init ("zr", "ng", "cr", "ov", "eo", "eu", "om",
     "tr", "pe", "pm", "bm", "tn", "mw", "ab");


/*	This table is a list of the names of the  4  types of  eis  instructions.  */

dcl  instr_type_names (4) char (12) aligned internal static
     init ("alphanumeric", "numeric     ",
     "bit  string ", "conversion  ");


/*	This table is a list of the num_chars values that may be assigned to each descriptor.  */

dcl  num_chars_table (0:3) fixed bin internal static
     init (1, 4, 36, -1);

/*  */
/*		EXTERNAL  DATA		*/



/*	These are the data areas referenced by the initialize instruction.  These
   *	addresses reference the first words of the middle page of each data area.
   *	These data areas are in the same segment  (etx)  as the instruction itself.
*/

dcl (etx$data1, etx$data2, etx$data3,
     etx$instruction_area, etx$instr_page_2) external;


dcl  com_err_ entry options (variable),

     et_mf entry (char (*), ptr, fixed bin (35)),

     et_util$get_next entry (ptr, fixed bin (35), fixed bin (35), char (*), fixed bin),
     et_util$skip entry (ptr, fixed bin (35), fixed bin (35)),
     et_util$convert_decimal entry (ptr, fixed bin (35), fixed bin (35), fixed bin, fixed bin (35));




dcl (addr,
     index,
     length,
     search,
     substr) builtin;
						/*  */
%include et_instr_data_map;
/* 	*/
%include et_setup_data;
/* 	*/
/*	Set up the window on the input  "inst"  statement.  We will skip the
   *	"inst"  field at the beginning of the statement.
*/


	state_ptr = addr (statement);
	next_statement_x = length (statement);

	et_data_ptr = arg_et_data_ptr;		/* Copy this argument. */

	start = 4;
	size = next_statement_x - 4;


/*	Now skip to the mnemonic name field.  */

	call et_util$skip (state_ptr, start, size);

	call get_instr_num;				/* The mnemonic name MUST be next. */

	if code ^= 0
	then return;




/*	Now initialize the data variables in  et_setup_data.  The initial state of the
   *	instruction and all descriptors is:
   *
   *	1.  There is no register or pointer modification.
   *	2.  There is no register length (RL) modification.
   *	3.  The descriptor is not indirect.
   *	4.  The data referenced via the descriptor is in the same segment as
   *	    the descriptor.  (etx)
*/

/*	Put the instruction name in the  note field.  The rest of the note will
   *	be left blank for now.
*/

	name = et_instr_data$instructions (instr_num).mnemonic;

	loop_count = 1;				/* The default is to execute the test
						   *  only once.  */

	instr_offset = 0;				/* Assume instruction goes at word zero
						   *  of middle page.  */

/*	Clear the instruction word and set up the opcode field.
*/

	instr_word = "0"b;

	instr_map_1.opcode = et_instr_data$instructions (instr_num).opcode;


	instr_type = et_instr_data$instructions (instr_num).instr_typex;

	do i = 1 to 3;				/* Initially there are no indirect descriptors.  */
	     descriptors (i) = "0"b;
	     ind_words (i) = "0"b;
	     desc_ptrs (i) = null ();
	end;

	do i = 1 to 5;				/* Entries 1 & 2 will be filled in below. */
	     data_ptrs (i) = null ();
	     data_lens (i) = 0;
	     data_offsets (i) = 0;
	end;

	do i = 1 to 14;				/* Default is no page faults. */
	     page_faults (i) = "0"b;
	     page_ptrs (i) = null ();
	end;

	page_ptrs (2) = addr (etx$instr_page_2);	/* This page is usually used. */

	truncation_flag = 0;

	do i = 0 to 7;				/* Unused pointer registers are null. */
	     pointers (i) = null ();
	end;

/*	Unused index registers and A and Q are set to some recognizable but
   *	never valid value  (17777 octal).
*/

	do i = 0 to 7;
	     regs.x (i) = 8191;
	end;

	regs.A, regs.Q = 8191;


/*	All indicators will be initialized to  off  except the  bar mode  indicator which
   *	will be on during normal  Multics operation.
*/

	ir_word = "000000000000000000000000000010000000"b;


/*	Now set up the initial values of the data pointers and the descriptors.
   *	The third descriptor is initialized only if this instruction actually has a
   *	third descriptor.
*/
	if et_instr_data$instructions (instr_num).desc_3_flag

	then num_descs = 3;
	else num_descs = 2;

	data_ptrs (1) = addr (etx$data1);
	data_ptrs (2) = addr (etx$data2);

	if num_descs = 3
	then data_ptrs (3) = addr (etx$data3);

	do i = 1 to num_descs;
	     addr (descriptors (i)) -> desc_map.y = fixed (rel (data_ptrs (i)), 14);
	end;


/*	Now set up the  mf  pointers.  There must be an  mf  field for each descriptor.
   *	The  mf1 field is always in the instruction word.  The mf2 and mf3 fields may
   *	be in the instruction word or in the descriptor itself.
*/

	mf_ptrs (1) = addr (instr_map_1.mf1);

	if et_instr_data$instructions (instr_num).mf2_flag
	then mf_ptrs (2) = addr (instr_map_1.mf2);
	else mf_ptrs (2) = addr (addr (descriptors (2)) -> desc_map.mf);

	if num_descs < 3

	then mf_ptrs (3) = null ();

	else if et_instr_data$instructions (instr_num).mf3_flag
	then mf_ptrs (3) = addr (instr_map_2.mf3);
	else mf_ptrs (3) = addr (addr (descriptors (3)) -> desc_map.mf);


/*	Now set up the  num_chars  table.  If there is now descriptor 3 then this
   *	entry in the table is zero.
*/

	num_chars (3) = 0;

	do i = 1 to num_descs;
	     num_chars (i) = num_chars_table (et_instr_data$instructions (instr_num).char_sizex (i));
	end;

/* 	*/
/*	Now start to process the options.  We will test for each possible option name.
   *	Each iteration of the loop will process one option.
*/


option_loop:


/*	Get the next option name.  If there are no more options then we have finished
   *	with this  "inst"  statement.
*/

	call et_util$get_next (state_ptr, start, size, "-", len);

	if len = 0 then return;

/*	We will try to find this option name in our list.  */

	option_name = substr (window, 1, 3);

	do option_num = 1 to 12;

	     if option_names (option_num) = option_name

	     then do;
		start = start + 3;			/* Move window past option name.  */
		size = size - 3;
		goto option_routine (option_num);	/* Go to correct routine.  */
	     end;
	end;


/*	We did not find a valid option name.  There must be an input error.  */

	code = 201;
	call com_err_ (0, "ET", "^d Illegal option ""^a"" in ""inst"" statement.", code, option_name);

	return;
						/* 	*/
option_routine (1):					/*  -tb  */

	if instr_type = 4				/* Illegal only for conversion type. */
	then goto illegal_option;

	if substr (window, 1, 1) = "y"
	then truncation_flag = 1;

	start = start + 1;
	size = size - 1;

	instr_map_1.t = "1"b;

	goto option_loop;



option_routine (2):					/*  -fb  */

	if instr_type = 3				/* Legal only for bit string types. */

	then goto set_fb_pb;
	else goto illegal_option;


option_routine (3):					/*  -pb  */

/*	Legal only for  numeric and conversion types.  */

	if (instr_type ^= 2) & (instr_type ^= 4)

	then goto illegal_option;


set_fb_pb:

	instr_map_2.p_f = "1"b;

	goto option_loop;



option_routine (4):					/*  -rb  */

	if instr_type ^= 2				/* Legal only for numeric types. */

	then goto illegal_option;

	instr_map_2.rd = "1"b;

	goto option_loop;



option_routine (5):					/*  -fc  */
option_routine (6):					/*  -mc  */

	if instr_type ^= 1				/* Legal only for alphanumeric types.  */

	then goto illegal_option;

	instr_map_1.fill_mask = substr (window, 1, 1);

	start = start + 1;
	size = size - 1;

	goto option_loop;
						/*  */
option_routine (7):					/*  -ln  */
option_routine (8):					/*  -io  */


/*	Each of these option names must be followed by a decimal term.  */

	call et_util$skip (state_ptr, start, size);

	call et_util$convert_decimal (state_ptr, start, size, dec_num, code);

	if code ^= 0 then goto illegal_term;

	if option_name = "-ln"

	then do;
	     if (dec_num < 1) | (dec_num > 4)
	     then goto illegal_term;
	     loop_count = dec_num;
	end;

/*	This option will position the instruction in the instruction area.  We must
   *	also determine which pages in the instruction area are actually used.   By
   *	default the first page in NOT used and the second page IS used.  If the user
   *	specifies an instruction offset then the first page will be used.
*/

	else do;
	     if (dec_num < 0) | (dec_num > 3)
	     then goto illegal_term;
	     instr_offset = dec_num;
	     if dec_num > 0
	     then page_ptrs (1) = addr (etx$instruction_area);
	end;

	goto option_loop;
						/*  */
option_routine (9):					/*  -nt  */


/*	Look for left hand quote.  */

	call et_util$skip (state_ptr, start, size);

	if substr (window, 1, 1) ^= quote

	then do;
	     code = 208;
	     call com_err_ (0, "ET", "^d Left quote of  -nt  term not found.", code);
	     return;
	end;

	start = start + 1;
	size = size - 1;

/*	Now we will move the characters inside the quotes into the note.  If we move more than
   *	the maximum of 64 characters then we will assume that the right quote is not present.
*/

	len = 0;					/* Position in the note string.  */

	do i = 1 to 65;

	     if substr (window, i, 1) = quote

	     then do;				/* Move the window past the right hand quote.
						   *  et_util$skip works funny with quotes.  */
		start = start + i;
		size = size - i;
		goto option_loop;
	     end;

	     len = len + 1;

	     substr (note, len, 1) = substr (window, i, 1);

	end;


	code = 209;
	call com_err_ (0, "ET", "^d Right quote missing in  ""-nt"" term  or  term too long.", code);

	return;
						/*  */
option_routine (10):				/*  -bo  */


	if instr_type ^= 3				/* Legal only for bit string types. */

	then goto illegal_option;


/*	Move the window to the start of the  BOLR name term.  */

	call et_util$skip (state_ptr, start, size);

	do dec_num = 0 to 15;

	     if substr (window, 1, 3) = bolr_names (dec_num)

	     then do;
		instr_map_3.bolr = substr (bit_word, 33, 4);
		goto option_loop;
	     end;

	end;


	code = 210;

	call com_err_ (0, "ET", "^d BORL name not known: ^a", code, substr (window, 1, 3));

	return;
						/* 	*/
option_routine (11):				/*  -ir  */



/*	This  routine will parse an  "ir"  option.
   *	An  ir  option has the following format:
   *
   *	-ir	ind . .  ind . . . ind
   *
   *	1.  The first field in the option MUST be the option name "-ir".
   *
   *	2.  Following  may be any number of  ind  terms.   These terms may be in
   *	    any order and may be separated by any number of skip fields.
   *
   *	3.  Each  ind  term is a two character identifier of an indicator
   *	    register.  The  ind  term values which are acceptable are:
   *
   *	    a)	zr  -  zero
   *	    b)	ng  -  negative
   *	    c)	cr  -  carry
   *	    d)	ov  -  overflow
   *	    e)	eo  -  exponent overflow
   *	    f)	eu  -  exponent underflow
   *	    g)	om  -  overflow mask
   *	    h)	tr  -  tally runout
   *	    i)	pe  -  parity error
   *	    j)	pm  -  parity mask
   *	    k)	bm  -  BAR mode  -  Really  NOT BAR mode
   *	    l)	tn  -  truncation
   *	    m)	mw  -  multi-word instruction
   *	    n)	ab  -  ABSOLUTE mode
*/




/*	Now start process the  ind  terms.   */



	do while (code = 0);


/*	Move the window to the beginning of the next term.  If we find the beginning of the
   *	next option or we hit the end of the statement then we are finished with this  ir
   *	option.
*/

	     call et_util$skip (state_ptr, start, size);

	     if (substr (window, 1, 1) = "-") | (substr (window, 1, 1) = ";")

	     then goto option_loop;


	     call parse_ir_ind_term;			/* Find the  ind  term in the ir_names table
						   *  and turn on the appropriate bit. */

	end;					/* End of the do loop. */


/*	To get here there must have been an error.  */

	return;
						/*  */
option_routine (12):				/*  -mf  */


	call et_mf (window, et_data_ptr, code);


	if code ^= 0

	then return;

	else goto option_loop;
						/* 	*/
get_instr_num: procedure;



/*	This procedure is called to find the entry for this instruction in the et_instr_data
   *	table.  It will return this index in  "instr_num".
*/



/*	First get the length of the mnemonic name.  We will search for the next skip character
   *	or  "/" (beginning of a comment)  or ";" (end of statement).  Note, it is valid
   *	to have an  "inst"  statement that has only the mnemonic name.  The length returned
   *	will be one greater than the actual length of the field.
*/

/*	Below we search for: New Line, Tab, Blank, "/", and ";"  */

	     len = search (window, "
	 /;") - 1;

	     if (len < 1) | (len > 4)

	     then do;
		code = 221;
		call com_err_ (0, "ET", "^d Illegal mnemonic name in statement:  ^a",
		     code, window);
		return;
	     end;



/*	Search the table for a matching instruction mnemonic.  */


	     do instr_num = 1 to et_instr_data$num_instructions;

		if substr (window, 1, len) = et_instr_data$instructions (instr_num).mnemonic

		then return;			/* If we find a match then instr_num
						   *  contains the index we want.  */
	     end;


/*	If we get here then there is an error.  We cound not find the mnemonic name
   *	specified in the input  "inst"  statement.
*/

	     code = 222;

	     call com_err_ (0, "ET", "^d ^a  is not a known  eis  instruction.", code, substr (window, 1, len));



	end get_instr_num;
						/*  */
parse_ir_ind_term: procedure;



/*	This procedure will search the  ir_names table for the current  ind  term.
   *	( the first two characters of window )  If it is found then the corresponding
   *	bit in  ir_word  will be turned on.
*/




	     do i = 1 to 14;

		if ir_names (i) = substr (window, 1, 2)

/*	The position of the  ind  term in the table indicates the position of
   *	its corresponding bit in the lower half of the ir_word.   Move the window
   *	past this indicator term.
*/

		then do;
		     substr (ir_word, 18+i, 1) = "1"b;
		     start = start + 2;
		     size = size - 2;
		     return;
		end;

	     end;					/* End of do loop. */

/*	This  ind  term was not found in The table. */

	     code = 231;
	     call com_err_ (0, "ET", "^d Illegal  ir  ind  term: ^a", code, substr (window, 1, 2));


	end parse_ir_ind_term;
						/* 	*/
illegal_option:

	code = 240 + option_num;

	call com_err_ (0, "ET", "^d "" ^a "" option is illegal for ^a type instruction.",
	     code, option_name, instr_type_names (instr_type));

	return;




illegal_term:

	code = 260 + option_num;

	call com_err_ (0, "ET", "^d Illegal decimal term (^d) for option ""^a"".",
	     code, dec_num, option_name);

	return;





     end et_inst;




		    et_instr_data.alm               09/16/81  1704.2r w 09/16/81  1535.7       26748



"  ******************************************************
"  *                                                    *
"  *                                                    *
"  * Copyright (c) 1972 by Massachusetts Institute of   *
"  * Technology and Honeywell Information Systems, Inc. *
"  *                                                    *
"  *                                                    *
"  ******************************************************

"	This segment contains a data table with information about   "eis"  instructions.
"	It is used by the  eis_tester  ",3/0T"  programs.
"
"	Created  Jan, 73  by   Bill Silver
"
"	This table is referenced via the PL/I structure found in the include file -
"	et_instr_data_map.incl.pl1


	segdef	num_instructions

	segdef	instructions



num_instructions:

	dec	29		"Number of real entries in the table below.
				"The first entry is entry zero and is a dummy.




instructions:

	vfd	a36/erro		"DUMMY INSTRUNTION
	vfd	a18/r ,18/0

	vfd	a36/mlr 
	vfd	o9/100,1/1,o8/1,3/1,3/1,3/7,1/1,1/0,1/0,3/2,3/2

	vfd	a36/mrl 
	vfd	o9/101,1/1,o8/1,3/1,3/1,3/7,1/1,1/0,1/0,3/2,3/2

	vfd	a36/mvt 
	vfd	o9/160,1/1,o8/1,3/1,3/1,3/0,1/1,1/0,1/1,3/2,3/2

	vfd	a36/mve 
	vfd	o9/020,1/1,o8/1,3/1,3/1,3/1,1/1,1/1,1/1,3/3,3/3

	vfd	a36/cmpc
	vfd	o9/106,1/1,o8/1,3/1,3/3,3/7,1/1,1/0,1/0,3/0,3/0

	vfd	a36/scd 
	vfd	o9/120,1/1,o8/1,3/1,3/3,3/0,1/1,1/0,1/1,3/3,3/3

	vfd	a36/scdr
	vfd	o9/121,1/1,o8/1,3/1,3/3,3/0,1/1,1/0,1/1,3/3,3/3

	vfd	a36/tct 
	vfd	o9/164,1/1,o8/1,3/1,3/0,3/0,1/0,1/0,1/1,3/3,3/3

	vfd	a36/tctr
	vfd	o9/165,1/1,o8/1,3/1,3/0,3/0,1/0,1/0,1/1,3/3,3/3

	vfd	a36/scm 
	vfd	o9/124,1/1,o8/1,3/1,3/3,3/0,1/1,1/0,1/1,3/3,3/3

	vfd	a36/scmr
	vfd	o9/125,1/1,o8/1,3/1,3/3,3/0,1/1,1/0,1/1,3/3,3/3

	vfd	a36/mvn 
	vfd	o9/300,1/1,o8/2,3/1,3/1,3/7,1/1,1/0,1/0,3/2,3/2

	vfd	a36/cmpn
	vfd	o9/303,1/1,o8/2,3/1,3/1,3/7,1/1,1/0,1/0,3/0,3/0

	vfd	a36/mvne
	vfd	o9/024,1/1,o8/2,3/1,3/1,3/1,1/1,1/1,1/1,3/3,3/3

	vfd	a36/ad3d
	vfd	o9/222,1/1,o8/2,3/1,3/1,3/1,1/1,1/1,1/1,3/3,3/3

	vfd	a36/ad2d
	vfd	o9/202,1/1,o8/2,3/1,3/1,3/7,1/1,1/0,1/0,3/3,3/2

	vfd	a36/sb3d
	vfd	o9/223,1/1,o8/2,3/1,3/1,3/1,1/1,1/1,1/1,3/3,3/3

	vfd	a36/sb2d
	vfd	o9/203,1/1,o8/2,3/1,3/1,3/7,1/1,1/0,1/0,3/3,3/2

	vfd	a36/mp3d
	vfd	o9/226,1/1,o8/2,3/1,3/1,3/1,1/1,1/1,1/1,3/3,3/3

	vfd	a36/mp2d
	vfd	o9/206,1/1,o8/2,3/1,3/1,3/7,1/1,1/0,1/0,3/3,3/2

	vfd	a36/dv3d
	vfd	o9/227,1/1,o8/2,3/1,3/1,3/1,1/1,1/1,1/1,3/3,3/3

	vfd	a36/dv2d
	vfd	o9/207,1/1,o8/2,3/1,3/1,3/7,1/1,1/0,1/0,3/3,3/2

	vfd	a36/csl 
	vfd	o9/060,1/1,o8/3,3/2,3/2,3/7,1/1,1/0,1/0,3/3,3/2

	vfd	a36/csr 
	vfd	o9/061,1/1,o8/3,3/2,3/2,3/7,1/1,1/0,1/0,3/3,3/2

	vfd	a36/sztl
	vfd	o9/064,1/1,o8/3,3/2,3/2,3/7,1/1,1/0,1/0,3/0,3/0

	vfd	a36/sztr
	vfd	o9/065,1/1,o8/3,3/2,3/2,3/7,1/1,1/0,1/0,3/0,3/0

	vfd	a36/cmpb
	vfd	o9/066,1/1,o8/3,3/2,3/2,3/7,1/1,1/0,1/0,3/0,3/0

	vfd	a36/dtb 
	vfd	o9/305,1/1,o8/4,3/1,3/1,3/7,1/1,1/0,1/0,3/2,3/2

	vfd	a36/btd 
	vfd	o9/301,1/1,o8/4,3/1,3/1,3/7,1/1,1/0,1/0,3/2,3/2


	end




		    et_mf.pl1                       06/03/82  1651.3rew 06/03/82  1023.7      173691



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


et_mf: procedure (option, arg_et_data_ptr, code);



/*	This procedure will parse the data in a "-mf" option that is part of
   *	an  "inst"  statement.
   *
   *	Originally coded  Feb, 73  by  Bill Silver
   *
   *
   *	An  mf  option has the following format.
   *
   *	-mfX	term . . . term
   *
   *	1.  The first field in the option is the option name  "-mf".
   *
   *	2.  Immediately following it  MUST  be the number of the descriptor to which this
   *	    mf  field relates.  Below  X  is used to indicate this value.
   *
   *	3.  Following the descriptor number may be up to  4  terms.  All are optional.
   *	    They may be specified in any order.   The valid  terms  are:
   *
   *
   *	a)  ar	This term specifies that the descriptor is to use  Address Register  modification.
   *		In Multics it is called pointer register modification.  The pointer
   *		assigned is  prX.   When this term is specified the data referenced by this
   *		descriptor will be placed in a different segment from the descriptor.
   *		It will go in segment  etdX.
   *
   *	d)  rl L	This term specifies that the descriptor is to use  Register Length  modification.
   *		This term  MUST  be followed by a decimal number "L" which specifies the
   *		character length of the data.  This value will be placed in the selected
   *		register and the  "n"  field of descriptor X will contain the register
   *		modification tag code.   The registers assigned are:
   *		X  =  1   -  A
   *		X  =  2   -  Q
   *		X  =  3   -  x6
   *
   *	c)  idA	This term specifies that descriptor X is to be referenced via an indirect
   *		word in the instruction.  The character immediately following the the
   *		"id"  term denotes what modification is to be used in the indirect word.
   *
   *		A  =  "a" ( ida )  This implies  Address (pointer) register modification.
   *			When this is specified the descriptor will be placed in a segment
   *			other than the segment containing the instruction.  This will
   *			be segment  etiX.  Note, if the descriptor does not specify  AR
   *			modification then the data for this descriptor will also be in
   *			segment  etiX.  The pointers registers assigned to an indirect
   *			word  are:  indirect word 1  =>  pr4
   *				  indirect word 2  =>  pr5
   *				  indirect word 3  =>  pr7
   *
   *		A  =  "r" ( idr )  This implies  Register modification.  The indirect
   *			word will be modified by index registers 4,5, or 7.  Note, this
   *			modification will be in terms of  WORDS.
   *
   *		A  =  "b" ( idb )  This implies both  "a" and "r"  modification as described
   *			above.
   *
   *		If  A  is none of the above then there is no modification in the
   *		indirect word.
   *
   *	b)  reg	This term specifies that descriptor X is to be modified by an index REGister.
   *		The value in the index register will be a CHARACTER offset and is  (x * 4).
   *		The index register assigned will be  index register X.  The value placed
   *		in index register  X  is dependent upon the type of instruction and the
   *		appropriate character size.  It will be in the following units:
   *		WORDS	For those descriptors which have no  mf  field in the
   *			instruction word.
   *		BITS	For all bit string instructions.
   *		CHARS	For all others.  The actual units depends upon the character
   *			size.  The default is a  9 bit character size.
*/






/*		PARAMETER  DATA		*/


dcl  option char (*),				/* The input string containing the  "-mf"
						   *  option to be parsed. */

     arg_et_data_ptr ptr,				/* Input pointer to the  et  data.  */

     code fixed bin (35);				/* Error code.  */






/*		AUTOMATIC  DATA		*/


/*	The following data items are used in calls to  et_util.  */

dcl  option_ptr ptr,				/* Pointer to the  "-mf"  input option. */

     start fixed bin (35),				/* The number of characters allready
						   *  processed in this  "-mf"  option.
						   *  The next character is the start of
						   *  the window.  */

     size fixed bin (35),				/* The current size ( in characters )
						   *  of the window on the "-mf" option. */

     next_option_x fixed bin;				/* Index of the last character in the
						   *  option - in effect the number of
						   *  characters in the option.  */


/*	These are some temporary variables. */

dcl  dec_num fixed bin,				/* Holds converted decimal number. */

     i fixed bin,

     len fixed bin,					/* Length of a field. */

     desc_ptr ptr,					/* Work pointer to a descriptor word. */
     indw_ptr ptr,
     mf_ptr ptr,

     offsetx fixed bin,				/* Used to modify a pointer register or an
						   *  address field.  */

     term_name char (3);				/* Used to temporarily hold a term name.  */


/*	The following data items are used when processing descriptors.  */

dcl  dx fixed bin,					/* Index to  those tables that dependent of the
						   *  three descriptors or indirect words.  */

     idx fixed bin,					/* Number of the pointer register and index
						   *  register used in modification of an
						   *  indirect word.  */

     mf_inst_flag bit (1),				/* On => mf field is in the instruction word.
						   *  Off => it is in the descriptor word.  */

     indw_ar_flag bit (1),				/* On => the current indirect word must use
						   *  ar  modification.  */

     indw_reg_flag bit (1);				/* On => the current indirect word must use
						   *  reg  modification.  */





/*		BASED  DATA		*/


/*	This is an overlay of the input  "-mf"  option.  */

dcl 1 mf_option based (option_ptr),			/* Used to access the input data option
						   *  as a stream of characters. */

    2 offset char (start),				/* The part of the "-mf" option which we have
						   *  allready processed. */

    2 window char (size);				/* The part of the "-mf" option which we are
						   *  currently accessing.  */


/*	An overlay of the decimal numbers which hold the input data terms.  */

dcl  bit_word bit (36) based (addr (dec_num)) aligned;


/*	An overlay of an  mf  field.  */

dcl 1 mf_map based unaligned,
    2 ar bit (1),
    2 rl bit (1),
    2 id bit (1),
    2 reg bit (4);


dcl 1 desc_map based aligned,
   (2 pr_num bit (3),
    2 y fixed bin (14),
    2 pad bit (14),
    2 rl_num bit (4)) unaligned;


dcl 1 indw_map based aligned,
   (2 pr_num bit (3),
    2 y fixed bin (14),
    2 pad1 bit (11),
    2 ar bit (1),
    2 pad2 bit (2),
    2 reg bit (4)) unaligned;





/*		INTERNAL  STATIC  DATA	*/


/*	A table of valid term names for an  mf  option.  */

dcl  term_names (4) char (2) internal static
     init ("ar", "rl", "id", "re");


/*	These two tables contain the modification tag codes which are placed in an  mf  field
   *	or in an  indirect word.  They represent  x1 - x3  and  x4,x5, and x7  respectively.
*/

dcl  mf_reg_tags (3) bit (4) internal static
     init ("1001"b, "1010"b, "1011"b);

dcl  indw_reg_tags (3) bit (4) internal static
     init ("1100"b, "1101"b, "1111"b);


/*	These arrays point to the various data area that are used.  */

dcl (init_flag bit (1) init ("0"b),

     etx_ind_ptrs (3) ptr,
     eti_ind_ptrs (3) ptr,
     eti_data_ptrs (3) ptr,
     etd_data_ptrs (3) ptr) internal static;






/*		EXTERNAL  DATA		*/


/*	The following declarations reference the procedures called by  et_desc.  */

dcl (etx$ind1, etx$ind2, etx$ind3) external,
    (eti1$ind, eti2$ind, eti3$ind) external,
    (eti1$data, eti2$data, eti3$data) external,
    (etd1$data, etd2$data, etd3$data) external;


dcl  com_err_ entry options (variable),
     et_util$skip entry (ptr, fixed bin (35), fixed bin (35)),
     et_util$convert_decimal entry (ptr, fixed bin (35), fixed bin (35), fixed bin,
     fixed bin (35));


dcl (addr,
     addrel,
     fixed,
     length,
     null,
     rel,
     substr,
     verify) builtin;
						/*  */
%include et_instr_data_map;
/* 	*/
%include et_setup_data;
/* 	*/
/*	Set up the window on the input  "-mf"  option.  We will skip the
   *	"-mf" field at the beginning of the option.
*/

	option_ptr = addr (option);
	next_option_x = length (option);

	et_data_ptr = arg_et_data_ptr;		/* Copy this argument.  */


	start = 0;
	size = next_option_x;


/*	Validate and convert the num  field.  */

	len = verify (substr (window, 1, 1), "123");

	if len = 0

	then do;
	     dx = fixed (substr (window, 1, 1), 17);
	     start = start + 1;
	     size = size - 1;
	end;

	else do;
	     code = 601;
	     call com_err_ (0, "ET", "^d Illegal desc num  field: ^a",
		code, substr (window, 1, 1));
	     return;
	end;


/*	Now test to see if we should process this  mf  field.  Only  mf  field 3  is in
   *	question.  If this  num field  is a  3  then check to see if there is an  mf
   *	field for this descriptor.
*/

	if (dx = 3) & (mf_ptrs (3) = null ())

	then do;
	     code = 602;
	     call com_err_ (0, "ET", "^d -mf3  option invalid - instruction has only 2 descriptors.", code);
	     return;
	end;


/*	Get a pointer to the  mf field  we will be working with.  */

	start = start + 1;				/* Move window past  num  field. */
	size = size - 1;


/*	Now we must initialize some of the data that we may need.  */

	desc_ptr = addr (descriptors (dx));
	indw_ptr = addr (ind_words (dx));
	mf_ptr = mf_ptrs (dx);

	mf_inst_flag = "1"b;

	if (dx = 2) & (^et_instr_data$instructions (instr_num).mf2_flag)
	then mf_inst_flag = "0"b;

	if (dx = 3) & (^et_instr_data$instructions (instr_num).mf3_flag)
	then mf_inst_flag = "0"b;


/*	Initialize these pointers just once per process.  */

	if init_flag then goto term_loop;

	eti_data_ptrs (1) = addr (eti1$data);
	eti_data_ptrs (2) = addr (eti2$data);
	eti_data_ptrs (3) = addr (eti3$data);

	etd_data_ptrs (1) = addr (etd1$data);
	etd_data_ptrs (2) = addr (etd2$data);
	etd_data_ptrs (3) = addr (etd3$data);

	etx_ind_ptrs (1) = addr (etx$ind1);
	etx_ind_ptrs (2) = addr (etx$ind2);
	etx_ind_ptrs (3) = addr (etx$ind3);

	eti_ind_ptrs (1) = addr (eti1$ind);
	eti_ind_ptrs (2) = addr (eti2$ind);
	eti_ind_ptrs (3) = addr (eti3$ind);

	init_flag = "1"b;
						/* 	*/
						/*	Now start to process the terms.  We will test for each possible term name.
						   *	Each iteration of this loop will process one term.
						   */


term_loop:


/*	Skip to the next term.  If we find the end of the statement or the beginning of a new
   *	option we will know that there are no more terms in this  mf  field.
*/

	call et_util$skip (option_ptr, start, size);

	if (substr (window, 1, 1) = ";") | (substr (window, 1, 1) = "-")

	then return;


/*	Look through the list of valid term names.  */

	term_name = substr (window, 1, 2);

	do i = 1 to 4;

	     if term_name = term_names (i)

	     then do;
		start = start + 2;			/* Move window past term name.  */
		size = size - 2;
		goto term_routine (i);		/* Go to routine which processes this term. */
	     end;
	end;

	goto illegal_term;				/* We didn't find a valid term name.  */
						/* 	*/
term_routine (1):					/*  ar  */


/*	First set up the  ar  bit in the  mf  field.  */

	mf_ptr -> mf_map.ar = "1"b;


/*	Next set up the pointer register number in the descriptor.  */

	desc_ptr -> desc_map.pr_num = substr (addr (dx) -> bit_word, 34, 3);


/*	Now set up the data pointer.  Since  ar  modification is present we know that the
   *	data will go into segment  etdX.
*/

	data_ptrs (dx) = etd_data_ptrs (dx);


/*	Now we must set up the address field and the pointer register used by this
   *	descriptor.  The address field in the descriptor will be set to  8 * X.
   The pointer register will actually point to the data but will be adjusted by
   *	the value of the descriptor address so the effective address will be correct.
   *	If  reg  modification is also specified then we must adjust the descriptor address
   *	by the effective word offset of the specified index register.
*/

	offsetx = dx * 8;

	if mf_ptr -> mf_map.reg = "0"b

	then desc_ptr -> desc_map.y = offsetx;

	else desc_ptr -> desc_map.y = offsetx - dx;

	pointers (dx) = addrel (data_ptrs (dx), -offsetx);

/*	That's it for an  ar  modifier.  Go back and process the next term.  */

	goto term_loop;
						/* 	*/
term_routine (2):					/*  rl  */

/*	The first thing we must do is to see if if is legal to have  rl  modification
   *	with this  mf  field.  If the  mf field  is not in the instruction word itself
   *	then  rl  modification is illegal.
*/

	if ^mf_inst_flag

	then do;
	     code = 621;
	     call com_err_ (0, "ET", "^d RL modification is illegal for  mf^d.", code, dx);
	     return;
	end;


/*	It is  OK.  We must get the length term that must follow the  rl  term.  */

	call et_util$skip (option_ptr, start, size);

	call et_util$convert_decimal (option_ptr, start, size, dec_num, code);

	if code ^= 0

	then do;
	     call com_err_ (0, "ET", "^d Illegal  rl  term length field.", code);
	     return;
	end;

/*	Now we will turn  ON  the  rl  bit in the  mf  field.  Then depending upon which
   *	descriptor this  mf  field is for we will go to the routine which will put the length
   *	in the correct register and set the correct register code in the descriptor.
*/

	mf_ptr -> mf_map.rl = "1"b;

	goto rl_routine (dx);


rl_routine (1):

	regs.A = dec_num;
	desc_ptr -> desc_map.rl_num = "0101"b;
	goto term_loop;


rl_routine (2):

	regs.Q = dec_num;
	desc_ptr -> desc_map.rl_num = "0110"b;
	goto term_loop;


rl_routine (3):

	regs.x (6) = dec_num;
	desc_ptr -> desc_map.rl_num = "1110"b;
	goto term_loop;
						/* 	*/
term_routine (3):					/*  id  */


/*	The first thing we must do is to see if it is legal to have  id  modification
   *	with this  mf  field.  If the  mf field  is not in the instruction word itself
   *	then  id  modification is illegal.
*/

	if ^mf_inst_flag

	then do;
	     code = 631;
	     call com_err_ (0, "ET", "^d ID modification is illegal for  mf^d.", code, dx);
	     return;
	end;


/*	The  id  term may be followed by a character which specifies  ar  or  reg  modification.
   *	We must look for that character and set the flags which indicate these types of
   *	modification.  If either of the two is specified we must move the window past
   *	this character.
*/

	indw_ar_flag = "0"b;
	indw_reg_flag = "0"b;

	if substr (window, 1, 1) = "b"
	then do;
	     indw_ar_flag = "1"b;
	     indw_reg_flag = "1"b;
	end;

	if substr (window, 1, 1) = "a"
	then indw_ar_flag = "1"b;

	if substr (window, 1, 1) = "r"
	then indw_reg_flag = "1"b;

	if (indw_ar_flag) | (indw_reg_flag)
	then do;
	     start = start + 1;
	     size = size - 1;
	end;


/*	Now perform the necessary initialization.  We must turn ON the  id  bit in the
   *	mf  field.  We will initially assume that the indirect word does not use
   *	ar  modification.  Thus the descriptor will be in segment  etx.  We will also
   *	initially assume that the indirect word does not use  reg  modification.
   *	Just in case, however, we will set the number of the pointer register or index
   *	used by this indirect word.
*/

	mf_ptr -> mf_map.id = "1"b;

	desc_ptrs (dx) = etx_ind_ptrs (dx);

	indw_ptr -> indw_map.y = fixed (rel (desc_ptrs (dx)), 14);

/*	Set up the number of the pointer register and index register that the indirect
   *	word will use.  We use  4,5, and 7 because we do not want to use  pointer
   *	register 6 - it is the stack pointer.
*/

	if dx = 3
	then idx = 7;
	else idx = dx + 3;


/*	If this indirect word requires  ar  modification then we must do the following:
   *	1.  Turn on the  ar  bit in the indirect word.
   *	2.  Set the pointer register number in the indirect word.
   *	3.  Change the  desc_ptrs entry.  The indirect descriptor will now be placed
   *	    in segment  etiX.
   *	4.  Set up the address field in the indirect word.
   *	5.  Set up the pointer register used by the indirect word.  It will point to
   *	    the descriptor but must be adjusted by the value in the indirect word's address
   *	    field so the effective address will be correct.
*/

	if ^indw_ar_flag then goto check_indw_reg;

	indw_ptr -> indw_map.ar = "1"b;

	indw_ptr -> indw_map.pr_num = substr (addr (idx) -> bit_word, 34, 3);

	desc_ptrs (dx) = eti_ind_ptrs (dx);

	indw_ptr -> indw_map.y = idx * 8;

	pointers (idx) = addrel (desc_ptrs (dx), - indw_ptr -> indw_map.y);


/*	If the descriptor itself has  ar  modification then the data will be in segment
   *	etdX.  We will leave it there.  However, if the descriptor does not specify
   *	ar  modification then the data currently is to be in segment  etx.   We must change
   *	this and put the data in the same segment as the descriptor which is in segment
   *	etiX.  Note, if the descriptor specifies  reg  modification then we will have
   *	to adjust the new descriptor address.
*/

	if mf_ptr -> mf_map.ar then goto check_indw_reg;

	data_ptrs (dx) = eti_data_ptrs (dx);

	if mf_ptr -> mf_map.reg = "0"b
	then offsetx = 0;
	else offsetx = - dx;

	desc_ptr -> desc_map.y = fixed (rel (addrel (data_ptrs (dx), offsetx)), 14);


/*	Now check for register modification.  If it is specified the offset will be
   *	idx  WORDS.  We don't care whether or not  ar  modification has been specified.
   *	In either case we must:
   *	1.  Set the index modifier tag code in the indirect word.
   *	2.  Put the word offset in the index register to be used.
   *	3.  Adjust the address field that is in the indirect word.
*/

check_indw_reg:

	if indw_reg_flag

	then do;

	     indw_ptr -> indw_map.reg = indw_reg_tags (dx);

	     regs.x (idx) = idx;

	     indw_ptr -> indw_map.y = indw_ptr -> indw_map.y - idx;

	end;


/*	Now we can set up the  page_ptrs  entry for this indirect descriptor.
   *	Their entries are:  3, 7, & 11.
*/

	page_ptrs (3 + (dx-1)*4) = desc_ptrs (dx);


	goto term_loop;
						/* 	*/
term_routine (4):					/*  reg  */


/*	We came here because we found an  "re".  Lets check to see that the next character
   *	is really the  "g".
*/

	substr (term_name, 3, 1) = substr (window, 1, 1);

	if term_name ^= "reg"
	then goto illegal_term;

	start = start + 1;
	size = size - 1;


/*	This is a valid  reg  term.  We must do the following:
   *	1.  Set the index register modifier tag code in the mf field.
   *	2.  Adjust the address field in the descriptor.  We must adjust it by a word
   *	    offset.  This value then will just be  X.
   *	3.  NOTE, we will not set up the value in the index register now.   We know that
   *	    it should be  X  words but we don't know what mode to express this offset
   *	    in yet.   This will be done by  "et_test"  when all the data statements have
   *	    been parsed.
*/

	mf_ptr -> mf_map.reg = mf_reg_tags (dx);

	desc_ptr -> desc_map.y = desc_ptr -> desc_map.y - dx;

	goto term_loop;
						/* 	*/
illegal_term:

	code = 607;

	call com_err_ (0, "ET", "^d Illegal  mf  term: ""^a"".", code, term_name);

	return;




     end et_mf;




		    et_page.pl1                     06/03/82  1651.3rew 06/03/82  1024.0       50850



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


et_page: procedure (statement, arg_et_data_ptr, code);



/*	This procedure parses a page statement.
   *
   *	Created  Jan, 73  by  Bill Silver.
   *
   *
   *	The format of a  "page"  statement is:
   *
   *	page   -option . . . -option ;
   *
   *	1.  The first field in the statement MUST be the statement name "page".
   *
   *	2.  The other fields are options which specify what pages are to HAVE page
   *	    faults.   The following page names are defined:
   *
   *	    in1 in2      The 2 pages of the  eis  instruction itself.
   *
   *	    id1 id2 id3  The pages used by descriptors that are referenced via
   *       	                 indirect words.
   *
   *	    d11 d12 d13  The three pages of data referenced by descriptor  1.
   *
   *	    d21 d22 d23  The three pages of data referenced by descriptor  2.
   *
   *	    d31 d32 d32  The three pages of data referenced by descriptor  3.
   *
   *	3.  If the  "-all"  option is entered then  ALL  of the pages defined for this
   *	    instruction will take a page fault.  If other options are entered along
   *	    with the  "-all"  option then the pages specified will NOT have page faults.
*/




/*	The following data items are used as arguments in the call to  et_page. */

dcl  statement char (*),				/* The input string which contains the  "page"
						   *  statement to be parsed.  */

     arg_et_data_ptr ptr,				/* Input pointer to  et_setup_data.  */

     code fixed bin (35);				/* Error code.  */



dcl  state_ptr ptr,					/* Pointer to the  "page"  statement.  */

     start fixed bin (35),				/* The number of characters allready processed
						   *  in this  "page"  statement.  */

     size fixed bin (35),				/* The current size ( in characters )
						   *  of the window on the  "page"  statement. */

     next_statement_x fixed bin;			/* The number of the last character in
						   *  the current statement.  */



/*	This is an overlay of the input  "page"  statement.  */

dcl 1 page_statement based (state_ptr),			/* Used to access the input data statement
						   *  as a stream of characters. */

    2 offset char (start),				/* The part of the  "page"  statement which we
						   *  have allready processed. */

    2 window char (size);				/* The part of the  "page"  statement which we
						   *  are currently accessing.  */



dcl  i fixed bin;					/* Temporary variable. */




/*	The following table defines the names of the pages which are currently
   *	under the control of the user.
*/

dcl  page_names (14) char (4) internal static

     init ("-in1", "-in2",
     "-id1", "-d11", "-d12", "-d13",
     "-id2", "-d21", "-d22", "-d23",
     "-id3", "-d31", "-d32", "-d33");




dcl  com_err_ entry options (variable),
     et_util$skip entry (ptr, fixed bin (35), fixed bin (35));




dcl (addr,
     length,
     substr) builtin;
						/* 	*/
%include et_instr_data_map;
/* 	*/
%include et_setup_data;
/* 	*/
/*	First we must set up the window on the input  "page"  statement.  We will skip the
   *	"page"  field at the beginning of the statement.  Note, the initial values for all of
   *	the entries in the page_faults array is OFF which implies no page faults.
*/

	state_ptr = addr (statement);
	next_statement_x = length (statement);

	et_data_ptr = arg_et_data_ptr;

	start = 4;
	size = next_statement_x - 4;


/*	Now process all of the options in this statement.   */


	do while (code = 0);


/*	Look for the next page name.  We are done when we hit the end of the statement.  */

	     call et_util$skip (state_ptr, start, size);

	     if substr (window, 1, 1) = ";"

	     then return;


/*	Test to see if we have an  "-all"  option.  If not we will assume
   *	that it is a regular page name option.  Note, we will invert the value for all
   *	pages.  If other options are entered then they will will cause the page they represent
   *	to be an exception to the  "-all".
*/

	     if substr (window, 1, 4) = "-all"

	     then do i = 1 to 14;
		page_faults (i) = ^page_faults (i);
	     end;


	     else do;
		call find_page_name;
		if code ^= 0
		then return;
	     end;

	     start = start + 4;			/* Move window past page name. */
	     size = size - 4;

	end;					/*  End of  do  loop.  */


/*	This is the logical end of the  parse_page_statement  procedure.  */
/* 	*/
find_page_name: procedure;



/*	This procedure searches the  page_names  table for the current page name
   *	option which is assumed to be the next three characters  in the window.
   *	If  the page name option is valid then its position in the page_names
   *	table is used to locate it corresponding position in the  page_faults
   *	table and the entry in this table is changed.
*/



	     do i = 1 to 14;


		if substr (window, 1, 4) = page_names (i)

		then do;				/* We have found the page - invert its entry. */
		     page_faults (i) = ^page_faults (i);
		     return;
		end;

	     end;


/*	This page name option was not found so it must be illegal.  */

	     code = 501;
	     call com_err_ (0, "ET", "^d Page names option ^a is invalid.",
		code, substr (window, 1, 3));

	end find_page_name;




     end et_page;




		    et_test.pl1                     06/03/82  1651.3rew 06/03/82  1024.2      112059



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


et_test: procedure (script_ptr, script_len, arg_et_data_ptr, finished_flag, code);


/*	Modified Aug, 1980 to add capability to run the new ets scripts.
   *	Accomplished by changing declaration of most fixed bin variables to
   *	fixed bin (35).
*/



/*	This procedure will parse the input data for one instruction.  The data
   *	for each instruction consists of statements.  There are four types of
   *	statements: inst, desc, data, and page.  The first statement of each
   *	instruction must be an  "inst"  statement.
   *	The format of a statement is as follows:
   *
   *	name	required_field	-option . . . -option . . .;
   *
   *	1.  The first field in all statements MUST be its  4  character statement
   *	    name:  "inst", "desc", "data", or "page".
   *
   *	2.  In some statements (all but page) the second field in the statement
   *	    MUST be some required information.
   *
   *	3.  The other fields in the statement represent optional data which may or
   *	    may not be given.  Each option field MUST begin with a "-".
   *
   *	4.  All statements must end with a ";".
   *
   *	5.  There may be any number of  blanks, tabs, and new line  characters between
   *	    any  fields in the statement, including before the name field.
   *
   *	6.  Wherever blanks are permitted (see 5. above) there may also be comment
   *	    fields.  Comments MUST begin with the characters "/*" and end with
   *	    the characters "*/".
   *
   *	Initial code on  10/24/72  by  Bill Silver.
*/



/*	The following data items are used as arguments in the call to  et_test. */

dcl  script_ptr ptr,				/* Pointer to the input data file. */

     script_len fixed bin (35),			/* The length in characters of the
						   *  input data file. */

     arg_et_data_ptr ptr,				/* Pointer to the  et_data  area.  */

     finished_flag fixed bin,				/* Indicates when all of the instructions
						   *  have been tested.  */

     code fixed bin (35);				/* Error code.  */




/*	This is an overlay of the input script file.  */

dcl 1 script based (script_ptr),			/* Used to access the input data segment
						   *  as a stream of characters. */

    2 offset char (start),				/* The part of the segment which we have
						   *  allready processed. */

    2 window char (size);				/* The part of the segment which we are
						   *  currently accessing.  */


dcl  start fixed bin (35),				/* The number of script characters allready
						   *  processed.  The next character is the start
						   *  of the window.  */

     size fixed bin (35);				/* The current size (in characters) of the window
						   *  on the script segment.  */



/*	These are some temporary variables. */

dcl  i fixed bin (35),				/* Work index variables. */

     len fixed bin (35),				/* Temporary.  */

     next_statement_x fixed bin (35),			/* The number of the last character in the
						   *  current statement.  */

     save fixed bin (35),				/* Temporary.  */

     test_x fixed bin;				/* Used to hold the test_x field from this
						   *  instruction's entry in the et_instr_data
						   *  table.  */



/*	An overlay of an  mf  field.  */

dcl 1 mf_map based unaligned,
    2 ar bit (1),
    2 rl bit (1),
    2 id bit (1),
    2 reg bit (4);


dcl  stringrange_label label internal static;




dcl  com_err_ entry options (variable),

     condition_ entry (char (*), entry),

     et_inst entry (char (*), ptr, fixed bin (35)),
     et_desc entry (char (*), ptr, fixed bin (35)),
     et_data entry (char (*), ptr, fixed bin (35)),
     et_page entry (char (*), ptr, fixed bin (35)),

     et_util$get_next entry (ptr, fixed bin (35), fixed bin (35), char (*), fixed bin (35)),
     et_util$skip entry (ptr, fixed bin (35), fixed bin (35));


dcl  substr builtin;
						/* 	*/
%include et_instr_data_map;
/*  */
%include et_setup_data;
/* 	*/
/*	Establish a window onto the data segment which will look at all of the data
   *	of this one instruction.  */

	et_data_ptr = arg_et_data_ptr;		/* Copy this argument so we can reference
						   *  common data directly.  */

	start = next_instruction_x;			/* Start the window at the beginning
						   *  of the next instruction's data.  */
	size = script_len - start;			/* From there open the window on
						   *  the rest of the file.  */

/*	Move the window so that it starts at the beginning of the statement name
   *	of the next test statement.  If len = 0 then none was found. */

	call et_util$get_next (script_ptr, start, size, "inst", len);
	if len = 0
	then do;
	     code = 100;
	     call com_err_ (0, "ET", "^d Script does not contain valid ""inst"" statement.", code);
	     finished_flag = 1;			/* Set flag to end the whole  */
	     return;				/* thing.  End it now. */
	end;


/*	We do have an instruction statement to start out test.  We must set up a condition
   *	handler for the  "stringrange"  condition.  We will also set up the label variable
   *	which the condition handler procedure can use to get back to this stack frame.
*/

	call condition_ ("stringrange", stringrange_handler);

	stringrange_label = stringrange_error;

	save = start;				/* Remember where the window is now at
						   *  the beginning of this instruction.
						   *  Right at the  "inst"  statement name. */

	start = start + 4;				/* Move the window to after the  "inst".  */
	size = size - 4;


/*	Find the beginning of the next instruction.  */

	call et_util$get_next (script_ptr, start, size, "inst", len);

	if len = 0

/*	If no new instruction was found ( the current one is the last one ) then
   *	move the window back to the beginning of the current instruction and
   *	then set the size of the window to be the rest of the segment.  Also set
   *	the finished_flag  on  to indicate that this is the last instruction to test. */

	then do;
	     start = save;
	     size = script_len - start;
	     next_instruction_x = script_len;
	     finished_flag = 1;
	end;

/*	If there is another instruction remember where it starts by saving its
   *	address (character number) in next_instruction_x.  Then move the window
   *	back to the beginning of the current instruction.  Set the size of the
   *	window so that it is open to just the data of the current instruction. */

	else do;
	     next_instruction_x = start;
	     start = save;
	     size = next_instruction_x - start;
	end;
						/* 	*/
						/*	Now look through the statements of this test.  Each statement must
						   *	end with a  ";".  First we must set up the  next_statement_x to
						   *	point to the beginning of the  "inst" statement.
						   */
	next_statement_x = start;



statement_loop:

	start = next_statement_x;			/* Move the window to start at
						   *  the beginning of the next state. */
	size = next_instruction_x - start;		/* The window looks at the rest
						   *  of the data for this instruction.  */

	save = start;				/* Save the start of the window at
						   * the beginning of the current statement. */

/*	Look for the ";" which denotes the end of the statement.  */

	call et_util$get_next (script_ptr, start, size, ";", len);
	if len = 0				/* If no ";" then there are no more */
	then goto end_statements;			/* statements to parse for this test.  */

/*	If there is a statement then remember where this statement ends and the next
   *	one begins.  Move the window back to the beginning of the current statement
   *	and open it so that it just references the data for this statement.
*/

	next_statement_x = start + 1;			/* start references the character
						   *  before the ";" so if we want to
						   *  include the ";" in the window for
						   *  this statement we must extend the
						   *  window by one character. */
	start = save;
	size = next_statement_x - start;

/*	Now search for the statement name of this statement.  Note that the first
   *	statement of each instruction must be an  "inst" statement.  It is processed
   *	in this generalized manner.  All other statements do not have to be in any
   *	special order.  The statement name does not have to be at the beginning
   *	of the statement line but it must be the first non skip field.
*/
	call et_util$skip (script_ptr, start, size);

/*	Now test to see if we have a valid statement name.  If we do we will call
   *	the procedure which will parse this statement.  If there is no valid
   *	statement name then we have to return with an error.
   *	Note, upon entry to any of the statement parsing procedures the data window
   *	will start at the first character of the statement name and end at either
   *	a ";" or the end of the data for this instruction.
*/

	if substr (window, 1, 4) = "inst"
	then call et_inst (window, et_data_ptr, code);

	else if substr (window, 1, 4) = "desc"
	then call et_desc (window, et_data_ptr, code);

	else if substr (window, 1, 4) = "data"
	then call et_data (window, et_data_ptr, code);

	else if substr (window, 1, 4) = "page"
	then call et_page (window, et_data_ptr, code);

	else do;
	     call com_err_ (0, "ET", "^d Invalid statement name: ^a ",
		code, substr (window, 1, 4));
	     code = 102;
	end;


/*	If the statement just parsed contained an error we will skip the whole test.
   *	The index to the beginning of the next instruction will be saved in "next_instruction_x"
   *	and the next time  "et_test"  is entered  it will start working on the the next
   *	instruction test.
*/

	if code ^= 0 then return;			/* Was there an error?  */



	goto statement_loop;			/* This is the end of the  loop which
						   *  processes the statements in an instruction
						   *  test.  Each iteration processes one
						   *  statement.  */



/*	Now we have parsed all of the statements in this instruction test.
   *	We must set up any index registers that are used in modification of a descriptor.
   *	This is based on the number of characters per word for this descriptor.
*/

end_statements:

	if mf_ptrs (3) = null ()
	then len = 2;
	else len = 3;

	do i = 1 to len;
	     if mf_ptrs (i) -> mf_map.reg ^= "0"b
	     then if num_chars (i) ^= -1
		then regs.x (i) = i * num_chars (i);
		else regs.x (i) = i * num_chars (1);
	end;


/*	Now we must check that the appropriate data fields have been set up by input data.
   *	statements.  We will check the following:
   *
   *	1.  Every instruction must have data for descriptor 1.
   *	2.  If the statement is used to input test data is not a   or data 2  statement
   *	    then there must be data for descriptor 2.
   *	3.  If there is a third descriptor and the test data is NOT input via a  data 3
   *	    statement then there must be data for descriptor 3.
   *	4.  If there is supposed to be test data for this instruction then this data must
   *	    be present.
*/


	test_x = et_instr_data$instructions (instr_num).test_x;


	if data_lens (1) = 0

	then call error_missing_data (1);


	if (test_x ^= 2) & (data_lens (2) = 0)

	then call error_missing_data (2);


	if (et_instr_data$instructions (instr_num).desc_3_flag) &

	(test_x ^= 3) & (data_lens (3) = 0)

	then call error_missing_data (3);


	if (test_x ^= 0) & (data_lens (4) = 0)

	then call error_missing_data (test_x);



	return;
						/* 	*/
						/*	We come here from the stringrange handler procedure.  */


stringrange_error:

	code = 109;

	call com_err_ (0, "ET", "^d Stringrange condition.  Current window is: ^/^a", code, window);

	return;






stringrange_handler: procedure;

	     goto stringrange_label;

	end stringrange_handler;
						/* 	*/
error_missing_data: procedure (data_num);


dcl  data_num fixed bin;				/* The number of the data statement that is missing.  */


	     code = 110 + data_num;


	     if data_num ^= test_x

	     then
		call com_err_ (0, "ET", "^d data ^d statement missing or incomplete.",
		code, data_num);

	     else
	     call com_err_ (0, "ET", "^d Test data ^d statement missing or incomplete.",
		code, data_num);


	end error_missing_data;




     end et_test;




		    et_util.pl1                     06/03/82  1651.3rew 06/03/82  1024.5       98208



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


et_util: procedure;


/*	Modified Aug, 1980 to add capability to run the new ets scripts.
   *	Accomplished by changing declaration of most fixed bin variables to
   *	fixed bin (35).
*/


/*	This procedure contains code which performs utility jobs for  ET.
   *
   *
   *
   *	The following data items are parameters to the various utility entries
   *	and procedures.
*/


dcl  script_ptr ptr,				/* Pointer to input data segment. */

     start fixed bin (35),				/* The number of script characters
						   *  allready processed.  The next
						   *  character is the start of the
						   *  window.  */

     size fixed bin (35),				/* The current size ( in characters )
						   *  of the window on the script seg. */

     next_statement_x fixed bin (35),			/* The number of the last character in
						   *  the current statement.  */

     arg_test_string char (*),			/* The character string searched for
						   *  by  get_next. */

     len fixed bin (35),				/* A temporary string length.  It is returned
						   *  by  get_next.  */

     ptr_data ptr,					/* Pointer to be adjusted in call to char_rel. */

     rel fixed bin,					/* Number of characters to adjust above pointer. */

     dec_num fixed bin,				/* Holds converted decimal number. */

     code fixed bin (35);				/* Error code. */




/*	The following data items are work variables used by the various utility
   *	entries and procedures.  */

dcl  save fixed bin (35),				/* Used to save the start of the
						   *  current window.  */

     field_len fixed bin (35),			/* A work variable which indicates
						   *  the size of a character string. */

     i fixed bin (35),				/* Temporary index. */

     sign fixed bin,				/* The sign of a decimal number.  */

     test_string char (8) aligned,			/* Contains the string searched for by
						   *  get_next.  */

     ptr_ptr ptr,					/* Points to the pointer being adjusted.  */

     bit_count fixed bin,				/* Work variable used by  char_rel.  */

     word_count fixed bin,				/* Number of words used when adjusting a pointer. */

     workx fixed bin;



dcl 1 script based (script_ptr),			/* Used to access the input data segment
						   *  as a stream of characters. */

    2 offset char (start),				/* The part of the segment which we have
						   *  allready processed. */

    2 window char (size);				/* The part of the segment which we are
						   *  currently accessing.  */


dcl  based_offset fixed bin (17) based unaligned,

     based_bit_offset fixed bin (5) based unaligned;




dcl  com_err_ entry options (variable),
     ioa_ entry options (variable);


dcl (addr,
     divide,
     fixed,
     index,
     length,
     search,
     substr,
     verify) builtin;
						/* 	*/
%include its;
/*  */
get_next:	entry (script_ptr, start, size, arg_test_string, len);



/*	This  entry  searches the current window for a specified character
   *	string.  The trick is to ignore any such occurrences of the
   *	specified string which are within comment fields.  Otherwize
   *	we could have used the  index  built-in.
*/



	field_len = length (arg_test_string);

	test_string = arg_test_string;


	do while (field_len > -1);			/* Loop on some imposible condition. */

	     call skip_proc;

/*	If there are no non skip characters in the window we won't find
   *	our test_string. */

	     if workx = 0
	     then do;
		len = 0;
		return;
	     end;


/*	We have found a  DATA  field.  We must be sure that we don't look for our test string
   *	inside of quotes.  If the data field begins with a quote then we must perform some
   *	special processing.  If the test string is a quote then we have found it and will return.
   *	If it is not then we will look for the right hand quote and skip the whole string.
   *	Note, imbedded quotes will be handled OK.  They just take an extra pass through this
   *	loop.
*/

	     if substr (window, 1, 1) = """"		/* Do we have a quote ? */


	     then do;				/* YES, we must do some special work.  */

		if test_string = """"
		then return;

		start = start + 1;			/* We want to skip this quote string. */
		size = size - 1;			/* Skip over the left hand quote. */

		len = search (window, """");		/* Get right hand quote. */

		if len = 0			/* No right hand quote is an error. */
		then return;

		start = start + len;		/* Move window past quote string. */
		size = size - len;

		goto end_search_loop;		/* Keep searching. */

	     end;


/*	We have a data field that is not inside quotes.  Find out its length.  We will look
   *	for the next skip character.  Note, a "/" is not a valid character in any
   *	data field except a comment field.  Thus if we find a "/" we will assume
   *	that it is the start of a comment field and thus the end of the non skip
   *	field.  The  "...." field below contains a  ( NL character, a TAB,
   *	a BLANK, and a "/" ).
*/

	     len = search (window, "
	 /");

/*	If no SKIP character was found then we must test the rest of the window.
   *	Otherwise test just the  NON SKIP character field.
*/

	     if len = 0

	     then len = size;

	     else len = len - 1;


/*	Make sure the NON SKIP field is at least as long as the test string we
   *	are looking for.  If it is we will begin searching down the string for
   *	our test string.
*/

	     if len ^< field_len


	     then do i = 1 to (len - field_len + 1);

		if substr (window, i, field_len) = test_string

/*	If we find the test string then we will set the beginning of the
   *	window to the beginning of the test string in the NON SKIP field.
*/

		then do;
		     start = start + i - 1;
		     size = size - i + 1;
		     return;
		end;

	     end;					/* END of the search loop.  */


/*	The test_string was not within this string.  So lets move the window
   *	to after this string and search for the next non skip string. */

	     start = start + len;
	     size = size - len;

end_search_loop:
	end;					/* End of the major do loop. */


	return;
						/*  */
skip:	entry (script_ptr, start, size);


/*	This entry is called from  other ET procedures.   However, the same function
   *	must be performed for the  et_util$get_next  entry.  Thus this entry is
   *	simply a call to an internal procedure which does the real work.
*/

	call skip_proc;

	return;					/* End of the  skip  entry.  */



skip_proc: procedure;


/*	This internal procedure will search the window for the first character
   *	that is not a skip character.  The skip characters are:
   *
   *	1.  Blanks.
   *
   *	2.  Tabs.
   *
   *	3.  New line characters.
   *
   *	4.  Any comment fields which  begin with a  "/*"
   *	    and  end with a  "*/".
*/




/*	Look for a character that is not a blank, tab, or new_line. */


	     do while (start > -1);			/* Loop on a condition that will
						   *  always be true.  */
		workx = verify (window, "
	 ");

/*	If workx = 0 then all the characters in the current window are skip
   *	characters. */

		if workx = 0 then return;

/*	We know that there is a non skip character at start + workx. */

		start = start + workx - 1;		/* Move window to 1st non skip */
		size = size - workx + 1;		/* character. */

/*	Now we will test for a comment field.  If we don't find one then we
   *	have found a valid non skip field. */

		if substr (window, 1, 2) ^= "/*" then return;

/*	We found the beginning of a comment.  Search for the end of the
   *	comment */

		workx = index (window, "*/");

/*	If the end of the comment field can not be found then type a warning
   *	message to the user and move the window  to just before the last
   *	character in the window. */

		if workx = 0
		then do;
		     call ioa_ ("WARNING: The end of a comment was not found. ");
		     call ioa_ ("Comment is: ^a", window);
		     start = start + size - 1;
		     size = 1;
		     return;
		end;

/*	If found then move the window to after the "*/". */

		start = start + workx + 1;		/* Note, workx indicates "*" */
		size = size - workx - 1;

/*	Now we will keep skipping.  To do this we must go back to the
   *	beginning of the loop.
*/

	     end;					/* End of the  do loop.  */



	end skip_proc;
						/* 	*/
char_rel:	entry (ptr_data, rel);


/*	This entry will adjust the pointer passed in ptr_data the number of characters
   *	specified in  rel.
*/



	ptr_ptr = addr (ptr_data);

	bit_count = rel * 9 + fixed (ptr_ptr -> its.bit_offset, 6);

	if bit_count ^< 0

	then do;
	     word_count = divide (bit_count, 36, 17, 0);
	     addr (ptr_ptr -> its.offset) -> based_offset =
		fixed (ptr_ptr -> its.offset, 17) + word_count;
	     addr (ptr_ptr -> its.bit_offset) -> based_bit_offset =
		(bit_count - word_count*36);
	end;

	else do;
	     bit_count = -bit_count - 1;
	     word_count = divide (bit_count, 36, 17, 0);
	     addr (ptr_ptr -> its.offset) -> based_offset =
		fixed (ptr_ptr -> its.offset, 17) -1 -word_count;
	     addr (ptr_ptr -> its.bit_offset) -> based_bit_offset =
		36 - ((bit_count + 1) - (word_count * 36));
	end;

	return;
						/*  */
convert_decimal: entry (script_ptr, start, size, dec_num, code);



/*	This entry will convert a character string number starting in the
   *	first position of the window to a decimal number which will be
   *	returned in the fixed bin(17) variable:  "dec_num".
*/



/*	Check for an explicit sign before the decimal number.  */

	sign = 1;					/* Assume a positive number.  */

	if substr (window, 1, 1) = "+"
	then goto skip_sign;

	if substr (window, 1, 1) = "-"
	then do;
	     sign = -1;

skip_sign:

	     start = start + 1;			/* Move window past sign. */
	     size = size - 1;

	end;


/*	Find the first character in the string that is not a decimal digit.
   *	It is an error if there is not at least one such decimal digit.
   *	This also tells us the length of the decimal number string.
*/

	field_len = verify (window, "0123456789");

	if field_len = 1
	then do;
	     code = 701;
	     call com_err_ (0, "ET", "^d Decimal conversion failed - ^a",
		code, substr (window, 1, 1));
	     return;
	end;

	if field_len ^= 0

	then field_len = field_len - 1;
	else field_len = size ;

/*	Use the character - decimal conversion feature. */

	dec_num = sign * fixed (substr (window, 1, field_len), 17);

/*	Move the window to after the number character string. */

	start = start + field_len;
	size = size - field_len;


	return;					/* The end of the convert decimal entry.  */



     end et_util;



		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved
