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