


		    check_cpu_speed.pl1             08/18/87  1527.7rew 08/18/87  1500.0       63234


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


/****^  HISTORY COMMENTS:
  1) change(87-05-18,Lippard), approve(87-02-09,MCR7616),
     audit(87-06-03,Farley), install(87-08-06,MR12.1-1064):
     Modified to use hcs_$set_procs_required instead of
     phcs_$set_procs_required.
  2) change(87-08-13,Lippard), approve(87-02-09,PBF7616),
     audit(87-08-13,Farley), install(87-08-18,MR12.1-1090):
     Modified to use hcs_$get_procs_required instead of ring_zero_peek_.
                                                   END HISTORY COMMENTS */


/* format: ^inddcls,ind4,ifthenstmt,ifthendo,thendo,ifthen,tree,^case */

check_cpu_speed: proc;

/*
   Program to test the speed of a CPU and determine whether cache and
   associative memory are on.
   R. E. Mullen
*/

/*
    Modified 83 June 6 by Art Beattie: changed to look at all of the
      configuration deck for CPU cards.
    Modified 83 July by Art Beattie: made the following changes;
      1) If no arguments were supplied, it should use only the users subset of
         CPUs that are currently online.
      2) If arguments are supplied (CPUs tags), it should run on them and only
         them.
      3) In either of the above two cases, the user is left running on the same
         subset of CPUs that check_cpu_speed found the user running on.
      4) If the user does not have access to phcs_, program will not run.
    Modified 84 May 25 to fix bug where user process wasn't getting default
      set of CPUs restored properly.
*/

        call cu_$af_return_arg (n_args, arg_ptr, arg_len, code);
        if code = 0 then do;
	      call active_fnc_err_ (error_table_$active_function, my_name);
	      return;
	  end;

/* Determine desired set of CPUs to test. */

        test_cpu_string = "0"b;
        do argno = 1 to n_args;
	  call cu_$arg_ptr (argno, arg_ptr, arg_len, code);
	  if arg = "-bf" | arg = "-brief" then brief_mode = "1"b;
	  else if arg = "-warn" then loud_mode = "1"b;
	       else do;

		     if verify (arg, CPU_TAGS) ^= 0 then do;
			   call com_err_ (0, my_name, "invalid cpu in argument: ^a", arg);
			   return;
		         end;

		     do i = 1 to arg_len;
		         substr (test_cpu_string, mod (index (CPU_TAGS, substr (arg, i, 1)) - 1, 8) + 1, 1) = "1"b;
		     end;

		 end;
        end;					/* ends argno do loop */

        if loud_mode then do;
	   call check_gate_access_ ("phcs_", codeptr (check_cpu_speed), code);
	   if code ^= 0 then do;
	        call com_err_ (code, my_name, "Cannot use -warn without access to phcs_.");
	        return;
	        end;
	   end;

/* Determine user's current set of CPUs. */

        call hcs_$get_procs_required (initial_cpu_string, default_procs_flag, code);

        if code ^= 0 then do;
	   call com_err_ (code, my_name, "set_proc_required.acs");
	   return;
	 end;

        if test_cpu_string = "0"b then do;
	      test_cpu_string = initial_cpu_string;
	      requested_procs_flag = "0"b;
	  end;

        on cleanup call hcs_$set_procs_required (initial_cpu_string, code);

        do cpu_num = 1 to 8;
	  if substr (test_cpu_string, cpu_num, 1) then do;
		current_cpu_string = copy ("0"b, cpu_num - 1) || "1"b;
		call hcs_$set_procs_required (current_cpu_string, code);
		if code = error_table_$insufficient_access then do;
		     call com_err_ (code, my_name, "While doing set_proc_required.");
		     return;
		end;
		else if code ^= 0 then
		     if requested_procs_flag
		     then call ioa_ ("CPU ^a is not online.", substr ("ABCDEFGH", cpu_num, 1));
		     else ;
		else call do_one_cpu (substr ("ABCDEFGH", cpu_num, 1));
	      end;
        end;
						/* this will force system default flag back on */
        if default_procs_flag then initial_cpu_string = "0"b;

        call hcs_$set_procs_required (initial_cpu_string, code);
        return;

do_one_cpu: proc (cpu_tag);

dcl     cpu_tag		 char (1);

        t3 = 1000000;				/* init to large value */
        do k = 1 to 10;
	  t1 = vclock ();
	  do i = 1 to 100;
	      do j = 1 to 120;
	      end;
	  end;
	  t2 = vclock ();
	  if t2 - t1 < t3 then t3 = t2 - t1;
        end;

        if t3 > 150000 then thing = "associative memory";
        else thing = "cache";

        if t3 > 80000 then onf = "OFF";
        else onf = "ON ";

        if onf = "ON " & brief_mode then return;

        t4 = float (t3) / 1e3;
        call ioa_ ("CPU ^a ^a: ^3a ^8.3f", cpu_tag, thing, onf, t4);

        if onf = "OFF" & loud_mode then
	   call phcs_$ring_0_message ("cpu " || cpu_tag || " " || thing || " off");
        return;

    end do_one_cpu;
%page;

dcl     CPU_TAGS		 char (16) init ("ABCDEFGHabcdefgh") int static options (constant);
dcl     active_fnc_err_	 entry options (variable);
dcl     arg		 char (arg_len) based (arg_ptr);
dcl     arg_len		 fixed bin (21);
dcl     arg_ptr		 ptr;
dcl     argno		 fixed bin;
dcl     brief_mode		 bit (1) init ("0"b);
dcl     check_gate_access_	 entry (char(*), ptr, fixed bin(35));
dcl     cleanup		 condition;
dcl     code		 fixed bin (35);
dcl     codeptr		 builtin;
dcl     com_err_		 entry options (variable);
dcl     copy		 builtin;
dcl     cpu_num		 fixed bin;
dcl     cu_$af_return_arg	 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl     (current_cpu_string, initial_cpu_string, test_cpu_string) bit (8) aligned;
dcl     default_procs_flag	 bit (1) aligned init ("0"b);
dcl     error_table_$active_function fixed bin (35) ext static;
dcl     error_table_$insufficient_access fixed bin (35) ext static;
dcl     (i, j, k)		 fixed bin;
dcl     float		 builtin;
dcl     hcs_$get_procs_required entry (bit (8) aligned, bit (1) aligned, fixed bin (35));
dcl     hcs_$set_procs_required entry (bit (8) aligned, fixed bin (35));
dcl     index		 builtin;
dcl     ioa_		 entry options (variable);
dcl     loud_mode		 bit (1) init ("0"b);
dcl     mod		 builtin;
dcl     my_name		 char (15) init ("check_cpu_speed") int static options (constant);
dcl     n_args		 fixed bin;
dcl     onf		 char (3);
dcl     phcs_$ring_0_message   entry (char (*));
dcl     requested_procs_flag	 bit (1) init ("1"b);	/* procs supplied to command */
dcl     substr		 builtin;
dcl     (t1, t2)		 fixed bin (71);
dcl     t3		 fixed bin (35);
dcl     t4		 float bin;
dcl     thing		 char (24);
dcl     vclock		 builtin;
dcl     verify		 builtin;
    end check_cpu_speed;
  



		    flush.pl1                       11/15/82  1905.9rew 11/15/82  1526.2       73611


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


flush:	proc;
	
/* Program to flush the contents of main memory by touching a
   sufficient number of pages in temporary segments created for
   this purpose.  The number of pages to flush is determined
   from sst$nused (it defaults to 1024 is the user does not
   have sufficient access to examine sst$nused).  The temporary
   segments are named flush.<sequential number>, and they are
   created either in thr process directory (the default) or in
   a directory supplied by the user via the -temp_dir control
   argument.  In order for all pages of main memory to be flushed,
   the directory used must have sufficient quota (the aggregate
   quota used by the temporary segments is the value of sst$nused).
   There is a mildly interesting hack to prevent a fatal process
   error if the temporary directory is the process directory and
   there is not enough quota to flush all of main memory.  
   Prior to the flush, the next page of the stack is written to,
   ensuring that there's enough stack to do the minimal condition
   handling if a reqord quota overflow occurs.

   Completely rewritten by J. Bongiovanni in June 1981						*/
	

/* Automatic */

	dcl arg_no fixed bin;			/* current argument number			*/
	dcl argl fixed bin (21);			/* length of current argument			*/
	dcl argp ptr;				/* pointer to current argument		*/
	dcl code fixed bin (35);			/* standard error code			*/
	dcl dir_name char (168);			/* name of directory for temp segments		*/
	dcl flush_seg_no pic "zzzz9";			/* for constructing temp segment names		*/
	dcl garbage fixed bin (35);			/* just what it says			*/
	dcl n_args fixed bin;			/* number of arguments			*/
	dcl n_flush_segs fixed bin;			/* number of temporary segs			*/
	dcl n_pages fixed bin;			/* number of pages in memory to flush		*/
	dcl n_pages_flushed fixed bin;		/* count of pages flushed			*/
	dcl n_pages_left fixed bin;			/* used in creating temp segs			*/
	dcl other_error bit (1);			/* ON => seg_fault_error occurred during flush	*/
	dcl pages_per_seg fixed bin;			/* number of pages per segment		*/
	dcl pagex fixed bin;			/* index to array of pages			*/
	dcl quota_overflow bit (1);			/* ON => RQO occurred during flush		*/
	dcl segx fixed bin;				/* index into control structure		*/
	dcl tempp ptr;				/* pointer to temp seg			*/
	
/* Static */

	dcl DEFAULT_PAGES_TO_FLUSH fixed bin int static options (constant) init (1024);
	dcl MYNAME char (5) int static options (constant) init ("flush");
	dcl TEMP_SEG_PREFIX char (6) int static options (constant) init ("flush.");
	
/* Based */

	dcl arg char (argl) based (argp);		/* current argument				*/
	dcl 1 flush_segs aligned based (tempp),		/* control structure			*/
	2 n_segs fixed bin,				/* number of temp segs 			*/
	2 segs (0 refer (n_segs)),
	3 segp ptr,				/* pointer to segment			*/
	3 seg_pages fixed bin;			/* number of pages to touch in this seg		*/
	dcl 1 segment aligned based,			/* used for touching pages during flush		*/
	2 page (256),
	3 word (1024) fixed bin (35);
	
/* Entry */

	dcl absolute_pathname_ entry (char(*), char(*), fixed bin(35));
	dcl com_err_ entry options (variable);
	dcl cu_$arg_count entry (fixed bin, fixed bin(35));
	dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
	dcl get_pdir_ entry() returns(char(168));
	dcl get_temp_segment_ entry (char(*), ptr, fixed bin(35));
	dcl hcs_$delentry_seg entry (ptr, fixed bin(35));
	dcl hcs_$make_seg entry (char(*), char(*), char(*), fixed bin(5), ptr, fixed bin(35));
	dcl ioa_$ioa_switch entry options (variable);
	dcl release_temp_segment_ entry (char(*), ptr, fixed bin(35));
	dcl ring_zero_peek_$by_definition entry (char(*), char(*), fixed bin(18), ptr, fixed bin(19), fixed bin(35));
	
/* External */

	dcl error_table_$badopt fixed bin (35) external;
	dcl iox_$error_output ptr external;
	dcl sys_info$max_seg_size fixed bin (19) external;
	dcl sys_info$page_size fixed bin external;

/* Condition */

	dcl cleanup condition;
	dcl record_quota_overflow condition;
	dcl seg_fault_error condition;

/* Builtin */

	dcl addr builtin;
	dcl ltrim builtin;
	dcl null builtin;
	dcl stackframeptr builtin;
	%page;
	
/* Pick up arguments and validate								*/
	
	dir_name = get_pdir_ ();			/* default temp dir = [pd]			*/

	call cu_$arg_count (n_args, code);
	if code ^= 0 then do;			/* active function not allowed		*/
	     call com_err_ (code, MYNAME);
	     return;
	end;
	
	do arg_no = 1 to n_args;
	     call cu_$arg_ptr (arg_no, argp, argl, code);
	     if arg = "-temp_dir" | arg = "-td" then do;
		arg_no = arg_no + 1;
		call cu_$arg_ptr (arg_no, argp, argl, code);
		if code^= 0 then do;
		     call com_err_ (code, MYNAME, "Temp directory name");
		     return;
		end;
		call absolute_pathname_ (arg, dir_name, code);
		if code ^= 0 then do;
		     call com_err_ (code, MYNAME, arg);
		     return;
		end;
	     end;
	     else do;
		call com_err_ (error_table_$badopt, MYNAME, arg);
		return;
	     end;
	end;
	%page;
	
/* Get a temp segment for the control structure.  Find out how many pages
   we should flush, and create the temporary segments needed in the
   appropriate directory									*/
	
	tempp = null ();
	on cleanup call clean_out;
	
	call get_temp_segment_ (MYNAME, tempp, code);
	if code ^= 0 then do;
	     call com_err_ (code, MYNAME, "Getting temp segment");
	     call clean_out;
	     return;
	end;
	
	call ring_zero_peek_$by_definition ("sst", "nused", 0, addr (n_pages), 1, code);
	if code ^= 0 then
	     n_pages = DEFAULT_PAGES_TO_FLUSH;
	
	pages_per_seg = divide (sys_info$max_seg_size, sys_info$page_size, 17);
	n_flush_segs = divide (n_pages, pages_per_seg, 17);
	n_pages_left = n_pages;
	do segx = 1 to n_flush_segs;
	     flush_seg_no = segx;
	     call hcs_$make_seg (dir_name, TEMP_SEG_PREFIX || ltrim (flush_seg_no), "",
		01010b, flush_segs.segs (segx).segp, code);
	     if flush_segs.segs (segx).segp = null () then do;
		call com_err_ (code, MYNAME, "Creating ^[>^1s^;^a>^]^a",
		     (dir_name = ">"), dir_name, TEMP_SEG_PREFIX || ltrim (flush_seg_no));
		call clean_out;
		return;
	     end;
	     flush_segs.segs (segx).seg_pages = min (pages_per_seg, n_pages_left);
	     flush_segs.n_segs = segx;
	     n_pages_left = n_pages_left - flush_segs.segs (segx).seg_pages;
	end;
	%page;
	
/* Do the flush, after making sure there's enough stack to handle a
   record_quota_overflow condition								*/
	
	stackframeptr () -> segment.page (2).word (1) = 1;
	quota_overflow = "0"b;
	other_error = "0"b;

	on record_quota_overflow begin;
	     quota_overflow = "1"b;
	     goto END_FLUSH;
	end;
	
	on seg_fault_error begin;			/* most likely out of room on LV */
	     other_error = "1"b;
	     goto END_FLUSH;
	end;

	n_pages_flushed = 0;
	
	do segx = 1 to n_flush_segs;
	     do pagex = 1 to flush_segs.segs (segx).seg_pages;
		garbage = flush_segs.segs (segx).segp -> segment.page (pagex).word (1);
		n_pages_flushed = n_pages_flushed + 1;
	     end;
	end;
	
END_FLUSH:
	revert record_quota_overflow;
	call clean_out;

	if quota_overflow then 
	     call ioa_$ioa_switch (iox_$error_output, 
	     "Insufficient quota for full flush - flushed ^d out of ^d pages",
	     n_pages_flushed, n_pages);

	if other_error then
	     call ioa_$ioa_switch (iox_$error_output,
	     "Error during flush - flushed ^d out of ^d pages",
	     n_pages_flushed, n_pages);

	return;
	%page;
	
/* Internal procedure to clean up after ourselves							*/
	
clean_out:
	proc;
	
	if tempp ^= null () then do;
	     do segx = 1 to flush_segs.n_segs;
		call hcs_$delentry_seg (flush_segs.segs (segx).segp, code);
	     end;
	     call release_temp_segment_ (MYNAME, tempp, code);
	     tempp = null ();
	end;
	
end clean_out;


end flush;
 



		    instr_speed.pl1                 12/01/87  0811.2rew 11/30/87  1323.6       56214


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


/****^  HISTORY COMMENTS:
  1) change(87-10-08,Martinson), approve(87-10-08,MCR7765),
     audit(87-11-20,Fawcett), install(87-11-30,MR12.2-1006):
     Modified to use cu_$arg_(count ptr) when processing control arguments.
                                                   END HISTORY COMMENTS */


instr_speed: proc;

/* " This program test the instructions speeds of several mixes of instructions.

   */
/* Modified June 81 by J. Bongiovanni to get temp segment for impure code				*/
	   

/*  */

/* DECLARATIONS */

dcl (successes, pf_aborts, nanos, ls_aborts, type, histi, bucketmin, bucketmax, pf, ls, maxs, bucket, count, nargs) fixed bin;
dcl arg_ptr ptr;
dcl arg_len fixed bin (21);
dcl arg char (arg_len) unaligned based (arg_ptr);
dcl long_report bit(1) unaligned;
dcl  time fixed bin (71);
dcl  time_total fixed bin (71);
dcl (mips, mips_total, mip_rate) float bin;
dcl  hist (0:300) fixed bin;
dcl  code fixed bin (35);
dcl error_table_$noarg external fixed bin(35);
dcl  temp_p ptr;
dcl (fixed, float, lbound, hbound, max, min, null, divide) builtin;
dcl  cu_$arg_count ext entry (fixed bin, fixed bin(35));
dcl  cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin(21), fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  com_err_ entry options (variable);
dcl  date_time_ entry (fixed bin (71), char (*) aligned);
dcl  clock_ entry (fixed bin (71));
dcl  char_time char (24) aligned;
dcl  test_speed entry (fixed bin, fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, ptr);
dcl  (get_temp_segment_, release_temp_segment_) entry (char (*), ptr, fixed bin (35));
dcl  name (15) char (32) aligned static init (
     "lda/sta - even/odd",
     "lda/sta - odd/even",
     "lda/lda/lda...",
     "lda/sta - even/odd bit29",
     "eppbp/spribp - even/odd",
     "eppbp/spribp - odd/even",
     "eppbp/spribp - even/odd indirect",
     "eppbp/spribp - odd/even indirect",
     "eppbp/spribp - even/odd bit29",
     "eppbp/spribp - even/odd bit29ind",
     "eppbp/spribp - odd/even bit29ind",
     "random mix",
     "lda 0,du...",
     "nop 0,du...",
     "lprpbp/sprpbp - even/odd bit29");
dcl  INDEX_FACTOR float bin int static options (constant) init (2e2);
dcl  MAXHIST fixed bin int static options (constant) init (300);
dcl  NUMPASSES fixed bin int static options (constant) init (100);
dcl  MYNAME char (11) int static options (constant) init ("instr_speed");
dcl  cleanup condition;

/*  */

/* Get a temp segment for the impure code in test_speed to run */

	temp_p = null ();
	on cleanup begin;
	     if temp_p ^= null ()
		then call release_temp_segment_ (MYNAME, temp_p, code);
	end;

	call get_temp_segment_ (MYNAME, temp_p, code);
	if code^=0 then do;
	     call com_err_ (code, MYNAME, "Getting temp segment");
	     return;
	end;
/* validate control arguments */
          call cu_$arg_count (nargs, code);
	if code ^= 0 then do;
	     call com_err_ (code, MYNAME);
	     return;
	     end;
          call cu_$arg_ptr (1, arg_ptr, arg_len, code);
	if code = error_table_$noarg then long_report = "0"b;
	else if arg = "-lg" | arg = "-long" then long_report = "1"b;
	else do;
	     call ioa_ ("instr_speed: Valid control arguments -long or -lg");
	     return;
	     end;


/* call print_config; */
	call clock_ (time);
	call date_time_ (time, char_time);
	call ioa_ ("INSTRUCTION SPEED TEST -- ^a^/", char_time);

/* Now run the test for the 15 possible types of sequences */

	do type = lbound (name,1) to hbound (name, 1);
	     successes,
	     pf_aborts,
	     ls_aborts,
	     bucketmax = 0;				/* initial for this case */
	     hist = 0;
	     time_total = 0;
	     mips_total = 0e0;
	     bucketmin = MAXHIST;

	     do while (successes < NUMPASSES);		/* loop until get 100 good runs */
		call test_speed (type, time, ls, maxs, pf, count, temp_p); /* run a test for this type */
		if pf > 0 then pf_aborts = pf_aborts + 1; /* took a page fault, skip this one */
		else if ls > 0 then ls_aborts = ls_aborts + 1; /* took a large sample (probable interrupt) */
		else do;
		     successes = successes + 1;	/* another successful run */
		     time_total = time_total + float (time);
		     mips = float (count) / float (time); /* get mips for this run */
		     bucket = mips * INDEX_FACTOR;		/* get the index into hist for this run */
		     bucket = min (bucket, MAXHIST);	/* watch out for overflow */
		     bucketmax = max (bucketmax, bucket); /* calculate bounds of possible values for this type */
		     bucketmin = min (bucketmin, bucket); /* .. */
		     hist (bucket) = hist (bucket) + 1;	/* fill in histogram */
		     mips_total = mips_total + mips;	/* keep running total for final ave */
		end;
	     end;

/* Now output the data for this type */

	     call ioa_ ("^/* * * * * * * * * * * * * * * * * * * * * *^/");
	     call ioa_ ("^/TEST ^d: (^a)", type, name (type));
	     if long_report then do;
		call ioa_ ("^/ HITS   MIPS^/");	/* output header */
		do histi = bucketmin to bucketmax;	/* loop through buckets that got hit */
		     call ioa_ ("^5d  ^5.3f", hist (histi), histi*5e-3);
		end;
	     end;
	     mip_rate = mips_total/float (successes);	/* calculate mip_rate */
	     nanos = fixed (1e3/mip_rate);		/* calculate the nanoseconds to do one instruction */
	     call ioa_ ("^/MIPS AVE = ^5.3f, TIME AVE = ^d, ^d NANOSECONDS", mip_rate, divide (time_total, successes, 17, 0), nanos);
	     if pf_aborts+ls_aborts > 0 then call ioa_ ("PF = ^d, LS = ^d, CUTOFF = ^d", pf_aborts, ls_aborts, maxs);

	end;
	
	call release_temp_segment_ (MYNAME, temp_p, code);
	temp_p = null();
	

     end;
  



		    meter_signal.pl1                11/15/82  1905.9rew 11/15/82  1526.1       63990


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


/* Originally coded by Paul Karger August 17, 1971 */
/* Updated by Alan Bier - March l974. */
/* Fixed to eliminate ERROR 295, 05/01/81, W. Olin Sibert */

meter_signal: proc;

dcl  cu_$arg_count entry (fixed bin),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin),
     com_err_ entry options (variable),
     clock_ entry returns (fixed bin (71)),
     ioa_ entry options (variable),
     ioa_$nnl entry options (variable),
     ios_$write_ptr entry (ptr, fixed bin, fixed bin),
    (unclaimed_signal, zerodivide) condition,
     condition_ entry (char (*), entry),
     default_error_handler_ entry,
     convert_binary_integer_$decimal_string entry (fixed bin) returns (char (12) varying),
     cv_dec_check_ entry (char (*), fixed bin) returns (fixed bin (35));

dcl  p pointer,
     newline char (1) aligned;
dcl (mod, unspec, divide, addr, min) builtin;
dcl (nargs, code, argl, c, q, k, i) fixed bin,
     nfaults fixed bin init (1),			/* number of faults to take */
     nframes fixed bin init (1),			/* number of frames to create */
     nuncl fixed bin init (0),			/* frame number for the unclaimed_signal handler */
     nhandlers fixed bin init (0),			/* number of dummy handlers to create */
    (diff, j, l) fixed bin (35),
    (time, newtime) fixed bin (71),
     frame_count fixed bin;

dcl  argp ptr,
     arg char (argl) based (argp),
     unclaimed bit (1) aligned init ("0"b);


/*  */

	p = addr (newline); 			/* Used to use init (addr (...)), got ERROR 295 */
	i, j = 0;
	unspec (newline) = "000001010"b;
	l = 11111111111111111111111111111111111b;
	call cu_$arg_count (nargs);			/* get number of arguments */
	if mod (nargs, 2) ^= 0 then
	     do;					/* must be even number of args */
	     call com_err_ (0, "meter_signal", "Odd number of arguments.");
	     return;
	end;
	do k = 1 to nargs by 2;			/* loop through the arguments two by two */
	     call cu_$arg_ptr (k, argp, argl, code);	/* get pointer to arg */
	     if code ^= 0 then
		do;
err1:		
		call com_err_ (code, "meter_signal");
		return;
	     end;
	     if arg = "-nfaults" then
		do;				/* specify number of faults to take */
		call cu_$arg_ptr (k+1, argp, argl, code);
						/* get number */
		if code ^= 0 then go to err1;

		nfaults = cv_dec_check_ (arg, code);	/* convert it */
		if code ^= 0 then
		     do;
err2:		     
		     call com_err_ (0, "meter_signal", arg);
		     return;
		end;
		if nfaults <= 0 then go to err2;	/* must be at least 1 fault */
		go to next;			/* get next arg */
	     end;
	     if arg = "-nframes" then
		do;				/* sepcify how many stack frames to establish */
		call cu_$arg_ptr (k+1, argp, argl, code);
						/* get the number */
		if code ^= 0 then go to err1;

		nframes = cv_dec_check_ (arg, code);	/* convert it */
		if code ^= 0 then go to err2;
		if nframes <= 0 then go to err2;

		go to next;
	     end;
	     if arg = "-unclaimed" then
		do;				/* we want an uncliamed signal handler */
		call cu_$arg_ptr (k+1, argp, argl, code);
						/* get the number of the frame to put it in */
		if code ^= 0 then go to err1;

		nuncl = cv_dec_check_ (arg, code);	/* convert it */
		if code ^= 0 then go to err2;
		if nuncl <= 0 then go to err2;
		unclaimed = "1"b;
		go to next;
	     end;
	     if arg = "-nhandlers" then
		do;				/* sets the number of dummy handlers */
		call cu_$arg_ptr (k+1, argp, argl, code);
		if code ^= 0 then go to err1;

		nhandlers = cv_dec_check_ (arg, code);
		if code ^= 0 then go to err2;
		if nhandlers <= 0 then go to err2;

		go to next;
	     end;
	     call com_err_ (0, "meter_signal", "Invalid argument.  ^R^a^B", arg);
						/* print error */
	     return;
next:	     
	end;
	call ioa_ ("The following environment will be established:");
	call ioa_ ("^/^d stack frames will be laid down.", nframes);
	if unclaimed then call ioa_ ("An unclaimed signal handler will be in stack frame ^d.", nuncl);
	call ioa_ ("^d dummy interrupt handlers will be established in each frame.", nhandlers);
	call ioa_ ("^d zerodivide faults will be signalled.", nfaults);
	call ioa_ ("^/^/Following are the times in microseconds for each fault:^/^/");
	if ^unclaimed then
	     on zerodivide
	     begin;				/* set up zerodivide handler */
	     newtime = clock_ ();			/* read the clock */
	     diff = newtime - time;			/* get the difference */
	     call ioa_$nnl ("^10d", diff);		/* print it out */
	     j = j + diff;				/* accumulate the sum */
	     l = min (l, diff);			/* get the minimum fault time */
	     i = i + 1;
	     if mod (i, 4) = 0 then call ios_$write_ptr (p, 0, 1); /* put out newline every four */
	     if i >= nfaults then go to all_done;
						/* check fault counter */
	end;					/* return to fault to permit resignalling */
	frame_count = 1;
	if unclaimed then
	     if nuncl = frame_count then
		on condition (unclaimed_signal)
		begin;

	     newtime = clock_ ();
	     diff = newtime - time;
	     call ioa_$nnl ("^10d", diff);
	     j = j + diff;
	     l = min (l, diff);
	     if mod (i, 4) = 0 then call ios_$write_ptr (p, 0, 1);
	     i = i + 1;
	     if i >= nfaults then go to all_done;
	end;
	do c = 1 to nhandlers;			/* set up the dummy handlers */
	     call condition_ ("meter_signal_"|| (convert_binary_integer_$decimal_string (c)),
	     default_error_handler_);
	end;
	if nframes = frame_count then
	     do;					/* is this the last frame? */
div_loop:      
	     time = clock_ ();			/* read the clock */
	     q = divide (1, 0, 17, 0);		/* divide by zero */
	     go to div_loop;			/* loop back - the handler will turn it off at the right time */
	end;
	call frame;

all_done: 
	call ioa_ ("^/^/Minimum value = ^d   Mean = ^d", l, divide (j, nfaults, 35, 0));
	return;
frame:	
	proc;					/* This is the recursive procedure to set up n stack frames */
	     frame_count = frame_count + 1;		/* increment frame counter */
	     if unclaimed then
		if nuncl = frame_count then
		     on condition (unclaimed_signal)
		     begin;

		newtime = clock_ ();
		diff = newtime - time;
		call ioa_$nnl ("^10d", diff);
		j = j + diff;
		l = min (l, diff);
		if mod (i, 4) = 0 then call ios_$write_ptr (p, 0, 1);
		i = i + 1;
		if i >= nfaults then go to all_done;
	     end;
	     do c = 1 to nhandlers;			/* set up the dummy handlers */
		call condition_ ("meter_signal_"|| (convert_binary_integer_$decimal_string (c)),
		default_error_handler_);
	     end;
	     if nframes = frame_count then
		do;				/* is this the last frame */
div_loop: 	
		time = clock_ ();
		q = divide (1, 0, 17, 0);		/* cause fault */
		go to div_loop;
	     end;
	     call frame;				/* recurse to next frame */
	end;
     end;
  



		    print_sample_refs.pl1           11/15/82  1905.9rew 11/15/82  1526.1      267723


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


print_sample_refs: psrf: procedure;

/*	print_sample_refs interprets the data segments produced by the sample_refs command, and produces
   a printable output file.  The data segments, _n_a_m_e.srf1, _n_a_m_e.srf2, and _n_a_m_e.srf3 are initiated, and
   the output file _n_a_m_e.list is made.  Each individual sample, as found in the srf1 segment, is examined.  An
   attempt is made to initiate the segment, then to determine if it is an object segment, and then to determine
   if the segment reference can be resolved down to a bound component of an object segment.  During this phase, a
   table of components is generated, and if the -brief option has not been specified, information about each
   individual sample is written into the output file.  In the next phase, information from the srf1, srf2,
   and component tables is used to produce the segment number - pathname dictionary. In the final phase, the PSR
   and TSR reference histograms are produced.

   0) created by Ross E. Klinger, November 11, 1973
   1) modified by R.E. Klinger, August 15, 1975 to convert
   to new object_info structure
   2) Modified 05/01/81, W. Olin Sibert, to eliminate ERROR 295

   */
	
declare 1 srf1seg based (srf1P) aligned,		/* srf1 data base */
        2 time_on fixed bin (71),			/* on time */
        2 time_off fixed bin (71),			/* off time */
        2 table_index fixed bin (35),			/* index of where_when table */
        2 frequency fixed bin (35),			/* sample rate */
        2 high_hc fixed bin (35),			/* high hardcore segment */
        2 proc_seg_cnt fixed bin (35),			/* high process segment */
        2 where_when (srf1_max_index),			/* interrupt table */
	3 time fixed bin (71),			/* interrupt time */
	3 prcdr pointer,				/* psr pointer */
	3 temporary pointer,			/* tsr pointer */
	3 prul fixed bin (35),			/* psr re-usage level */
	3 trul fixed bin (35);			/* tsr re-usage level */

declare 1 srf2seg based (srf2P) aligned,		/* srf2 data base */
        2 time_on fixed bin (71),			/* on time */
        2 high_segno fixed bin (35),			/* highest segment number in table */
        2 pad fixed bin (35),				/* pad */
        2 segment (srf2_max_index),			/* table indexed by segment number */
	3 pathname character (168),			/* segment pathname */
	3 prc fixed bin (35),			/* psr reference count */
	3 trc fixed bin (35),			/* tsr reference count */
	3 ci fixed bin (35),			/* chain index to extension */
	3 bci fixed bin (35);			/* index to bound components */

declare 1 srf3seg based (srf3P) aligned,		/* extension data base for re-used segment numbers */
        2 time_on fixed bin (71),			/* on time */
        2 ni fixed bin (35),				/* index to next available entry */
        2 pad fixed bin (35),				/* pad area */
        2 extension (srf3_max_index),			/* table of pathnames of re-used segment numbers */
	3 pathname char (168),			/* pathname */
	3 prc fixed bin (35),			/* psr reference count */
	3 trc fixed bin (35),			/* tsr reference count */
	3 ci fixed bin (35),			/* index to further re-usage entries */
	3 bci fixed bin (35);			/* index to bound components */


declare 1 temp based (t1P) aligned,			/* segment to hold ordered lines */
        2 li fixed bin (35),				/* index to next available entry */
        2 pad fixed bin (35),				/* pad area */
        2 line (temp_max_index),			/* lines */
	3 rul fixed bin (35),			/* re-usage level */
	3 sgnum fixed bin (35),			/* segment number */
	3 bindl fixed bin (35),			/* bound component level */
	3 name char (168),				/* segment/component name */
	3 prc fixed bin (35),			/* psr reference count */
	3 trc fixed bin (35),			/* tsr reference count */
	3 pad fixed bin (35);			/* pad area */

declare 1 bindings based (t2P) aligned,			/* segment to hold bound component entries */
        2 bcmpi fixed bin (35),			/* index to next available entry */
        2 pad fixed bin (35),				/* pad area */
        2 bcmp (bindings_max_index),			/* bound components */
	3 name char (32),				/* component name */
	3 prc fixed bin (35),			/* psr reference count */
	3 trc fixed bin (35),			/* tsr reference count */
	3 ci fixed bin (35),			/* chain index to next bound component within a segment */
	3 pad fixed bin (35);			/* pad area */
	
declare (srf1P, srf2P, srf3P, t1P, t2P) ptr,		/* segment pointers */
         output_path character (168) varying,		/* output pathname */
         iocbP ptr,					/* iocb pointer */
         open_sw bit (1),				/* iocb open switch */
         switch_name char (20),			/* I/O switch name */
         unique_name char (15);			/* shreik name used in this invocation */

declare (srf1_max_index, srf2_max_index, srf3_max_index) fixed bin internal static; /* array limits */

declare (aP, bP, cP) pointer,				/* argument pointers */
        (arglen, i, j, k, l) fixed bin,			/* temporary storage */
         reg character (3),				/* holds "TSR" or "PSR" for print_int */
         bl character (3),				/* holds bind component incidence */
         usage character (4),				/* holds re-usage level for output line */
         re_ul fixed bin (35),			/* holds psr or tsr re-usage level */
         pname char (168),				/* holds a pathname for print_int */
         wdir char (168) aligned,			/* pathname of working directory */
         offset fixed bin (35),			/* holds an offset for print_int */
         tbit bit (1),				/* psr(0)/tsr(1) interpet switch */
         long bit (1) initial ("1"b),			/* long format print switch - default is on */
         bindings_full bit (1) initial ("0"b),		/* bindings table full switch */
         code fixed bin (35),				/* error code */
         bc fixed binary (24),			/* segment bit count */
         temp_max_index fixed bin,			/* temp segment maximum index */
         bindings_max_index fixed bin,			/* bindings segment maximum index */
         current_ring fixed bin (6),			/* current ring */
         ring_brackets (3) fixed bin (3),		/* ring brakets of initiated segments */
        (pres, tres) fixed binary (35) initial (1),	/* histogram resolution factors */
         arg character (arglen) based (aP),		/* argument */
         name character (32) aligned,			/* suffixed entry name  */
         dirname character (168) aligned,		/* directory name */
         ename character (32) aligned,			/* entry name */
         rs character (19) varying,			/* psr pointer string for tab evaluation */
         prefix character (22) varying,			/* message prefixed to pathname */
        (ontime, offtime) character (24);		/* time character strings */

declare 1 image based (aP),				/* image of auxilliary or extension entry */
        2 pathname char (168),			/* pathname */
        2 prc fixed bin (35),				/* psr reference count */
        2 trc fixed bin (35),				/* tsr reference count */
        2 ci fixed bin (35),				/* chain index to extension */
        2 bci fixed bin (35);				/* index to bound components */

declare  null builtin, (any_other, cleanup) condition;

declare  sys_info$max_seg_size fixed bin (35) external;	/* maximum segment size */
declare  error_table_$badopt fixed bin (35) external;	/* an error code */

declare  wbar character (100),
         bar (100) character (1) defined (wbar);
	
declare  com_err_ ext entry options (variable),
         component_info_$offset ext entry (ptr, fixed bin, ptr, fixed bin (35)),
         continue_to_signal_ ext entry (fixed bin (35)),
         cu_$arg_count ext entry (fixed bin),
         cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35)),
         date_time_ ext entry (fixed bin (71), char (*)),
         expand_path_ ext entry (ptr, fixed bin, ptr, ptr, fixed bin (35)),
         get_ring_ ext entry returns (fixed bin (6)),
         get_wdir_ ext entry returns (char (168) aligned),
         find_condition_info_ ext entry (ptr, ptr, fixed bin (35)),
         hcs_$delentry_seg ext entry (ptr, fixed bin (35)),
         hcs_$get_ring_brackets ext entry (char (*) aligned, char (*) aligned, (3)fixed bin (3), fixed bin (35)),
         hcs_$initiate_count ext entry (char (*) aligned, char (*) aligned, char (*),
         fixed bin (24), fixed bin (2), ptr, fixed bin (35)),
         hcs_$make_seg ext entry (char (*) aligned, char (*) aligned, char (*), fixed bin (5), ptr, fixed bin (35)),
         hcs_$terminate_noname ext entry (ptr, fixed bin (35)),
         hcs_$truncate_seg ext entry (ptr, fixed bin (24), fixed bin (35)),
         ioa_$ioa_switch ext entry options (variable),
         ioa_$rsnnl ext entry options (variable),
         iox_$attach_ioname ext entry (char (*), ptr, char (*), fixed bin (35)),
         iox_$close ext entry (ptr, fixed bin (35)),
         iox_$detach_iocb ext entry (ptr, fixed bin (35)),
         iox_$open ext entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)),
         object_info_$brief ext entry (ptr, fixed bin (24), ptr, fixed bin (35)),
         suffixed_name_$make ext entry (char (*) aligned, char (*), char (32) aligned, fixed bin (35)),
         unique_chars_ ext entry (bit (*)) returns (char (15));
	
dcl 1 oi aligned automatic like object_info;		/* storage for object_info_ structure */

%include object_info;
	
%include component_info;
	
	oi.version_number = object_info_version_2;	/* set object_info_ structure version */
	srf1_max_index = divide (sys_info$max_seg_size - 8, 8, 17, 0); /* get maximum segment indices */
	srf2_max_index = divide (sys_info$max_seg_size - 4, 46, 17, 0);
	srf3_max_index = srf2_max_index;
	temp_max_index = divide (sys_info$max_seg_size - 2, 48, 17, 0); /* get maximum segment indices */
	bindings_max_index = divide (sys_info$max_seg_size - 2, 13, 17, 0);
	current_ring = get_ring_ ();			/* get current ring number */
	call cu_$arg_ptr (1, aP, arglen, code);		/* get pathname */
	if code ^= 0 then do;			/* is the argument missing? */
	     call com_err_ (code, "print_sample_refs");	/* yes -- write an error message */
	     return;				/* exit */
	end;

	srf1P, srf2P, srf3P, t1P, t2P = null;		/* initialize segment pointers */
	iocbP = null;				/* initialize iocb pointer */
	on cleanup call cleaner;			/* establish cleanup handler to terminate/delete segments */

	bP = addr (dirname);			/* get pointer to directory portion of pathname */
	cP = addr (ename);				/* get pointer to entry name portion of pathname */
	call expand_path_ (aP, arglen, bP, cP, code);	/* expand to an absolute pathname */
	if code ^= 0 then do;			/* was there an error? */
	     call com_err_ (code, "print_sample_refs", "^a", aP -> arg); /* write an error message */
	     return;
	end;

	call cu_$arg_count (i);			/* see if there are more arguments */
	if i > 1 then do;				/* yes */
	     call cu_$arg_ptr (2, aP, arglen, code);	/* get the argument */
	     if aP -> arg ^= "-brief" then if aP -> arg ^= "-bf" then do; /* if not brief, wrong */
		     call com_err_ (error_table_$badopt, "print_sample_refs", "^a", aP -> arg); /* write error message */
		     return;
		end;
		else long = "0"b;			/* set long switch off */
	end;
	i = index (ename, ".srf");			/* look for an ".srf" suffix (or ".srf1", ".srf2", etc. ) */
	if i ^= 0 then substr (ename, i, 32 - i + 1) = " "; /* if found, best just to strip it off */
	
	call suffixed_name_$make (ename, "srf1", name, code); /* add suffix */
	if code ^= 0 then go to suffix_error;		/* was there an error? */
	call hcs_$initiate_count (dirname, name, "", (0), 0, srf1P, code); /* initiate the srf1 segment */
	if srf1P = null then go to init_error;		/* was there an error? */

	call suffixed_name_$make (ename, "srf2", name, code); /* add suffix */
	if code ^= 0 then go to suffix_error;		/* was there an error? */
	call hcs_$initiate_count (dirname, name, "", (0), 0, srf2P, code); /* initiate the srf2 segment */
	if srf2P = null then go to init_error;		/* was there an error? */

	call suffixed_name_$make (ename, "srf3", name, code); /* add suffix */
	if code ^= 0 then go to suffix_error;		/* was there an error? */
	call hcs_$initiate_count (dirname, name, "", (0), 0, srf3P, code); /* initiate the srf3 segment */
	if srf3P = null then go to init_error;		/* was there an error? */

	unique_name = unique_chars_ ("0"b);		/* get a shreik name */
	call hcs_$make_seg ("", unique_name || ".temp1.psrf", "", 01011b, t1P, code);
	if t1P = null then go to temp_error;		/* was there an error? */
	call hcs_$make_seg ("", unique_name || ".temp2.psrf", "", 01011b, t2P, code); /* make the bindings segment */
	if t2P = null then go to temp_error;		/* was there an error? */

	li = 1;					/* initialize the index of temp segment */
	bcmpi = 1;				/* initialize the bindings index */

	call suffixed_name_$make (ename, "list", name, code); /* add suffix */
	if code ^= 0 then go to suffix_error;
	wdir = get_wdir_ ();			/* get working directory name */
	j = index (wdir, " ");			/* find end of working directory name */
	output_path = substr (wdir, 1, j - 1) || ">" || name; /* form list segment absolute pathname */

	switch_name = unique_name || ".psrf";		/* make an unique I/O switch name */
	call iox_$attach_ioname (switch_name, iocbP, "vfile_ " || output_path, code); /* attach the switch */
	if code ^= 0 then go to switch_error;
	call iox_$open (iocbP, 2, "0"b, code);		/* open switch for stream_output */
	if code ^= 0 then go to switch_error;
	else open_sw = "1"b;
	
	call ioa_$ioa_switch (iocbP, "^|^5-PRINT_SAMPLE_REFS"); /* write report header */
	call date_time_ (srf1seg.time_on, ontime);	/* convert on time to characters */
	call date_time_ (srf1seg.time_off, offtime);	/* convert off time to characters */
	call ioa_$ioa_switch (iocbP, "^3/ON TIME: ^a^/OFF TIME: ^a^/SAMPLE RATE: ^d msec.^/NUMBER OF SAMPLES: ^d^2/",
	     ontime, offtime, frequency, table_index);	/* write initial data */


	do i = 1 to table_index;			/* loop to output each interrupt */

	     tbit = "0"b;				/* set tbit to psr interpet */
	     bP = where_when (i).prcdr;		/* set pointer to psr */
	     re_ul = where_when (i).prul;		/* set re-usage level to psr */
	     reg = "PSR";				/* set to psr */
start1:	     j = fixed (baseno (bP));			/* get segment number */

	     if j <= high_hc then do;			/* is the segment in the hardcore? */
		segment (j).bci = -1;		/* don't investigate binding */
set_up1:		pname = segment (j).pathname;		/* yes -- name to be printed is the pathname */
set_up2:		offset = fixed (rel (bP));		/* offset to be printed is the interrupt offset */
		go to print_int;			/* output a line */
	     end;

	     if re_ul = 0 then do;			/* is this a primary usage of the segment number? */
		if segment (j).bci = -1 then go to set_up1; /* primary -- is the segment bound? */
		aP = addr (segment (j).pathname);	/* might be bound -- investigate */
		call check_binding;			/* determine if bound */
		go to print_int;			/* output a line */
	     end;

	     k = segment (j).ci;			/* not primary -- set k to first re-usage */
	     do l = 1 to re_ul - 1;			/* locate re-usage level corresponding to interrupt */
		k = extension (k).ci;		/* set k to next re-usage */
	     end;

	     if extension (k).bci = -1 then do;		/* is the segment not bound? */
		pname = extension (k).pathname;	/* not bound -- set pathname to be printed */
		go to set_up2;			/* go to calculate offset */
	     end;
	     aP = addr (extension (k).pathname);	/* might be bound -- investigate */
	     call check_binding;			/* determine if bound */
print_int:     if re_ul = 0 then usage = "";		/* print only a non-zero usage */
	     else call ioa_$rsnnl ("(^d)", usage, j, re_ul);
	     if long then do;			/* output detailed trace if long switch on */
		call ioa_$ioa_switch (iocbP, "^4d  ^a  ^4a  ^p^-^a|^o", i, reg, usage, bP, pname, offset);
		if tbit then call ioa_$ioa_switch (iocbP, "^/"); /* skip a line after tsr print */
	     end;
	     if tbit then go to end1;			/* have both psr and tsr been interpeted? */
	     tbit = "1"b;				/* no -- set to interpet tsr */
	     bP = where_when (i).temporary;		/* set pointer to tsr */
	     re_ul = where_when (i).trul;		/* set re-usage level to tsr re-usage */
	     reg = "TSR";				/* set to tsr */
	     go to start1;				/* go to interpet */
end1:	end;
	
	do i = 1 to high_segno;			/* loop to order our output lines */
	     if segment (i).pathname < " " then go to end2; /* no entry -- check the next */

	     j = 0;				/* re-usage level is 0 */
	     l = 0;				/* bind level is zero */
	     aP = addr (segment (i).pathname);		/* set pointer to the auxilliary entry */
cycle:	     line (li).rul = j;			/* store the re-usage level */
	     line (li).sgnum = i;			/* store the segment number */
	     line (li).bindl = 0;			/* this is not a bound component */
	     line (li).name = image.pathname;		/* store the pathname */
	     if image.bci <= 0 then do;		/* is this segment bound? */
		line (li).prc = image.prc;		/* not bound -- store the psr reference count */
		line (li).trc = image.trc;		/* store the tsr reference count */
		line (li).bindl = -1;		/* set field to indicate not bound */
		go to check_ru;			/* find out if the segment number is re-used */
	     end;

	     k = image.bci;				/* segment is bound -- set index to the first component */
	     do l = 1 by 1;				/* loop to pick up the bound components */
		if li = temp_max_index then do;	/* is the temp segment full? */
temp_full:	     call com_err_ (0, "print_sample_refs", "The segment number to pathname dictionary is full.
Entries following component ^d of segment ^d at re-usage level ^d are missing.", l, i, j);
		     go to output_dictionary;		/* output the partial dictionary */
		end;
		li = li + 1 ;			/* increment index to next line */
		line (li).sgnum = i;		/* store segment number */
		line (li).bindl = l;		/* store bound component incidence */
		line (li).rul = j;			/* store re-usage level */
		line (li).name = bcmp (k).name;	/* store component name */
		line (li).prc = bcmp (k).prc;		/* store psr reference count */
		line (li).trc = bcmp (k).trc;		/* store tsr reference count */
		if bcmp (k).ci = 0 then go to check_ru; /* if no more components, check for re-used segment number */
		k = bcmp (k).ci;			/* more -- set index to the next component */
	     end;

check_ru:	     if image.ci = 0 then do;			/* is the segment number re-used? */
		if li = temp_max_index then go to temp_full; /* check if temp segment is full */
		li = li + 1;			/* no -- increment the line index */
		go to end2;			/* go to check the next auxilliary entry */
	     end;
	     j = j + 1;				/* the segment is re-used -- increment the re-usage level */
	     k = image.ci;				/* get the index of the extension entry */
	     aP = addr (extension (k).pathname);	/* set the image pointer to the extension entry */
	     if li = temp_max_index then go to temp_full; /* check if temp segment is full */
	     li = li+1;				/* increment the line index */
	     go to cycle;				/* go to set up a line, check binding, etc */
end2:	end;
	
output_dictionary: call ioa_$ioa_switch (iocbP, "^|^5xSEGMENT^-PATHNAME^/");
	do i = 1 to li - 1;				/* loop to output the segment/pathname dictionary */

	     if line (i).bindl = 0 then go to pre_write;	/* ignore references on a bound segment line */
	     if line (i).prc > pres then pres = line (i).prc; /* get highest number of psr references */
	     if line (i).trc > tres then tres = line (i).trc; /* get highest number of tsr references */
	     if line (i).bindl = -1 then do;		/* is this not a bound component? */
pre_write:	bl = "";				/* not a bound component -- set bind incidence for write */
		if line (i).rul = 0 then usage = "";	/* set re-usage for write -- blank if primary...or... */
		else call ioa_$rsnnl ("(^d)", usage, j, line (i).rul); /* outputted if not */
		go to write;
	     end;
	     call ioa_$rsnnl (".^d", bl, j, line (i).bindl); /* bound component - form the bind suffix */
write:	     call ioa_$ioa_switch (iocbP, "^4a ^4o^3a^-^a", usage, line (i).sgnum, bl, line (i).name);
	end;

	call ioa_$ioa_switch (iocbP, "^|^5-PSR REFERENCE HISTOGRAM");
	if pres <= 100 then pres = 1;			/* set pres factor */
	else if pres <= 200 then pres = 2;
	else if pres <= 500 then pres = 5;
	else if pres <= 1000 then pres = 10;
	else if pres <= 2000 then pres = 20;
	else if pres <= 5000 then pres = 50;
	else pres = 100;
	call ioa_$ioa_switch (iocbP, "^5-(Resolution factor = ^d)", pres);
	call ioa_$ioa_switch (iocbP, "^2/^-SEGMENT^/");

	do i = 1 to li - 1;				/* loop to output bars */
	     if line (i).bindl = 0 then go to again;	/* skip a bound segment line */
	     if line (i).prc = 0 then go to again;	/* if no references, check the next entry */
	     if line (i).rul = 0 then usage = "";	/* print only a re-usage > 0 */
	     else call ioa_$rsnnl ("(^d)", usage, j, line (i).rul);
	     if line (i).bindl = -1 then bl = "";	/* print only a bound component or unbound segment bl */
	     else call ioa_$rsnnl (".^d", bl, j, line (i).bindl);
	     bar = " ";				/* set the bar to all blanks */
	     do j = 1 to 100 while (line (i).prc>0);	/* extend the bar as long as references remain */
		bar (j) = "x";
		line (i).prc = line (i).prc - pres;	/* decrement the count by the resolution factor */
	     end;
	     call ioa_$ioa_switch (iocbP, "^4a ^4o^3a^-^a", usage, line (i).sgnum, bl, wbar); /* write a line */
again:	end;
	
	call ioa_$ioa_switch (iocbP, "^|^5-TSR REFERENCE HISTOGRAM");
	if tres <= 100 then tres = 1;			/* set tres factor */
	else if tres <= 200 then tres = 2;
	else if tres <= 500 then tres = 5;
	else if tres <= 1000 then tres = 10;
	else if tres <= 2000 then tres = 20;
	else if tres <= 5000 then tres = 50;
	else tres = 100;
	call ioa_$ioa_switch (iocbP, "^5-(Resolution factor = ^d)", tres);
	call ioa_$ioa_switch (iocbP, "^2/^-SEGMENT^/");

	do i = 1 to li - 1;				/* loop to output bars */
	     if line (i).bindl = 0 then go to again1;	/* skip a bound segment line */
	     if line (i).trc = 0 then go to again1;	/* if no references, check the next entry */
	     if line (i).rul = 0 then usage = "";	/* print only a re-usage > 0 */
	     else call ioa_$rsnnl ("(^d)", usage, j, line (i).rul);
	     if line (i).bindl = -1 then bl = "";	/* print only a bound component or unbound segment bl */
	     else call ioa_$rsnnl (".^d", bl, j, line (i).bindl);
	     bar = " ";				/* set the bar to all blanks */
	     do j = 1 to 100 while (line (i).trc>0);	/* extend the bar as long as references remain */
		bar (j) = "x";
		line (i).trc = line (i).trc - tres;	/* decrement the count by the resolution factor */
	     end;
	     call ioa_$ioa_switch (iocbP, "^4a ^4o^3a^-^a", usage, line (i).sgnum, bl, wbar); /* write a line */
again1:	end;

	call cleaner;				/* tidy up segments; detach io stream; restore srf segments */
	revert cleanup;				/* disable condition handler */
	return;					/* exit */
	
cleaner:	procedure;				/* cleanup procedure */
	     if iocbP ^= null then do;		/* I/O switch attached? */
		if open_sw then do;			/* I/O switch open? */
		     call iox_$close (iocbP, 0);	/* close it */
		     open_sw = "0"b;		/* and indicate same */
		end;
		call iox_$detach_iocb (iocbP, 0);	/* detach it */
		iocbP = null;			/* indicate same */
	     end;
	     if srf1P ^= null then do;
		call hcs_$terminate_noname (srf1P, 0);
		srf1P = null;
	     end;
	     if srf2P ^= null then do;
		do i = 1 to high_segno;		/* loop to restore srf2 segment to virgin state */
		     segment (i).bci = 0;		/* zero auxilliary bound component indices */
		end;
		call hcs_$terminate_noname (srf2P, 0);
		srf2P = null;
	     end;
	     if srf3P ^= null then do;
		do i = 1 to ni;			/* loop to restore srf3 segment */
		     extension (i).bci = 0;		/* zero extension bound component indices */
		end;
		call hcs_$terminate_noname (srf3P, 0);
		srf3P = null;
	     end;
	     if t1P ^= null then do;
		call hcs_$delentry_seg (t1P, 0);
		t1P = null;
	     end;
	     if t2P ^= null then do;
		call hcs_$delentry_seg (t2P, 0);
		t2P = null;
	     end;
	     return;
	end cleaner;
	
check_binding: procedure;				/* internal procedure to determine if a segment is bound */
	     if bindings_full then go to no_chance;	/* don't try anything if table is full */

	     j = index (image.pathname, " ");		/* find the end of the pathname */
	     do k = j by -1 to 1 while (substr (image.pathname, k, 1) ^= ">"); /* find the last ">" */
	     end;
	     if substr (image.pathname, k, 1) ^= ">" then go to no_seg; /* not a valid pathname */
	     if k = 1 then dirname = ">";		/* directory is the root */
	     else dirname = substr (image.pathname, 1, k-1); /* form the directory name */
	     ename = substr (image.pathname, k+1, j-k);	/* form the entry name */
	     call hcs_$get_ring_brackets (dirname, ename, ring_brackets, code); /* get the ring brackets */
	     if code ^= 0 then go to no_status;		/* no status on directory -- give up */
	     if ring_brackets (2)<current_ring then go to no_access; /* no access -- give up */
	     call hcs_$initiate_count (dirname, ename, "", bc, 0, cP, code); /* initiate the segment */
	     if cP = null then go to no_seg;		/* unable to initiate? */

	     if image.bci = 0 then do;		/* initiated -- is the bound status unknown? */
		on any_other call oi_failure;		/* intercept faults from object_info_ */
		call object_info_$brief (ptr (cP, 0), bc, addr (oi), code); /* unknown -- find out */
		revert any_other;			/* intercept off */
		if code ^= 0 then go to not_bound;	/* is it an object segment? */
		if ^(oi.format.bound) then go to not_bound; /* object segment -- is it bound? */
	     end;

	     call component_info_$offset (ptr (cP, 0), binary (rel (bP)), addr (ci), code); /* bound -- get the component */
	     if code ^= 0 then go to no_component;	/* was the component found? */

	     if image.bci = 0 then do;		/* found -- initial bound component entry for the segment? */
		image.bci = bcmpi;			/* initial -- set bound component index to next available entry */
create:		bcmp (bcmpi).name = ci.name;		/* store the component name */
		if tbit then bcmp (bcmpi).trc = 1;	/* set a tsr...or... */
		else bcmp (bcmpi).prc = 1;		/* psr reference */
		if bcmpi = bindings_max_index then do;	/* is the bindings segment full? */
		     call com_err_ (0, "print_sample_refs", "The bound component table is full.
Components of segment references following sample ^d cannot be determined.", i);
		     bindings_full = "1"b;		/* set to process no more compoents */
		end;
		else bcmpi = bcmpi + 1;		/* increment the table index to the next available entry */
exit1:		pname = ci.name;			/* store component name for print_int */
		offset = binary (rel (bP)) - binary (rel (ci.text_start)); /* compute offset for print_int */
		call hcs_$terminate_noname (cP, code);	/* terminate the segment */
		return;				/* exit */
	     end;
	     
	     j = image.bci;				/* not an initial entry -- get index of first bound component */
check:	     if bcmp (j).name = ci.name then do;	/* do the names match? */
		if tbit then bcmp (j).trc = bcmp (j).trc + 1; /* match -- increment tsr...or... */
		else bcmp (j).prc = bcmp (j).prc + 1;	/* psr reference count */
		go to exit1;			/* transfer to set up for print_int */
	     end;
	     if bcmp (j).ci ^= 0 then do;		/* no match -- are there more components */
		j = bcmp (j).ci;			/* set index to next component */
		go to check;			/* look for a match */
	     end;
	     bcmp (j).ci = bcmpi;			/* no more components -- store index to next available entry */
	     go to create;				/* make a new entry */

no_chance:     prefix = "";
	     go to exit2;
no_status:     prefix = "NO STATUS - ";
	     go to exit2;
no_access:     prefix = "NOT IN READ BRACKET - ";
	     go to exit2;
no_seg:	     prefix = "CANNOT INITIATE - ";
	     go to exit2;
no_component:  prefix = "NO COMPONENT - ";
	     go to exit4;
not_bound:     prefix = "";
	     image.bci = -1;
exit4:	     call hcs_$terminate_noname (cP, code);	/* terminate the segment */
exit3:	     pname = prefix||image.pathname;		/* form pathname with prefix, if any */
	     offset = fixed (rel (bP));		/* store offset from psr or tsr */
	     return;
exit2:	     image.bci = -1;
	     go to exit3;
	     
oi_failure:    procedure;				/* object_info_ fault interceptor */
declare 1 cond_info aligned,				/* filled in by find_condition_info_ */
%include cond_info;

         call find_condition_info_ (null, addr (cond_info), code); /* what sort of fault? */
		if cond_info.condition_name = "cput" then go to pass_it_on;
		if cond_info.condition_name = "finish" then go to pass_it_on;
		if cond_info.condition_name = "storage" then go to pass_it_on;
		if cond_info.condition_name = "alrm" then go to pass_it_on;
		if cond_info.condition_name = "quit" then go to pass_it_on;
		if cond_info.condition_name = "program_interrupt" then do;
pass_it_on:	     call continue_to_signal_ (code);
		     return;
		end;
		go to not_bound;
	     end oi_failure;

	end check_binding;
	
suffix_error: call com_err_ (code, "print_sample_refs", "^a", ename);
	call cleaner;
	return;

init_error: call com_err_ (code, "print_sample_refs", "^a>^a", dirname, name);
	call cleaner;
	return;

temp_error: call com_err_ (code, "print_sample_refs", "While making a temporary segment in the process directory.");
	call cleaner;
	return;

switch_error: call com_err_ (code, "print_sample_refs", "^a", output_path);
	call cleaner;
	return;


     end print_sample_refs;
 



		    sample_refs.pl1                 11/15/82  1905.9rew 11/15/82  1526.2      203265


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


sample_refs: srf: procedure;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*	sample_refs samples the contents of the PSR and TSR periodically, in order to determine which segments
   a process is referencing.  Three data segments are used:
   srf1 - individual samples - time of interrupt; PSR and TSR contents; re-used segment number count
   srf2 - pathnames - segment pathnames; reference counts; link for re-used segment numbers
   srf3 - re-used seg.no. pathnames - pathnames;reference counts; link for further re-usages
   A CPU timer is established to interrupt the process every _n milliseconds.  (N.B. - SAMPLE RATES OF LESS
   THAN 1000 MILLISECONDS ARE NOT GUARANTEED ACCURATE).  The interrupt handller sample_refs$ih attempts to
   find the pathnames associated with the segment numbers as found in the PSR and TSR. (N.B. - THE CONTENTS OF
   THE TSR ARE OFTEN INVALID). The pathnames are then saved in either the srf2 or srf3 data segment, depending
   upon whether or not the segment number had been re-assigned since its last reference. The individual samples
   data are stored in the srf1 data segment.
   ONLY ONE INVOCATION OF sample_refs CAN RUN PER PROCESS. A SECONDARY INVOCATION WILL FORCE TERMINATION
   OF THE FIRST.

   0) Created by: Ross E. Klinger, November 11, 1973					*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

declare 1 srf1seg based (srf1P) aligned,		/* srf1 data base */
        2 time_on fixed binary (71),			/* time srf turned on */
        2 time_off fixed binary (71),			/* time srf turned off */
        2 table_index fixed binary (35),		/* index of where_when table */
        2 frequency fixed binary (35),			/* sample frequency in milliseconds */
        2 high_hc fixed binary (35),			/* highest hardcore segment number */
        2 proc_seg_cnt fixed binary (35),		/* highest process segment number */
        2 where_when (srf1_max_index),			/* table of times and locations */
	3 time fixed binary (71),			/* time of interrupt */
	3 prcdr pointer,				/* prcdr pointer */
	3 temporary pointer,			/* temporary pointer */
	3 prul fixed binary (35),			/* psr segment number re-usage level */
	3 trul fixed binary (35);			/* tsr segment number re-usage level */

declare 1 srf2seg based (srf2P) aligned,		/* auxilliary srf data base */
        2 time_on fixed binary (71),			/* time srf turned on */
        2 high_segno fixed bin (35),			/* highest segno referenced (valid or invalid) */
        2 pad fixed bin (35),				/* pad */
        2 segment (srf2_max_index),			/* table of pathnames indexed by segment number */
	3 pathname character (168),			/* segment pathname */
	3 prc fixed binary (35),			/* psr reference count */
	3 trc fixed binary (35),			/* tsr reference count */
	3 ci fixed binary (35),			/* chain index to extension for re-used segment numbers */
	3 bci fixed binary (35);			/* bound chain index -- NOT SET BY THIS PROGRAM */

declare 1 srf3seg based (srf3P) aligned,		/* extension data base for re-used segment numbers */
        2 time_on fixed binary (71),			/* time srf turned on */
        2 ni fixed binary (35),			/* index to next available table entry */
        2 pad fixed binary (35),			/* pad area */
        2 extension (srf3_max_index),			/* table of pathnames of re-used segment numbers */
	3 pathname character (168),			/* segment pathname */
	3 prc fixed binary (35),			/* psr reference count */
	3 trc fixed binary (35),			/* tsr reference count */
	3 ci fixed binary (35),			/* chain index to extension for n > 1 re-usages */
	3 bci fixed binary (35);			/* bound chain index -- NOT SET BY THIS PROGRAM */

declare (srf1P, srf2P, srf3P) pointer internal static initial (null); /* data base pointers */
declare (srf1_max_index, srf2_max_index, srf3_max_index) fixed bin internal static; /* maximum table indices */

declare  arg character (arglen) based (aP) unaligned,	/* command argument */
         argcnt fixed binary,				/* number of arguments */
         arglen fixed binary,				/* length of the argument */
         code fixed binary (35),			/* error code */
        (i, j, rul) fixed binary,			/* temporary storage */
        (k, kx) bit (1) initial ("0"b),			/* (k,kx)nown (1) / un(k,kx)nown (0) segment switches */
         dirname character (168) aligned,		/* directory name */
         ename character (32) aligned,			/* entry name */
         date_time character (24),			/* date and time */
         t fixed binary (71),				/* temporary storage -- clock time */
         f fixed binary (35),				/* temporary storage -- frequency */
         name char (32) aligned,			/* suffixed entry name */
        (aP, bP, cP) pointer;				/* pointers */

declare  error_table_$badopt external fixed binary (35);	/* error codes */
declare  sys_info$max_seg_size external fixed binary (35);	/* system maximum segment size */

declare  sample_refs$ih external entry (pointer);		/* srf interrupt handler */


declare  com_err_ external entry options (variable),
         continue_to_signal_ external entry (fixed bin (35)),
         cu_$arg_count external entry (fixed binary),
         cu_$arg_ptr external entry (fixed binary, pointer, fixed binary, fixed binary (35)),
         cv_dec_check_ external entry (character (*), fixed binary (35)) returns (fixed binary (35)),
         clock_ external entry returns (fixed binary (71)),
         date_time_ external entry (fixed binary (71), char (*)),
         expand_path_ external entry (pointer, fixed binary, pointer, pointer, fixed binary (35)),
         find_condition_info_ external entry (ptr, ptr, fixed bin (35)),
         get_wdir_ ext entry returns (char (168) aligned),
         hcs_$high_low_seg_count external entry (fixed binary (35), fixed binary (35)),
         hcs_$make_seg external entry (char (*) aligned, char (*) aligned, char (*), fixed bin (5), ptr, fixed bin (35)),
         hcs_$terminate_noname external entry (pointer, fixed binary (35)),
         suffixed_name_$make ext entry (char (*) aligned, char (*), char (32) aligned, fixed bin (35)),
         timer_manager_$cpu_call external entry (fixed binary (71), bit (2), entry),
         timer_manager_$reset_cpu_call external entry (entry);

declare  null builtin, (any_other, cleanup) condition;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	on cleanup call cleaner;			/* terminate data base if error before timer starts */
	srf1_max_index = divide (sys_info$max_seg_size - 8, 8, 17, 0); /* set maximum table indices */
	srf2_max_index = divide (sys_info$max_seg_size - 4, 46, 17, 0);
	srf3_max_index = srf2_max_index;

	call cu_$arg_count (argcnt);			/* check number of arguments */
	if argcnt = 0 then go to invock;		/* no -off option, check invocation */
	call cu_$arg_ptr (1, aP, arglen, code);		/* get the first argument */
	if aP -> arg ^= "-rs" then if aP -> arg ^= "-reset" then go to invock; /* is it the "-reset" option? */
	if argcnt > 1 then call com_err_ (0, "sample_refs", "Options after a ""-reset"" are ignored."); /* yes -- are there others? */
	if srf1P = null then return;			/* exit if nothing to turn off */
	call off;					/* close data bases */
	return;					/* exit */
invock:	if srf1P ^= null then do;			/* if secondary invocation, close previous data bases */
	     call off;				/* close */
	     call com_err_ (0, "sample_refs", "Secondary invocation: previous data bases terminated."); /* warning */
	end;
	srf2P, srf3P = null;			/* null to avoid needless hcs_$terminate_noname calls */
	f = 1000;					/* default frequency is 1000 milliseconds */
	ename = " ";				/* set to blanks: implies default entry name */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	do i = 1 to argcnt;				/* loop to examine arguments */
	     call cu_$arg_ptr (i, aP, arglen, code);	/* get the argument */
	     if aP -> arg ^= "-sm" then if aP -> arg ^= "-segment" then go to timeck; /* is it the "-segment" option? */
	     i = i+1;				/* increment argument counter */
	     call cu_$arg_ptr (i, aP, arglen, code);	/* get the segment name */
	     if code ^= 0 then do;			/* is segment name missing? */
		call com_err_ (0, "sample_refs", "No segment name after segment option."); /* write an error message */
		return;				/* give up */
	     end;
	     bP = addr (dirname);			/* get pointer to directory portion of pathname */
	     cP = addr (ename);			/* get pointer to entry name portion of pathname */
	     call expand_path_ (aP, arglen, bP, cP, code); /* expand to an absolute pathname */
	     if code ^= 0 then do;			/* was there an error? */
		call com_err_ (code, "sample_refs", "^a", aP -> arg); /* write an error message */
		return;
	     end;
	     go to continue;			/* look for another control option */
timeck:	     if aP -> arg ^= "-tm" then if aP -> arg ^= "-time" then go to bad_opt; /* is it the "-time" option? */
	     i = i+1;				/* must be -time option  --  increment argument counter */
	     call cu_$arg_ptr (i, aP, arglen, code);	/* get the frequency */
	     if code ^= 0 then do;			/* is the frequency missing? */
err1:		call com_err_ (0, "sample_refs", "Missing or invalid time."); /* write an error message */
		return;				/* give up */
	     end;
	     f = cv_dec_check_ (aP -> arg, code);	/* get the frequency */
	     if code ^= 0 then go to err1;		/* check for an invalidity */
	     if f ^> 0 then go to err1;		/* error if zero or negative */
continue: end;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	t = clock_ ();				/* get the clock time */
	if ename = " " then do;			/* was -sm option specified? */
	     call date_time_ (t, date_time);		/* no -- get string for unique name */
	     ename = translate (date_time, "_", " ");	/* change all " " to "_" */
	     dirname = get_wdir_ ();			/* put the segments in the working directory */
	end;

	i = index (ename, ".srf");			/* look for the suffix ".srf", ".srf1", ".srf2", etc. */
	if i ^= 0 then substr (ename, i, 32 - i + 1) = " "; /* if found, best just to strip it off */

	call suffixed_name_$make (ename, "srf1", name, code); /* add suffix */
	if code ^= 0 then go to suffix_error;		/* was there an error? */
	call hcs_$make_seg (dirname, name, "", 01011b, srf1P, code); /* make the segment */
	if srf1P = null then go to make_error;		/* was there an error? */

	call suffixed_name_$make (ename, "srf2", name, code); /* add suffix */
	if code ^= 0 then go to suffix_error;		/* was there an error? */
	call hcs_$make_seg (dirname, name, "", 01011b, srf2P, code); /* make the segment */
	if srf2P = null then go to make_error;

	call suffixed_name_$make (ename, "srf3", name, code); /* add suffix */
	if code ^= 0 then go to suffix_error;		/* was there an error? */
	call hcs_$make_seg (dirname, name, "", 01011b, srf3P, code); /* make the segment */
	if srf3P = null then go to make_error;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
start_timer: srf1seg.time_on = t;			/* set on time in srf data base */
	srf3seg.time_on = t;			/* set on time in srf3 data base */
	srf2seg.time_on = t;			/* set on time in auxilliary data base */
	frequency = f;				/* put frequency in data base */
	table_index = 1;				/* initialize table index */
	high_segno = 0;				/* initialize highest segno referenced */
	ni = 1;					/* initialize extension index */
	call hcs_$high_low_seg_count (proc_seg_cnt, high_hc); /* set the hardcore and process segment bounds */
	call timer_manager_$cpu_call ((frequency*1000), "10"b, sample_refs$ih); /* start timer */
	revert cleanup;
	return;					/* normal exit */


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

cleaner:	procedure;				/* terminates srf segments and resets invocation switch */
	     if srf3P ^= null then call hcs_$terminate_noname (srf3P, code);
	     if srf2P ^= null then call hcs_$terminate_noname (srf2P, code);
	     if srf1P ^= null then do;
		call hcs_$terminate_noname (srf1P, code);
		srf1P = null;
	     end;
	     return;
	end cleaner;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

suffix_error: call com_err_ (code, "sample_refs", ename);	/* write the error message */
	call cleaner;				/* cleanup */
	return;

make_error: call com_err_ (code, "sample_refs", "^a>^a", dirname, name); /* write the error message */
	call cleaner;				/* cleanup */
	return;

bad_opt:	if aP -> arg ^= "-rs" then if aP -> arg ^= "-reset" then go to bad_opt1; /* is it a "-reset" option? */
	call com_err_ (0, "sample_refs", """-reset"" ignored: must be first and only option."); /* yes -- warn and ignore */
	go to continue;
bad_opt1: call com_err_ (error_table_$badopt, "sample_refs", "^a", aP -> arg); /* write an error message */
	return;					/* exit */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

off:	procedure;				/* internal procedure to close data bases */

	     call timer_manager_$reset_cpu_call (sample_refs$ih); /* turn the timer off */
	     time_off = clock_ ();			/* set the off time */
	     table_index = table_index - 1;		/* decrement to drop the last (invalid) entry */
	     call hcs_$high_low_seg_count (proc_seg_cnt, high_hc); /* set the highest hardcore and process segment numbers */
	     call cleaner;				/* terminate the data bases */
	     return;				/* exit */

	end off;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

ih:	entry (mcP);				/* srf interrupt handler */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	on any_other begin;

dcl 1 cond_info aligned,				/* filled in by find_condition_info_ */
%include cond_info;

     call find_condition_info_ (null, addr (cond_info), code); /* determine type of fault */

	     if cond_info.condition_name = "cleanup" then call off; /* handle this condition */
	     else if cond_info.condition_name = "cput" then go to pass_it_on;
	     else if cond_info.condition_name = "alrm" then go to pass_it_on;
	     else if cond_info.condition_name = "quit" then go to pass_it_on;
	     else if cond_info.condition_name = "stack" then go to pass_it_on;
	     else if cond_info.condition_name = "finish" then go to pass_it_on;
	     else if cond_info.condition_name = "program_interrupt" then
pass_it_on:	call continue_to_signal_ (code);
	     else;				/* ignore all other conditions */

	end;
%include "mc";      /* include machine conditions declaration */

declare (mcP, pP, tP) pointer;			/* pointers to conditions and segments */

	where_when (table_index).time = clock_ ();	/* store the time of interrupt */
	mcp = mcP;				/* initialize the include's pointer */
	scup = addr (mc.scu);			/* ditto */
	pP = pointer (baseptr ("000"b || scu.psr), scu.ilc); /* form pointer to prcdr segment */
	where_when (table_index).prcdr = pP;		/* store in data base */
	call fill_pathname_p (pP);			/* develope pathname in auxilliary data base */

	if ni = srf3_max_index + 1 then do;		/* is the extension table full? */
srf3_full:     call off;				/* close the data bases */
	     call com_err_ (0, "sample_refs$ih", "srf3 data base full. Automatic reset."); /* write message */
	     revert any_other;
	     return;
	end;

	tP = pointer (baseptr ("000"b || scu.tsr), scu.ca); /* form pointer to temporary segment */
	where_when (table_index).temporary = tP;	/* store in data base */
	call fill_pathname_t (tP);			/* develop pathname in auxilliary data base */
	if ni = srf3_max_index then go to srf3_full;	/* is extension table full? */

	if table_index = 37767 then do;		/* is this the last possible place? */
	     call off;				/* yes -- close the data bases */
	     call com_err_ (0, "sample_refs$ih", "srf1 data base full. Automatic reset."); /* write  message */
	     revert any_other;			/* stop intercepting faults */
	     return;				/* exit */
	end;

	table_index = table_index + 1;		/* no -- increment the index */
	call timer_manager_$cpu_call ((frequency*1000), "10"b, sample_refs$ih); /* start the timer again */
	revert any_other;				/* stop intercepting faults */
	return;					/* exit */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

fill_pathname_p: procedure (xP);			/* internal procedure to store pathnames -- psr reference entry */

declare  xP pointer,				/* pointer to segment */
         temp_pathname character (168),			/* pathname temporary storage */
         tbit bit (1),				/* psr (0)/tsr (1) reference switch */
         ring0_get_$name external entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35)),
         hcs_$fs_get_path_name external entry (ptr, char (*) aligned, fixed bin, char (*) aligned, fixed bin (35));

	     tbit = "0"b;				/* psr reference */
	     go to start;

fill_pathname_t: entry (xP);				/* tsr reference entry */

	     tbit = "1"b;				/* set switch on */
start:	     i = fixed (baseno (xP));			/* set segment number */

	     if i > srf2_max_index then do;		/* is the segment number beyond the srf2 table capacity? */
		call com_err_ (0, "sample_refs$ih", "Reference to segment number ^d exceeds table capacity. Reference ignored.", i);
		return;
	     end;

	     if i > high_segno then high_segno = i;	/* keep highest segno referenced up to data */
	     if i <= high_hc then do;			/* is the segment in the hardcore? */
		call ring0_get_$name (dirname, ename, xP, code); /* yes -- get the pathname components */

		if code = 0 then do;		/* did it succeed? */
		     j = index (dirname, " ");	/* yes -- find the first blank in the directory name */
		     if j <= 1 then temp_pathname = ename; /* no directory name */
		     else temp_pathname = substr (dirname, 1, j-1)||">"||ename; /* directory name found */
		end;

		else temp_pathname = "INVALID RING 0 SEGMENT NUMBER"; /* ring0_get_$name failed */
	     end;

	     else do;				/* segment not in hardcore */
		call hcs_$fs_get_path_name (xP, dirname, j, ename, code); /* yes -- get the pathname components */
		if code = 0 then temp_pathname = substr (dirname, 1, j)||">"||ename; /* form the pathname */
		else temp_pathname = "INVALID NON-RING 0 SEGMENT NUMBER"; /* hcs_$fs_get_path_name failed */
	     end;

	     if segment (i).pathname < " " then do;	/* has this segment number been encountered? */
		segment (i).pathname = temp_pathname;	/* no -- fill in the pathname */
		go to set_seg_rc;			/* set reference count in segment table */
	     end;

	     if segment (i).ci = 0 then do;		/* segment number encountered -- is it re-used? */

		if segment (i).pathname = temp_pathname then do; /* not re-used -- do the pathnames match? */
set_seg_rc:	     if tbit then segment (i).trc = segment (i).trc + 1; /* match -- increment trc...or... */
		     else segment (i).prc = segment (i).prc + 1; /* increment prc */
		     return;			/* exit */
		end;

		else do;				/* no match -- build an extension entry for re-used segment number */
		     rul = 1;			/* set re-usage level for an initial re-usage */
		     segment (i).ci = ni;		/* set segment chain index to next available extension entry */
		     go to set_ext;			/* fill in the extension */
		end;
	     end;

	     j = segment (i).ci;			/* segment number previously re-used -- pick up initial chain index */
	     do rul = 1 by 1 while (extension (j).ci ^= 0); /* find the last usage of the segment number */
		j = extension (j).ci;
	     end;

	     if extension (j).pathname = temp_pathname then do; /* do the pathnames match? */
		if tbit then extension (j).trc = extension (j).trc + 1; /* match -- increment trc...or... */
		else extension (j).prc = extension (j).prc + 1; /* increment prc */
		go to set_rul;			/* set re-usage level */
	     end;

	     rul = rul + 1;				/* no match -- increment re-usage level */
	     extension (j).ci = ni;			/* set extension chain index to next available extension entry */
set_ext:	     extension (ni).pathname = temp_pathname;	/* fill in pathname */
	     if tbit then extension (ni).trc = 1;	/* set trc...or... */
	     else extension (ni).prc = 1;		/* set prc */
	     ni = ni + 1;				/* increment index to next available entry */
set_rul:	     if tbit then where_when (table_index).trul = rul; /* set trul...or... */
	     else where_when (table_index).prul = rul;	/* set prul */
	     return;

	end fill_pathname_p;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

     end sample_refs;
   



		    test_cpu.pl1                    10/22/84  1154.7rew 10/22/84  1059.4      609246


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */
/* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */


test_cpu:
     proc;

/* This program calls several test cases that have been known to fail at one time or another on the
   various CPUs. It is assumed that they have been fixed; this program justs checks to make sure
   they indeed have been.

   If no arguments are specified, all tests are run.

   It is assumed new tests will be added as they are developed.

   Coded.		01/10/74 by S.Webber
   Updated	03/27/74 by S.Webber to add mpy_ofl, test_xed, bad_fill.
   Updated	3/20/76 by S.Webber to add test_cmpc_fill, extra_fill, cmpc7
   Updated	3/21/76 by S.Webber to add acv_restart, scm_tally
   Updated	8/27/76 by J. A. Bush to add tests 23 to 32
   Updated          8/30/80 by R. L. Coppola to add tests 33 to 42
   Updated          8/30/80 by R.L. Coppola to make this and associated tests
   bindable.
   Updated          2/24/81 by Rich Coppola to add call to save history regs
   Updated          9/01/81 by Rich Coppola to add test 43, and restructure
   the entire thing.
   Updated          02/15/82 by Rich Fawcett to add test 44 (scm_tro).
   Updated          02/25/82 by Rich Fawcett to add test 45 (rpt_test_odd).
   Updated          02/25/82 by Rich Fawcett to add test 46 (rpt_test_evn)
   Updated	Apr 2, 1982 by Rich Coppola to add FCO info and determine
   CPU type that a test fails on.
   Updated          Nov 8, 1983 by Rich Coppola to add test 47 and beef up test 43.
   Updated          Oct 1984 by Rich Fawcett to add tests 48 to 52.
   Updated          Oct 1984 by Rich Fawcett to call the test cases as cpu_test_$TEST_NMAE
*/


/* Automatic */

dcl  1 ACL (1) aligned,
       2 access_name char (32) aligned,
       2 modes bit (36),
       2 zero bit (36) init ("0"b),
       2 status fixed bin (35);

dcl  num_sel_tests fixed bin;
dcl  targ char (tc) based (tp);
dcl  temp_data char (temp_data_size) based (temp_data_ptr);
dcl  temp_data_ptr ptr;
dcl  temp_data_size fixed bin (21);
dcl  temp_words (temp_data_size) bit (36) based (temp_data_ptr);
dcl  sel_list (NUM_TESTS) fixed bin;
dcl  excl_list (NUM_TESTS) fixed bin;
dcl  long_sw bit (1) init ("0"b);
dcl  line_length fixed bin;
dcl  pdir char (168) aligned;
dcl  (argcount, i, j, k, next_test, start_test, last_test, num_to_cycle, num_to_repeat) fixed bin init (0);
dcl  (COND, sum, RPT, SEL, CYCL) fixed bin;
dcl  tries fixed bin;
dcl  (hreg_ptr, stackp, faultsp, test_data1p) ptr;
dcl  tmlr_ptr ptr init (null);
dcl  (TERM, sel_flag, from_flag, to_flag, cycle_flag, found_arg) bit (1) init ("0"b);
dcl  tp ptr;
dcl  tc fixed bin;
dcl  code fixed bin (35);
dcl  1 akst aligned like kst_attributes;
dcl  (no_display_mc, h_sw, mc_sw, no_cond, brief_sw) bit (1) init ("0"b);
dcl  hreg_state bit (1) aligned;			/* state of the process hreg switch */
dcl  int_cond_name char (32);
dcl  pertinent_info char (100) var init ("");
dcl  FCO_required char (100) var init ("");
dcl  cond_infop ptr;				/* pointer to condition info */
dcl  str char (j) based (tmlr_ptr);
dcl  (no_write_permission, cleanup, any_other, no_read_permission, program_interrupt) condition;
dcl  STR char;
dcl  (null, collate, addr, addrel, baseno, char,fixed,index,length,
     ltrim,rtrim,substr,unspec) builtin;

/* Constants */


dcl  NUM_TESTS fixed bin init (52) static options (constant);

/* LIST OF TEST NAMES */

dcl  test_name (52) char (40) var int static options (constant)
	init ("mlrstern", "tmlr", "csl_oob", "mvn", "mvn_ofl", "tct", "sreg", "csl_onc", "test_sc2", "test_ci",
	"rpd_test", "mlr_tst", "csl_test", "cmpc", "bad_fill", "mpy_ofl", "test_xed", "cmpc7", "extra_fill",
	"test_cmpc_fill", "acv_restart", "scm_tally", "mvt_ascii_to_bcd", "mvt_bcd_to_ascii", "mvt_nine_to_four",
	"mvt_four_to_nine", "mvt_ascii_to_ebcdic", "mvt_ebcdic_to_ascii", "ci_mod_case_2", "acv_restart_csl",
	"cmpn_tst", "itp_mod", "mvnoosb", "cmpb_with_sixbit_offset", "cmpb_with_rotate", "cmpc_pgbnd", "csl_pgflt",
	"scm_pgflt", "scd_con_flt", "xed_dirflt_even", "xed_dirflt_odd", "cmpc_adj_len", "cmpc_zero_ind", "scm_tro",
	"rpt_test_odd", "rpt_test_evn", "scd_oob_tst","cmpb_onc","cmpc_a","cmpc_b","sreg_no_write","tnz");


dcl  num_temps fixed bin int static;
dcl  expected_condition (5) char (32) int static init ((5) (32)"");
dcl  num_expected_cond fixed bin int static;
dcl  myname char (8) int static options (constant) init ("test_cpu");
dcl  mvtr_sw bit (1) int static init ("0"b);

dcl  tempseg_ptr (1:3) ptr int static init ((3) null);
dcl  TRUNC_and_DEACT fixed bin int static init (1);
dcl  DELETE fixed bin int static init (2);
dcl  TRUNCATE fixed bin int static init (3);
dcl  DEACT fixed bin int static init (4);


/* External  */

dcl  ioa_ entry options (variable);
dcl  hcs_$add_acl_entries entry (char (*) aligned, char (*), ptr, fixed bin, fixed bin (35));
dcl  get_group_id_ entry returns (char (32));
dcl  get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin);
dcl  hcs_$history_regs_get entry (bit (1) aligned);
dcl  hcs_$history_regs_set entry (bit (1) aligned);
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  term_$refname entry (char (*) aligned, fixed bin (35));
dcl  phcs_$deactivate entry (ptr, fixed bin (35));
dcl  phcs_$set_kst_attributes entry (fixed bin (35), ptr, fixed bin (35));
dcl  get_pdir_ entry returns (char (168) aligned);
dcl  delete_$ptr entry (ptr, bit (6) aligned, char (*), fixed bin (35));
dcl  hcs_$set_max_length_seg entry (ptr, fixed bin (19), fixed bin (35));
dcl  hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry returns (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  find_condition_info_ entry (ptr, ptr, fixed bin (35));
dcl  continue_to_signal_ entry (fixed bin (35));
dcl  find_condition_frame_ entry (ptr) returns (ptr);
dcl  cu_$stack_frame_ptr entry (ptr);
dcl  dump_machine_cond_ entry (ptr, ptr, char (32) aligned, fixed bin);
dcl  hran_$hranl entry (ptr, ptr, bit (1));
dcl  test_data1_$ ext;
     

/* test_cpu test cases and support routines */


dcl  cpu_tests_$tmlr entry (fixed bin, ptr, fixed bin, ptr);
dcl  cpu_tests_$tmlr_data char (58) aligned ext;
dcl  cpu_tests_$mvn entry (ptr);
dcl  cpu_tests_$tct entry (ptr);
dcl  cpu_tests_$mvn_ofl entry (ptr);
dcl  cpu_tests_$mlrstern entry (ptr, ptr);
dcl  cpu_tests_$sreg entry;
dcl  cpu_tests_$csl_onc entry (ptr);
dcl  cpu_tests_$test_sc2 entry (ptr);
dcl  cpu_tests_$test_ci entry;
dcl  cpu_tests_$rpd_test entry;
dcl  cpu_tests_$mlr_tst entry (ptr);
dcl  cpu_tests_$cmpc entry;
dcl  cpu_tests_$csl_test entry (ptr, ptr);
dcl  cpu_tests_$csl_oob entry (ptr);
dcl  cpu_tests_$bad_fill entry (ptr, ptr);
dcl  cpu_tests_$mpy_ofl entry;
dcl  cpu_tests_$test_xed entry;
dcl  cpu_tests_$cmpc7 entry (ptr);
dcl  cpu_tests_$extra_fill entry (ptr);
dcl  cpu_tests_$test_cmpc_fill entry;
dcl  cpu_tests_$acv_restart entry (ptr);
dcl  cpu_tests_$scm_tally entry (ptr);
dcl  cpu_tests_$mvt_tst_ascii_to_bcd entry;
dcl  cpu_tests_$mvt_tst_bcd_to_ascii entry;
dcl  cpu_tests_$mvt_tst_nine_to_four entry;
dcl  cpu_tests_$mvt_tst_four_to_nine entry;
dcl  cpu_tests_$mvt_tst_ascii_to_ebcdic entry;
dcl  cpu_tests_$mvt_tst_ebcdic_to_ascii entry;
dcl  cpu_tests_$mvt_tst_release_t_segs entry;
dcl  cpu_tests_$ci_mod_case_2 entry (ptr);
dcl  cpu_tests_$acv_restart_csl entry (ptr);
dcl  cpu_tests_$cmpn_tst entry (ptr);
dcl  cpu_tests_$itp_mod entry;
dcl  cpu_tests_$mvnoosb entry (ptr);
dcl  cpu_tests_$cmpb_with_sixbit_offset entry (ptr);
dcl  cpu_tests_$cmpb_with_rotate entry (ptr);
dcl  cpu_tests_$cmpc_pgbnd entry (ptr);
dcl  cpu_tests_$csl_pgflt entry (ptr);
dcl  cpu_tests_$scm_pgflt entry (ptr);
dcl  (cpu_tests_$scd_con_flt,
      cpu_tests_$sreg_no_write) entry;
dcl  cpu_tests_$xed_dirflt_even entry (ptr);
dcl  cpu_tests_$xed_dirflt_odd entry (ptr);
dcl  cpu_tests_$cmpc_zero_ind entry (ptr);
dcl  cpu_tests_$scm_tro entry (ptr);
dcl  cpu_tests_$rpt_test_odd entry (ptr);
dcl  cpu_tests_$rpt_test_evn entry (ptr);
dcl  cpu_tests_$scd_oob_tst entry (ptr, ptr);
dcl  cpu_tests_$cmpc_adj_len entry (ptr);
dcl  (cpu_tests_$cmpb_onc,
      cpu_tests_$cmpc_a,
      cpu_tests_$cmpc_b,
      cpu_tests_$tnz) entry (ptr);
    

dcl  1 cond_info aligned,
%include cond_info;


%page;
%include kst_attributes;
%page;

	on cleanup call CLEANUP;


/* set default options */

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


	call hcs_$history_regs_get (hreg_state);	/* get current state */
	if ^hreg_state then /* if off, turn them on */ call hcs_$history_regs_set ("1"b);

	h_sw = "0"b;				/* set display of hregs to off */
	mc_sw = "0"b;				/* set display of mach cond's to off */
	no_display_mc = "1"b;

	test_data1p = addr (test_data1_$);
	num_to_cycle, num_to_repeat, start_test = 1;
	num_sel_tests, last_test = NUM_TESTS;

	do i = 1 to NUM_TESTS;			/* fill in the test selection */
	     sel_list (i) = i;			/* to default values */
	     excl_list (i) = -1;
	end;

	do i = 1 to 3;				/* ensure all are nul */
	     tempseg_ptr (i) = null ();
	end;


/* get the arguments if given and handle the test specified */


	argcount = cu_$arg_count ();			/* get argument count */

	do j = 1 to argcount;			/* process args */
	     call cu_$arg_ptr (j, tp, tc, code);
	     if code ^= 0 then do;
		call com_err_ (0, (myname), "Invalid or unrecognized control_arg.");
		go to BAD_ARG;
		end;
command_loop:
	     if targ = "-from" | targ = "-fm" then do;
		j = j + 1;
		call cu_$arg_ptr (j, tp, tc, code);
		if code ^= 0 then do;
		     call com_err_ (0, (myname), "Invalid or unrecognized control_arg.");
		     go to BAD_ARG;
		     end;

		start_test = cv_dec_check_ (targ, code);
		from_flag = "1"b;
		if code ^= 0 then do;
		     do k = 1 to NUM_TESTS while (^found_arg);
			if test_name (k) = targ then do;
			     found_arg = "1"b;
			     start_test = k;
			     end;
		     end;
		     if ^found_arg then do;
			call com_err_ (0, myname, "test (^a) not recognized", targ);
			return;
			end;
		     end;
		end;

	     else if targ = "-to" then do;
		to_flag = "1"b;
		j = j + 1;
		call cu_$arg_ptr (j, tp, tc, code);
		if code ^= 0 then do;
		     call com_err_ (0, (myname), "Invalid or unrecognized control_arg.");
		     go to BAD_ARG;
		     end;

		last_test = cv_dec_check_ (targ, code);
		if code ^= 0 then do;
		     do k = 1 to NUM_TESTS while (^found_arg);
			if test_name (k) = targ then do;
			     found_arg = "1"b;
			     last_test = k;
			     end;
		     end;
		     if ^found_arg then do;
			call com_err_ (0, myname, "test (^a) not recognized", targ);
			return;
			end;
		     end;
		end;

	     else if targ = "-repeat" | targ = "-rpt" then do;
		sel_flag = "1"b;
		j = j + 1;
		call cu_$arg_ptr (j, tp, tc, code);
		if code ^= 0 then do;
		     call com_err_ (0, (myname), "Invalid or unrecognized control_arg.");
		     go to BAD_ARG;
		     end;

		num_to_repeat = cv_dec_check_ (targ, code);

		if code ^= 0 then do;
		     call com_err_ (code, (myname),
			"The ""repeat"" control_arg must be followed by a decimal number, not (^a).", targ);
		     go to BAD_ARG;
		     end;
		end;

	     else if targ = "-cycle" | targ = "-cyc" then do;
		j = j + 1;
		cycle_flag = "1"b;
		call cu_$arg_ptr (j, tp, tc, code);

		if code ^= 0 then do;
		     call com_err_ (0, (myname), "Invalid or unrecognized control_arg.");
		     go to BAD_ARG;
		     end;

		num_to_cycle = cv_dec_check_ (targ, code);

		if code ^= 0 then do;
		     call com_err_ (code, (myname),
			"The ""-cycle"" control_arg must be followed by a decimal number, not (^a).", targ);
		     go to BAD_ARG;
		     end;
		end;

	     else if targ = "-sel" | targ = "-select" | targ = "-do" then do;
		sel_flag = "1"b;
		j = j + 1;

		num_sel_tests = 0;
		do i = 1 to NUM_TESTS;		/* zip the select array */
		     sel_list (i) = NUM_TESTS + 1;
		end;


		do j = j to argcount;
		     call cu_$arg_ptr (j, tp, tc, code);
		     if code ^= 0 then do;
			call com_err_ (0, (myname), "bad arg in -select");
			goto BAD_ARG;
			end;
		     if substr (targ, 1, 1) = "-" then goto command_loop;
		     num_sel_tests = num_sel_tests + 1;
		     sel_list (num_sel_tests) = cv_dec_check_ (targ, code);
		     if code ^= 0 then do;
			found_arg = "0"b;
			do k = 1 to NUM_TESTS while (^found_arg);
			     if test_name (k) = targ then do;
				found_arg = "1"b;
				sel_list (num_sel_tests) = k;
				end;
			end;
			if ^found_arg then do;
			     call com_err_ (0, myname, "test (^a) not recognized", targ);
			     return;
			     end;
			end;
		end;
		end;

	     else if targ = "-excl" | targ = "-exclude" then do;
		j = j + 1;

		do j = j to argcount;
		     call cu_$arg_ptr (j, tp, tc, code);
		     if code ^= 0 then do;
			call com_err_ (code, (myname), "bad arg in -exclude");
			goto BAD_ARG;
			end;
		     if substr (targ, 1, 1) = "-" then goto command_loop;

		     k = cv_dec_check_ (targ, code);

		     if code ^= 0 then do;
			found_arg = "0"b;
			do k = 1 to NUM_TESTS while (^found_arg);
			     if test_name (k) = targ then do;
				found_arg = "1"b;
				excl_list (k) = k;
				end;
			end;
			if ^found_arg then do;
			     call com_err_ (0, myname, "test (^a) not recognized", targ);
			     return;
			     end;
			end;

		     if (k > 1) & (k ^> NUM_TESTS) then excl_list (k) = k;
		end;
		end;


	     else if targ = "-test_names" then do;
		call ioa_ ("Test Names:");
		do k = 1 to NUM_TESTS;
		     call ioa_ ("^3d. ^a.", k, test_name (k));
		end;
		return;
		end;

	     else if targ = "-help" then go to USAGE;


	     else if targ = "-history_regs" | targ = "-hregs" then h_sw = "1"b;


	     else if targ = "-machine_conditions" | targ = "-mc" then mc_sw = "1"b;

	     else if targ = "-brief" | targ = "-bf" then brief_sw = "1"b;


	     else if targ = "-long" | targ = "-lg" then do;
						/* turn hregs and mc on */
		mc_sw, h_sw = "1"b;
		call hcs_$history_regs_get (hreg_state);/* get current state */
		if ^hreg_state then /* if off, turn them on */ call hcs_$history_regs_set ("1"b);
		end;


	     else if targ = "-stop_on_failure" | targ = "-sof" then /* don't handle any conditions */ no_cond = "1"b;


	     else do;
		call com_err_ (0, (myname), "Invalid or unrecognizable control_arg (^a)", targ);
		go to BAD_ARG;
		end;


	end;					/* end process args */
	if (sel_flag & from_flag) | (sel_flag & to_flag) then
	     if num_to_repeat = 1 then do;
		call com_err_ (0, (myname), "The -select argument cannot be used with the -to or -from arguments.");
		goto BAD_ARG;
		end;


	go to START;


BAD_ARG:
	call com_err_ (0, (myname), "For a list of valid control_args type 'test_cpu -help'.");
	return;
USAGE:
	call ioa_ ("Usage: test_cpu {-control_args}");
	call ioa_ ("control_args:^/     -from TEST_NUM/NAME (-fm)   -to TEST_NUM/NAME	-test_names
     -exclude TEST_LIST (-excl)  -stop_on_failure (-sof)	-long (lg)");
	call ioa_ ("     -history_regs (-hregs)	   -machine_conditions (-mc)	-brief (-bf)
     -repeat COUNT (-rpt)	   -select (-sel) TEST_LIST   -cycle COUNT^/");
	return;

%page;

START:
	if no_cond then go to start_join;

	on condition (any_other)
	     begin;

		TERM = "0"b;
		cond_infop = addr (cond_info);
		call find_condition_info_ (null (), cond_infop, code);
		int_cond_name = cond_info.condition_name;

		if cond_info.condition_name = "cleanup"
		     | /* dont bother with these */ cond_info.condition_name = "quit"
		     | cond_info.condition_name = "command_error" | cond_info.condition_name = "command_question"
		     | cond_info.condition_name = "linkage_error" | cond_info.condition_name = "finish" then
		     go to END_COND;


		do COND = 1 to num_expected_cond while (^TERM);
		     if rtrim (cond_info.condition_name) = rtrim (expected_condition (COND)) then do;
			call ioa_ ("^a: Test ^a failed --^a-- condition.^/^-^-^-*** HARDWARE FAILING ***", myname,
			     test_name (next_test - 1), int_cond_name);

			if pertinent_info ^= "" then call ioa_ ("^a: ^a", myname, pertinent_info);
			if FCO_required ^= "" then call ioa_ ("^a: ^a", myname, FCO_required);


			TERM = "1"b;
			if ^no_display_mc then call display_mc;
			if next_test > NUM_TESTS /* error in last test? */ then go to done;
			if ^sel_flag then go to test (next_test);
			go to sel_loop;
			end;
		end;


/* If we get here, some fault other than the one we expected ("normal" failure)
   occurred! Here it is our duty to display the MCs and Hregs whether the
   user requested them or not. */


		call ioa_ (
		     "^a: Test ^a encountered an unexpected ^a.^/^-^-^-*** HARDWARE FAILING ***^/^-The function under test does not normally exhibit this failure."
		     , myname, test_name (next_test - 1), int_cond_name);
		no_display_mc = "0"b;
		mc_sw, h_sw = "1"b;
		call display_mc;
		if next_test > NUM_TESTS then /* did last test fail */ go to done;

		if ^sel_flag then go to test (next_test);
		go to sel_loop;

END_COND:
		call continue_to_signal_ (code);

	     end;					/* end cond handler */
%page;

start_join:
	on condition (program_interrupt)
	     begin;
		call ioa_ ("test_cpu: Restarting test ^d.", next_test - 1);
		go to test (next_test - 1);
	     end;					/* end pi handler */


	if (h_sw | mc_sw) then no_display_mc = "0"b;

	if from_flag = "1"b | to_flag = "1"b then do;

	     if from_flag = "0"b then start_test = 1;
	     if to_flag = "0"b then last_test = NUM_TESTS;
	     if start_test > last_test then do;
		call com_err_ (0, (myname), " -from ^d is greater then the -to ^d .", start_test, last_test);
		return;
		end;

	     sel_flag = "1"b;

	     TERM = "0"b;
	     num_sel_tests = 0;
	     do i = 1 to NUM_TESTS while (^TERM);
		num_sel_tests = i;
		sel_list (i) = start_test;
		start_test = start_test + 1;
		if start_test > last_test then TERM = ^TERM;
	     end;
	     end;

	if ^sel_flag then go to test (1);		/* normal pass */

	do RPT = 1 to num_to_repeat;
	     do SEL = 0 to num_sel_tests - 1 while (sel_list (SEL + 1) ^> NUM_TESTS);
		go to test (sel_list (SEL + 1));
sel_loop:
	     end;
	end;

	go to done;
%page;

/*	TEST 1.   mlrstern     */

/* This test tests a particular failure whereby the fill  character is placed as the
   first character of a new page */

test (1):
	next_test = 2;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude1;

	if ^brief_sw then call ioa_ ("Test  1^-<mlrstern>");

	call set_up_conds (3, "derail,mme1,mme4",
	     "Derail = MLR failed; MME1 = MLR and CMPC failed; MME4 = CMPC failed.", "");

	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */
	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (TRUNC_and_DEACT);
	     call cpu_tests_$mlrstern (test_data1p, tempseg_ptr(1));
	end;
	call prepare_segment (DELETE);


exclude1:
	if sel_flag then goto sel_loop;
	if next_test > last_test then goto done;

%page;


/*	TEST 2.	tmlr	*/

/* This test consists of calling " which in turn calls tmlr to do a MLR instruction.
   If test_tmlr notices that the MLR failed it prints out a message.	*/

test (2):
	next_test = 3;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude2;

	if ^brief_sw then call ioa_ ("Test  2^-<tmlr>");

	call set_up_conds (0, "", "", "");

	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (TRUNC_and_DEACT);

	     do j = 54 to 58;
		do i = 0 to 4;
		     call cpu_tests_$tmlr (i, tmlr_ptr, j, tempseg_ptr (1));
		     if substr (cpu_tests_$tmlr_data, 1, j) ^= str then do;
			call ioa_ (
			     "test tmlr; strings do not match *** HARDWARE FAILING ***^/data should be:^-^a^/data is^7x^-^a^/"
			     , substr (cpu_tests_$tmlr_data, 1, j), str);
			end;
		     call prepare_segment (DEACT);
		end;
	     end;
	end;
	call prepare_segment (DELETE);
exclude2:
	if sel_flag then goto sel_loop;
	if next_test > last_test then goto done;

%page;


/* 	TEST 3.	csl_oob	*/

/* This test consists in calling the program csl_oob, failure gives us an out_of_bounds */

test (3):
	next_test = 4;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude3;

	if ^brief_sw then call ioa_ ("Test  3^-<csl_oob>");

	call set_up_conds (1, "out_of_bounds", "Key to failure is starting Bit No. in D1.", "");

	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (TRUNC_and_DEACT);
	     call cpu_tests_$csl_oob (tempseg_ptr (1));
	end;

	call prepare_segment (DELETE);

exclude3:
	if sel_flag then goto sel_loop;
	if next_test > last_test then goto done;


%page;


/*	TEST 4.	mvn	*/

/* This test consists in a call to the routine "mvn" does not fault if the hardware works. */

test (4):
	next_test = 5;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude4;

	if ^brief_sw then call ioa_ ("Test  4^-<mvn>");

	call set_up_conds (3, "derail,mme1,mme4",
	     "DERAIL = MVN failed; MME1 = MVN and CMPC failed; MME4 = CMPC failed.", "");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (TRUNC_and_DEACT);
	     call cpu_tests_$mvn (tempseg_ptr (1));
	end;

	call prepare_segment (DELETE);

exclude4:
	if sel_flag then goto sel_loop;
	if next_test > last_test then goto done;

%page;


/*	TEST 5.	mvn_ofl	*/

/* This test checks the moving of a number which has value 0. It should not get
   an overflow */

test (5):
	next_test = 6;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude5;

	if ^brief_sw then call ioa_ ("Test  5^-<mvn_ofl>");

	call set_up_conds (1, "overflow", "", "");

	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (TRUNC_and_DEACT);
	     call cpu_tests_$mvn_ofl (tempseg_ptr(1));
	end;

	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */


exclude5:
	if sel_flag then goto sel_loop;
	if next_test > last_test then goto done;

%page;


/*	TEST 6.	tct	*/

/* This test consists in a call to the routine "tct" which gets  an op_not_complete
   if the hardware fails. */

test (6):
	next_test = 7;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude6;

	if ^brief_sw then call ioa_ ("Test  6^-<tct>");

	call set_up_conds (1, "op_not_complete", "", "");

	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (TRUNC_and_DEACT);
	     call cpu_tests_$tct (tempseg_ptr(1));
	end;

	call prepare_segment (DELETE);


exclude6:
	if sel_flag then goto sel_loop;
	if next_test > last_test then goto done;

%page;


/*	TEST 7.	sreg	*/

/* This test is done by calling the program sreg which has an sreg instruction as the
   last instruction on a page and the next procedure page faults.

   The test fails (the hardware is broken) if we get an op-not-complete. */


test (7):
	next_test = 8;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude7;

	if ^brief_sw then call ioa_ ("Test  7^-<sreg>");

	call set_up_conds (1, "op_not_complete", "", "");

	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call cpu_tests_$sreg ();				/* run the actual test */
	end;

	call prepare_segment (DELETE);

exclude7:
	if sel_flag then goto sel_loop;
	if next_test > last_test then goto done;

%page;


/*	TEST 8.	csl_onc	*/

/* This test consists in calling csl_onc which gets an op_not_complete if it fails. */

test (8):
	next_test = 9;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude8;

	if ^brief_sw then call ioa_ ("Test  8^-<csl_onc>");

	call set_up_conds (1, "op_not_complete", "", "");

	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (TRUNC_and_DEACT);
	     call cpu_tests_$csl_onc (tempseg_ptr (1));
	end;

	call prepare_segment (DELETE);

exclude8:
	if sel_flag then goto sel_loop;
	if next_test > last_test then goto done;

%page;


/*	TEST 9.	test_sc2	*/

/* This test checks the sequence character tag.  A ZOP fault occurs if the hardware fails. */

test (9):
	next_test = 10;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude9;

	if ^brief_sw then call ioa_ ("Test  9^-<test_sc2>");

	call set_up_conds (1, "illegal_opcode", "", "");


	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (TRUNC_and_DEACT);
	     call cpu_tests_$test_sc2 (tempseg_ptr(1));
	end;

	call prepare_segment (DELETE);

exclude9:
	if sel_flag then goto sel_loop;
	if next_test > last_test then goto done;

%page;


/*	TEST 10.	test_ci	*/

/* This test tries out a CI modifier. The test gets a ZOP fault if the hardware fails. */

test (10):
	next_test = 11;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude10;

	if ^brief_sw then call ioa_ ("Test 10^-<test_ci>");

	call set_up_conds (1, "illegal_opcode", "", "");

	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */


	do CYCL = 1 to num_to_cycle;
	     call cpu_tests_$test_ci ();
	end;

	call prepare_segment (DELETE);


exclude10:
	if sel_flag then goto sel_loop;
	if next_test > last_test then goto done;

%page;


/* 	TEST 11.	rpd_test	*/

/* This test tries a particluar RPD sequence that failed on Serial 7 at MIT */

test (11):
	next_test = 12;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude11;

	if ^brief_sw then call ioa_ ("Test 11^-<rpd_test>");

	call set_up_conds (1, "illegal_opcode", "", "");

	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call cpu_tests_$rpd_test ();
	end;

	call prepare_segment (DELETE);

exclude11:
	if sel_flag then goto sel_loop;
	if next_test > last_test then goto done;

%page;


/*	TEST 12.	mlr_tst	*/

/* This test tries a particular MLR sequence. */

test (12):
	next_test = 13;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude12;

	if ^brief_sw then call ioa_ ("Test 12^-<mlr_tst>");

	call set_up_conds (3, "derail,mme1,mme4",
	     "Derail = MLR failed; MME1 = MLR and CMPC failed; MME4 = CMPC failed.", "");


/* This test interacts with the bound fault mechanism. We must create anew the testcpu_tempseg(1) each time we run the
   test as well as terminate the test itself */

	num_temps = 1;				/* need one temp seg */
	do CYCL = 1 to num_to_cycle;
	     call make_tempsegs;			/* make it */
	     call term_$refname ("mlr_tst", code);
	     call cpu_tests_$mlr_tst (tempseg_ptr(1));
	     call prepare_segment (DELETE);
	end;

exclude12:
	if sel_flag then goto sel_loop;
	if next_test > last_test then goto done;


%page;

/*	TEST 13.	csl_test	*/

/* This test tries a given CSL instruction which fails across a boundsfault boundary */

test (13):
	next_test = 14;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude13;

	if ^brief_sw then call ioa_ ("Test 13^-<csl_test>");

	call set_up_conds (1, "illegal_opcode", "", "");

/* This test, like test 12, interacts with the boundfault mechanism. Similar things are done */
	num_temps = 1;				/* need one temp seg */
	do CYCL = 1 to num_to_cycle;
	     call make_tempsegs;			/* make it */
	     call term_$refname ("csl_test", code);
	     call cpu_tests_$csl_test (test_data1p, tempseg_ptr(1));
	     call prepare_segment (DELETE);
	end;

exclude13:
	if sel_flag then goto sel_loop;
	if next_test > last_test then goto done;

%page;

/*	TEST 14.  cmpc	*/

/* This test tries a given cmpc insruction which fails when hit with */
/* a TRO or connect fault 				*/

test (14):
	next_test = 15;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude14;

	if ^brief_sw then call ioa_ ("Test 14^-<cmpc>");

	call set_up_conds (1, "illegal_opcode", "", "");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call cpu_tests_$cmpc ();
	end;

	call prepare_segment (DELETE);

exclude14:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;
%page;


/*	TEST 15.	bad_fill	*/

/* This test checks to see if an MLR or CMPC that ends in the first 2 words of a new page
   works correctly. */

test (15):
	next_test = 16;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude15;

	if ^brief_sw then call ioa_ ("Test 15^-<bad_fill>");

	call set_up_conds (1, "illegal_opcode", "MLR generating bad fill.", "");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */


	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (TRUNC_and_DEACT);
	     call cpu_tests_$bad_fill (test_data1p, tempseg_ptr(1));
	end;

	call prepare_segment (DELETE);

exclude15:
	if sel_flag then goto sel_loop;
	if next_test > last_test then goto done;

%page;


/*	TEST 16.	mpy_ofl	*/

/* This test checks to see if an overflow fault occurs when the number -2**35 is
   multiplied by itself. An overflow should not occur. */

test (16):
	next_test = 17;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude16;

	if ^brief_sw then call ioa_ ("Test 16^-<mpy_ofl>");

	call set_up_conds (1, "fixedoverflow", "", "");

	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call cpu_tests_$mpy_ofl;
	end;

	call prepare_segment (DELETE);


exclude16:
	if sel_flag then goto sel_loop;
	if next_test > last_test then goto done;

%page;

/* 	TEST 17.	test_xed	*/

/* This test checks a particular XED sequence which fails to do the proper indexing
   in the executed instructions. */

test (17):
	next_test = 18;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude17;

	if ^brief_sw then call ioa_ ("Test 17^-<test_xed>");

	call set_up_conds (1, "illegal_opcode", "XED did not index properly.", "");

	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call cpu_tests_$test_xed;
	end;

	call prepare_segment (DELETE);


exclude17:
	if sel_flag then goto sel_loop;
	if next_test > last_test then goto done;

%page;

/*	TEST 18.	cmpc7	*/

/* This test checks a particular cmpc use where both strrings are 7 words from the end of a page */

test (18):
	next_test = 19;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude18;

	if ^brief_sw then call ioa_ ("Test 18^-<cmpc7>");

	call set_up_conds (1, "illegal_opcode", "", "");

	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call cpu_tests_$cmpc7 (test_data1p);
	end;

	call prepare_segment (DELETE);


exclude18:
	if sel_flag then goto sel_loop;
	if next_test > last_test then goto done;

%page;

/*	TEST 19.	extra_fill	*/

/* This test checks to see if extra fill characters are placed after a string moved by an MLR which
   starts 6 words from the end of a page */

test (19):
	next_test = 20;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude19;

	if ^brief_sw then call ioa_ ("Test 19^-<extra_fill>");

	call set_up_conds (1, "illegal_opcode", "MLR causing extra fill.", "");

	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */


	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (TRUNC_and_DEACT);
	     call cpu_tests_$extra_fill (tempseg_ptr(1));
	end;

	call prepare_segment (DELETE);


exclude19:
	if sel_flag then goto sel_loop;
	if next_test > last_test then goto done;

%page;

/* 	TEST 20.	test_cmpc_fill	*/

/* This test checks that the fill character used in a cmpc instruction is correct */

test (20):
	next_test = 21;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude20;

	if ^brief_sw then call ioa_ ("Test 20^-<test_cmpc_fill>");

	call set_up_conds (1, "illegal_opcode", "", "");

	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call cpu_tests_$test_cmpc_fill;
	end;

	call prepare_segment (DELETE);


exclude20:
	if sel_flag then goto sel_loop;
	if next_test > last_test then goto done;

%page;

/*	TEST 21.	acv_restart	*/

/* This test check that the hardware can successfully restart the machine conditions after an
   access violation fault caused by a reference to data via an EIS (mlr) instruction */

test (21):
	next_test = 22;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude21;

	if ^brief_sw then call ioa_ ("Test 21^-<acv_restart>");

	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	on no_write_permission
	     begin;
		if tries > 1 then do;
		     call ioa_ ("^a (restart did not work  *** HARDWARE FAILING ***)", test_name (next_test - 1));
		     if ^no_display_mc then /* are we in brief mode? */ call display_mc;
						/* no go print out the machine conditions */
		     revert no_write_permission;
		     go to exclude21;
		     end;
		ACL.access_name = get_group_id_ ();
		ACL.modes = "101"b;
		pdir = get_pdir_ ();
		call hcs_$add_acl_entries (pdir, "testcpu_tempseg_1", addr (ACL), 1, code);
		tries = tries + 1;
	     end;

	do CYCL = 1 to num_to_cycle;
	     tries = 0;
	     call prepare_segment (TRUNC_and_DEACT);
	     call cpu_tests_$acv_restart (tempseg_ptr(1));
	end;

	call prepare_segment (DELETE);

exclude21:
	revert no_write_permission;
	if sel_flag then goto sel_loop;
	if next_test > last_test then goto done;

%page;


/* 	TEST 22.	scm_tally */

/* This test attempts to see if the SCM instruction works with the tally runout indicator being
   set correctly. The test calls a small alm program that uses an scm instruction. Sometimes the hardware
   fails -- sometimes it doesn't. Therefore the test is run 100 times to get a slight statistical
   sampling */

test (22):
	next_test = 23;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude22;

	if ^brief_sw then call ioa_ ("Test 22^-<scm_tally>");

	call set_up_conds (1, "illegal_opcode", "SCM failed to set the tally runout indicator.", "");

	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     sum = 0;
	     call prepare_segment (TRUNC_and_DEACT);
	     do i = 1 to 100;
		call prepare_segment (DEACT);
		call cpu_tests_$scm_tally (tempseg_ptr(1));
	     end;
	end;

	call prepare_segment (DELETE);

exclude22:
	if sel_flag then goto sel_loop;
	if next_test > last_test then goto done;

%page;

/* test 23. mvt_ascii_to_bcd */
/*
   This test checks nine to six (ascii to bcd) conversion using the MVT instruction. A large ascii data
   segment  is  generated  and  a  subsequent  bcd segment is generated using non EIS conversion. Three
   segments are then converted from ascii to bcd, using the MVT  instruction  and  these  segments  are
   compared  to  the  known  good bcd segment. If any compare errors are detected, the contents of both
   segments are dumped in octal at the failing location.
*/

test (23):
	next_test = 24;
	mvtr_sw = "1"b;				/* set release switch */
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude23;

	if ^brief_sw then call ioa_ ("Test 23^-<mvt_ascii_to_bcd>");

	call set_up_conds (0, "", "", "");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call cpu_tests_$mvt_tst_ascii_to_bcd;
	end;

	call prepare_segment (DELETE);

exclude23:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;

%page;

/* test 24. mvt_six_to_nine */
/*
   This test checks six to nine (bcd to ascii) conversion using the MVT instruction. A large ascii data
   segment  is generated and then a bcd segment is generated, converting the ascii segment with non EIS
   code. The known good bcd segment is then converted to ascii, using the MVT instruction, into 3 large
   segments.  The  3  converted  segments  are  then  compared to the original ascii segment and if any
   descrepencies are found the contents of both segments are dumped in octal at the failing location.
*/

test (24):
	mvtr_sw = "1"b;				/* set release switch */
	next_test = 25;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude24;

	if ^brief_sw then call ioa_ ("Test 24^-<mvt_bcd_to_ascii>");

	call set_up_conds (0, "", "", "");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call cpu_tests_$mvt_tst_bcd_to_ascii;
	end;

	call prepare_segment (DELETE);


exclude24:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;

%page;

/* test 25. mvt_nine_to_four */
/*
   This test checks 9 bit to 4 bit (decimal to packed decimal) conversion using the MVT instruction.  A
   large  segment of data is generated containing 9 bit charaters with a value of 0 to 15 in a rotating
   pattern. Then a second segment if generated, converting the 9 bit characters into 4  bit  characters
   using  non  EIS  conversion techniques. The 9 bit data is then converted to 4 bit data using the MVT
   instruction, into 3 segments and this converted data is compared to the known good 4  bit  data.  If
   any descrepencies are found, the contents of both segments are dumped in octal at the failing.
*/

test (25):
	next_test = 26;
	mvtr_sw = "1"b;				/* set release switch */
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude25;

	if ^brief_sw then call ioa_ ("Test 25^-<mvt_nine_to_four>");

	call set_up_conds (0, "", "", "");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call cpu_tests_$mvt_tst_nine_to_four;
	end;
	call prepare_segment (DELETE);

exclude25:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;

%page;

/* test 26 */
/*
   This test checks 4 bit to 9 bit (packed decimal to decimal ) conversion using the MVT instruction. 9
   bit  and  4  bit data segments are generated using non EIS conversion as described in test 25. The 4
   bit data is then converted to 9 bit with an MVT instruction into 3 segments. The 3 segments are then
   compared  to  the  original  9  bit  segment.  If  any descrepencies are found, the contents of both
   segments are dumped in octal ato the failing location.
*/

test (26):
	next_test = 27;
	mvtr_sw = "1"b;				/* set release switch */
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude26;

	if ^brief_sw then call ioa_ ("Test 26^-<mvt_four_to_nine>");

	call set_up_conds (0, "", "", "");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call cpu_tests_$mvt_tst_four_to_nine;
	end;
	call prepare_segment (DELETE);

exclude26:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;

%page;

/* test 27. mvt_ascii_to_ebcdic */
/*
   This test checks nine to nine (ascii to ebcdic) character conversion using the  MVT  instruction.  A
   large  ascii  segment  is  generated  and  then  this  segment  is converted to ebcdic using non EIS
   techniques. The ascii segment is then converted  into  3  segments  using  a  MVT  instruction.  The
   resultant  ebcdic  segments  are  compared to the know good ebcdic segment. If any descrepencies are
   found, the contents of both segments are dumped at the failing location.
*/

test (27):
	next_test = 28;
	mvtr_sw = "1"b;				/* set release switch */
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude27;

	if ^brief_sw then call ioa_ ("Test 27^-<mvt_ascii_to_ebcdic>");

	call set_up_conds (0, "", "", "");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call cpu_tests_$mvt_tst_ascii_to_ebcdic;
	end;
	call prepare_segment (DELETE);

exclude27:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;

%page;

/* test 28. mvt_ebcdic_to_ascii */
/*
   This test checks nine to nine (ebcdic to ascii) character  conversion  using  the  MVT  instruction.
   Large  ascii  and  ebcdic segments are generated using non EIS conversion techniques as described in
   test 27. The known good ebcdic segment is converted to  ascii  using  the  MVt  instruction  into  3
   segments.  The  known  good  ascii  segment  is  compared  with  the  3  converted  segments. If any
   descrepencies are found, the contents of both segments are dumped in octal at the failing location.
*/

test (28):
	next_test = 29;
	mvtr_sw = "1"b;				/* Set release switch */
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude28;

	if ^brief_sw then call ioa_ ("Test 28^-<mvt_ebcdic_to_ascii>");

	call set_up_conds (0, "", "", "");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call cpu_tests_$mvt_tst_ebcdic_to_ascii;
	end;
	call prepare_segment (DELETE);

exclude28:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;

%page;

/* test 29. ci_mod_case_2 */
/*
   This test checks character indirect modification with 2 tally words and  2  data  character  strings
   each located at a page boundary. A LDA instruction is executed on one tally word with ci mod, a cmpa
   is executed with a second tally word, ci mod. Both tally words point to a char. string  that  should
   be  equal.  If the zero indicator does not come on as a result of the cmpa, a ZOP fault is taken and
   the test failed. */

test (29):
	next_test = 30;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude29;

	if ^brief_sw then call ioa_ ("Test 29^-<ci_mod_case_2>");

	call set_up_conds (1, "illegal_opcode", "", "");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (TRUNC_and_DEACT);
	     call cpu_tests_$ci_mod_case_2 (tempseg_ptr (1));
	end;
	call prepare_segment (DELETE);

exclude29:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;

%page;

/*	TEST 30.	acv_restart_csl	*/

/* This test check that the hardware can successfully restart the machine conditions after an
   access violation fault caused by a reference to data via an EIS (csl) instruction */

test (30):
	next_test = 31;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude30;

	if ^brief_sw then call ioa_ ("Test 30^-<acv_restart_csl>");

	call set_up_conds (0, "", "", "");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	on no_write_permission
	     begin;
		if tries > 1 then do;
		     call ioa_ ("restart did not work  *** HARDWARE FAILING ***");
		     if ^no_display_mc then /* are we in brief mode? */ call display_mc;
						/* no go print out the machine conditions */
		     revert no_write_permission;
		     goto exclude30;
		     end;
		ACL.access_name = get_group_id_ ();
		ACL.modes = "101"b;
		pdir = get_pdir_ ();
		call hcs_$add_acl_entries (pdir, "testcpu_tempseg_1", addr (ACL), 1, code);
		tries = tries + 1;
	     end;

	do CYCL = 1 to num_to_cycle;
	     tries = 0;
	     call prepare_segment (TRUNC_and_DEACT);
	     call cpu_tests_$acv_restart_csl (tempseg_ptr (1));
	end;
	call prepare_segment (DELETE);


exclude30:
	revert no_write_permission;
	if sel_flag then goto sel_loop;
	if next_test > last_test then goto done;

%page;

/* test 31. cmpn_tst */
/* This test checks that numeric data moved with a mvn instruction can be successfully compared
   with a cmpn instruction. */

test (31):
	next_test = 32;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude31;

	if ^brief_sw then call ioa_ ("Test 31^-<cmpn_tst>");

	call set_up_conds (1, "illegal_opcode", "", "");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (TRUNC_and_DEACT);
	     call cpu_tests_$cmpn_tst (tempseg_ptr (1));
	end;
	call prepare_segment (DELETE);

exclude31:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;
%page;

/*	TEST 32. itp_mod */

/* This test checks that an epp2,* to a word pair tahat  contains an itp modifier
   with a bit offset actually loads pr2 with the correct information */


test (32):
	next_test = 33;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude32;

	if ^brief_sw then call ioa_ ("Test 32^-<itp_mod>");

	call set_up_conds (1, "illegal_opcode", "", "");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call cpu_tests_$itp_mod;
	end;
	call prepare_segment (DELETE);

exclude32:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;

%page;


test (33):
	next_test = 34;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude33;

	if ^brief_sw then call ioa_ ("Test 33^-<mvnoosb>");

	call set_up_conds (1, "out_of_bounds", "Pre-page (FPTW2) logic not working.", "");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (TRUNC_and_DEACT);
	     call cpu_tests_$mvnoosb (tempseg_ptr (1));
	end;
	call prepare_segment (DELETE);

exclude33:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;

%page;

test (34):
	next_test = 35;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude34;

	if ^brief_sw then call ioa_ ("Test 34^-<cmpb_with_sixbit_offset>");

	call set_up_conds (0, "", "", "");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (TRUNC_and_DEACT);
	     call cpu_tests_$cmpb_with_sixbit_offset (tempseg_ptr (1));
	end;
	call prepare_segment (DELETE);

exclude34:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;

%page;

test (35):
	next_test = 36;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude35;

	if ^brief_sw then call ioa_ ("Test 35^-<cmpb_with_rotate>");

	call set_up_conds (0, "", "", "");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (TRUNC_and_DEACT);
	     call cpu_tests_$cmpb_with_rotate (tempseg_ptr (1));
	end;
	call prepare_segment (DELETE);

exclude35:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;
%page;


/*	TEST 36. cmpc_pgbnd (cmpc fails on page bound when one string is zero length) */

/* This tests a CMPC instruction at seg|1767 (octal) for 38 chars against a 0 length string
   with blank fill. */

test (36):
	next_test = 37;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude36;

	if ^brief_sw then call ioa_ ("Test 36^-<cmpc_pgbnd>");

	call set_up_conds (1, "illegal_opcode", "", "");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (TRUNC_and_DEACT);
	     call cpu_tests_$cmpc_pgbnd (tempseg_ptr (1));
	end;
	call prepare_segment (DELETE);

exclude36:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;

%page;


/*	TEST 37. csl_pgflt (csl gets no_write_perm if page faults on target & source is read-only */

test (37):
	next_test = 38;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude37;

	if ^brief_sw then call ioa_ ("Test 37^-<csl_pgflt>");

	call set_up_conds (1, "no_write_permission", "", "");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (TRUNC_and_DEACT);
	     call cpu_tests_$csl_pgflt (tempseg_ptr (1));
	end;
	call prepare_segment (DELETE);

exclude37:
	if sel_flag then goto sel_loop;
	if next_test > last_test then goto done;

%page;


/*	TEST 38.  scm_pgflt (trouble with SCM instruction when operand gets a pagefault) */

test (38):
dcl  scm_str char (1044449) based (tempseg_ptr (1));
dcl  start fixed bin (21) init (143242);


	next_test = 39;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude38;

	if ^brief_sw then call ioa_ ("Test 38^-<scm_pgflt>");

	call set_up_conds (1, "illegal_opcode", "", "");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     substr (scm_str, start, 132) = "";
	     substr (scm_str, start + 132, 1) = "
";						/* a new line */

	     do i = 1 to 500;
		call prepare_segment (DEACT);
		call cpu_tests_$scm_pgflt (tempseg_ptr (1));
	     end;
	end;
	call prepare_segment (DELETE);

exclude38:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;

%page;


/*	TEST 39.	scd_con_flt (SCD fails very rarely when interrupted by connect fault(?)) */

test (39):
	next_test = 40;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude39;

	if ^brief_sw then call ioa_ ("Test 39^-<scd_conflt>");

	call set_up_conds (1, "illegal_opcode", "", "");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call cpu_tests_$scd_con_flt;
	end;
	call prepare_segment (DELETE);

exclude39:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;

%page;
/*        TEST 40. xed_dirflt_even (xed on an even word bound executes the second instr
   of the op pair twice when a dir'd flt occurs on the second op.) */

test (40):
	next_test = 41;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude40;

	if ^brief_sw then call ioa_ ("Test 40^-<xed_dirflt_even>");

	call set_up_conds (1, "illegal_opcode", "", "PHAFPG174/175/934");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (TRUNC_and_DEACT);
	     call cpu_tests_$xed_dirflt_even (tempseg_ptr (1));
	end;
	call prepare_segment (DELETE);

exclude40:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;
%page;


/*        TEST 41. xed_dirflt_odd (xed on an odd word bound skips the second instr
   of the op pair when a dir'd flt occurs on the first? op.) */

test (41):
	next_test = 42;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude41;

	if ^brief_sw then call ioa_ ("Test 41^-<xed_dirflt_odd>");

	call set_up_conds (1, "illegal_opcode", "", "PHAFPG174/175/934");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (TRUNC_and_DEACT);
	     call cpu_tests_$xed_dirflt_odd (tempseg_ptr (1));
	end;
	call prepare_segment (DELETE);

exclude41:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;
%page;


/*        TEST 42. CMPC falsely sets the zero indicator if D2 takes a fault
   and has residue (MIF flag on), d2 (4'th fetch takes a fault).
   The level count on D2 does not get adjusted correctly on the SP&L */

test (42):
	next_test = 42;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude42;

	if ^brief_sw then call ioa_ ("Test 42^-<cmpc_adj_len>");

	call set_up_conds (1, "illegal_opcode", "", "");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (TRUNC_and_DEACT);
	     call cpu_tests_$cmpc_adj_len (tempseg_ptr (1));
	end;
	call prepare_segment (DELETE);

exclude42:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;
%page;


/*        TEST 43. CMPC fails to set the zero indicator after returning from
   a page fault on d2. */

test (43):
	next_test = 44;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude43;

	if ^brief_sw then call ioa_ ("Test 43^-<cmpc_zero_ind>");

	call set_up_conds (1, "illegal_opcode", "", "PHAFPG192,193,194");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (TRUNC_and_DEACT);
	     call cpu_tests_$cmpc_zero_ind (tempseg_ptr (1));
	end;
	call prepare_segment (DELETE);

exclude43:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;


%page;


/*        TEST 44. SCM fails to find the correct char (sets the tro and it
   should not  (simulate pl1 statment:
   index (collate (), aray_char (i));  */

test (44):
	next_test = 45;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude44;

	if ^brief_sw then call ioa_ ("Test 44^-<scm_tro>");

	call set_up_conds (1, "illegal_opcode", "", "");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */
	call prepare_segment (DEACT);			/* set it set up to deactivae before we use it */

          temp_data_size = 200;
	tempseg_ptr (1) -> temp_data = collate ();
	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (DEACT);
	     call cpu_tests_$scm_tro (tempseg_ptr (1));
	end;
	call prepare_segment (DELETE);

exclude44:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;


%page;


/*        TEST 45. RPT at odd location fails after a page fault on a stz when crossing page bound */

test (45):
	next_test = 46;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude45;

	if ^brief_sw then call ioa_ ("Test 45^-<rpt_test_odd>");

	call set_up_conds (1, "lockup", "", "");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (DEACT);
	     call cpu_tests_$rpt_test_odd (tempseg_ptr (1));
	end;
	call prepare_segment (DELETE);


exclude45:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;


%page;


/*        TEST 46. RPT at even location fails after a page fault on a stz when crossing page bound */

test (46):
	next_test = 47;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude46;

	if ^brief_sw then call ioa_ ("Test 46^-<rpt_test_evn>");

	call set_up_conds (1, "no_write_permission", "", "");
	num_temps = 1;				/* need one temp seg */
	call make_tempsegs;				/* make it */

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (DEACT);
	     call cpu_tests_$rpt_test_evn (tempseg_ptr (1));
	end;
	call prepare_segment (DELETE);


exclude46:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;


%page;


/*        TEST 47 scd_oob_tst. The SCD would fail if arg (d3) resided in a
   different segment than D1 or D2 AND there was no match, AND the scan ended
   a few words from the end of a 64K seg AND a seg fault was taken on the seg
   described by d3. This failed on a L68.
   The failure manifested itself by continuing the scan 'till the seg grew > 256K */

test (47):
	next_test = 48;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude47;

	if ^brief_sw then call ioa_ ("Test 47^-<scd_oob_tst>");

	call set_up_conds (2, "out_of_bounds,illegal_opcode", "", "PHAFPG192,193,194");

	num_temps = 2;				/* this test requires 2 temp_segs */
	call make_tempsegs;				/* make it */

	call hcs_$set_max_length_seg (tempseg_ptr (2), 1024 * 64, code);
						/* make max len 64k so mct will have a chance to capture pertinent info */
	call prepare_segment (DEACT);

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (DEACT);
	     call term_$refname ("scd_oob_tst", code);
	     call cpu_tests_$scd_oob_tst(tempseg_ptr (1), tempseg_ptr(2));
	end;
	call prepare_segment (DELETE);

exclude47:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;

%page;


/*    TEST 48 cmpb_onc.
      with the right magic numbers the cmpb will onc without the correct fix.
*/

test (48):
	next_test = 48+1;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude48;

	if ^brief_sw then call ioa_ ("Test 48^-<cmpb_onc>");

	call set_up_conds (2, "op_not_complete,illegal_opcode", "For DPS8M", "PHAOPD369");

	num_temps = 1;

	call make_tempsegs;				/* make it */
	call prepare_segment (DEACT);

/* setup the needed data using the magic numbers */

	temp_data_ptr = addrel(tempseg_ptr (1),1459);
	temp_data_size = 70;
	do i = 1 to temp_data_size;
	   temp_words(i) = "777777777777"b3;
	   end;
	

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (DEACT);
	     call cpu_tests_$cmpb_onc (tempseg_ptr (1));
	end;
	call prepare_segment (DELETE);

exclude48:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;

%page;


/*        TEST 49 cmpc_a.
          With the correct magic numbers and data a cmpc will not set 
	the indicators correctly
*/

test (49):
	next_test = 49+1;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude49;

	if ^brief_sw then call ioa_ ("Test 49^-<cmpc_a>");

	call set_up_conds (1, "illegal_opcode", "", "FPG194");

	num_temps = 1;

	call make_tempsegs;				/* make it */
	call prepare_segment (DEACT);

/*      use the correct magic numbers and data */
	temp_data_size = 253;
	temp_data_ptr = addrel(tempseg_ptr(1),4402);
	temp_data = "101";

	temp_data_size = 3921;
	temp_data_ptr = addrel(tempseg_ptr(1),254480);
	temp_data = "101";
	

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (DEACT);
	     call cpu_tests_$cmpc_a (tempseg_ptr (1));
	end;
	call prepare_segment (DELETE);

exclude49:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;

%page;


/*        TEST 50 cmpc_b.
          With the correct magic numbers and data a cmpc will not set 
	the indicators correctly. Very similar to test 49.
*/

test (50):
	next_test = 50+1;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude50;

	if ^brief_sw then call ioa_ ("Test 50^-<cmpc_b>");

	call set_up_conds (1, "illegal_opcode", "", "FPG195,FPD358");

	num_temps = 1;

	call make_tempsegs;				/* make it */
	call prepare_segment (DEACT);

/*      use the correct magic numbers and data */
	temp_data_size = 253;
	temp_data_ptr = addrel(tempseg_ptr(1),4402);
	temp_data = "102";

	temp_data_size = 3921;
	temp_data_ptr = addrel(tempseg_ptr(1),254670);
	temp_data = "102";
	

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (DEACT);
	     call cpu_tests_$cmpc_b (tempseg_ptr (1));
	end;
	call prepare_segment (DELETE);

exclude50:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;

%page;


/*        TEST 51 sreg_no_write.
          If an sreg at page bound -2 the PSR segment number will be used
	instead of the TRS if fix not installed.
	Test  sreg_no_write dose not use a temp seg.
*/

test (51):
	next_test = 51+1;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude51;

	if ^brief_sw then call ioa_ ("Test 51^-<sreg_no_write>");

	call set_up_conds (1, "no_write_permission", "", "FPD312");

	do CYCL = 1 to num_to_cycle;
	     call cpu_tests_$sreg_no_write;
	end;

exclude51:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;

%page;


/*        TEST 52 tnz.
          Without fix a tnz at page bound -1 will not work
*/

test (52):
	next_test = 52+1;
	if excl_list (next_test - 1) = next_test - 1 then /* exclude this test? */ go to exclude52;

	if ^brief_sw then call ioa_ ("Test 52^-<tnz>");

	call set_up_conds (1, "illegal_opcode", "", "FPD354");

	num_temps = 1;

	call make_tempsegs;				/* make it */
	call prepare_segment (DEACT);

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (DEACT);
	     call cpu_tests_$tnz (tempseg_ptr (1));
	end;
	call prepare_segment (DELETE);

exclude52:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;
%page;

/* END OF TESTS */
%page;
/*****************************************************************************/
/*  This is an example for adding test cases			       */
/*							       */
/*        TEST XX TEST_NAME.					       */
/*	What it tries to test if known.			       */
/*							       */
/*****************************************************************************/
/*
test (XX):
	next_test = XX+1;

 "**** exclude this test? **** "
	if excl_list (next_test - 1) = next_test - 1 then go to excludeXX;

	if ^brief_sw then call ioa_ ("Test XX^-<TEST_NAME>");

	call set_up_conds (NUM_OF_COND, "LIST_OF_COND", "", "FCO_LIST");

	num_temps = NUMBER_OF_TEMPSEGS;

	call make_tempsegs;			" **** make it **** "
	call prepare_segment (ACTION);

 " *****  any special data is placed here ***** "

	do CYCL = 1 to num_to_cycle;
	     call prepare_segment (ACTION);
	     call cpu_tests_$TEST_NAME (ARGLIST);
	end;
	call prepare_segment (DELETE);

excludeXX:
	if sel_flag then goto sel_loop;
	if next_test > last_test then go to done;
*/
%page;


/* This procedure creates the temp seg(s) to be used by all test cases and set up for deactivation. */

make_tempsegs:
     proc;

dcl  i fixed bin;


	do i = 1 to num_temps;
	     STR = ltrim (rtrim (char (i)));
	     call hcs_$make_seg ("", "testcpu_tempseg_" || STR, "testcpu_tempseg_" || STR, 1111b, tempseg_ptr (i), code)
		;

	     if tempseg_ptr (i) = null () then do;

notempseg:
		call com_err_ (code, "test_cpu", "Cannot get ptr to temporary segment.");
		return;
		end;

	     unspec (akst) = "0"b;			/* set up KST so we can deactivate the tempseg */
	     akst.set.explicit_deactivate_ok, akst.value.explicit_deactivate_ok = "1"b;

	     on no_read_permission
		begin;
link_err:
		     call com_err_ (0, (myname), "test_cpu requires access to >sl1>phcs_.");
		     go to done;
		end;

	     call phcs_$set_kst_attributes (fixed (baseno (tempseg_ptr (i)), 17), addr (akst), code);
						/* now set permissions */

	     revert no_read_permission;

	     call phcs_$deactivate (tempseg_ptr (i), code);
						/* do it now before its touched */
	     if code ^= 0 then do;			/* just quit */
		call com_err_ (code, myname, "Call to deactivate failed.");
		return;
		end;

	end;
	return;
     end;


%page;
prepare_segment:
     proc (operation);

dcl  operation fixed bin;
dcl  idx fixed bin;

	go to OP (operation);

OP (1):						/* truncate & deactivate */
	do idx = 1 to num_temps;
	     call hcs_$truncate_seg (tempseg_ptr (idx), 0, code);
	     if code ^= 0 then do;			/* just quit */
		call com_err_ (code, myname, "Call to truncate failed.");
		return;
		end;

	     call phcs_$deactivate (tempseg_ptr (idx), code);
						/* do it now before its touched */
	     if code ^= 0 then do;			/* just quit */
		call com_err_ (code, myname, "Call to deactivate failed.");
		return;
		end;
	end;

	return;

OP (2):						/* delete */
	do idx = 1 to num_temps;
	     call delete_$ptr (tempseg_ptr (idx), "100101"b, "test_cpu", code);
	end;
	return;

OP (3):						/* truncate only */
	do idx = 1 to num_temps;
	     call hcs_$truncate_seg (tempseg_ptr (idx), 0, code);
	end;
	return;

OP (4):						/* deactivate only */
	do idx = 1 to num_temps;
	     call phcs_$deactivate (tempseg_ptr (idx), code);

	     if code ^= 0 then do;			/* just quit */
		call com_err_ (code, myname, "Call to deactivate failed.");
		return;
		end;
	end;
	return;

     end prepare_segment;


%page;

/* This routine is used by those test cases that need to deactivate the temp seg */

test_cpu$deactivate_tempseg:
     entry;

dcl  idx fixed bin;


	do idx = 1 to num_temps;
	     call phcs_$deactivate (tempseg_ptr (idx), code);
						/* do it now before its touched */
	     if code ^= 0 then do;			/* just quit */
		call com_err_ (code, myname, "Call to deactivate failed.");
		return;
		end;
	end;

	return;

%page;
done:
	call CLEANUP;

	return;

CLEANUP:
     proc;
dcl  idx fixed bin;

	if mvtr_sw then /* if mvt release switch set go release temp segs */ call cpu_tests_$mvt_tst_release_t_segs;

	do idx = 1 to 3;
	     if tempseg_ptr (idx) ^= null then call delete_$ptr (tempseg_ptr (idx), "100101"b, "test_cpu", code);
	end;

	if ^hreg_state then /* leave hreg state the way it was */ call hcs_$history_regs_set ("0"b);
	return;

     end CLEANUP;
%page;
display_mc:
     proc;

	call cu_$stack_frame_ptr (stackp);		/* get current sstack ptr */
	faultsp = find_condition_frame_ (stackp);	/* is this the cond frame ? */
	if faultsp = null () then do;
	     call ioa_ ("^a: Cannot find condition frame.", myname);
	     return;
	     end;

	call find_condition_info_ (faultsp, addr (cond_info), code);
	if cond_info.mcptr = null () then return;

	if ^mc_sw then go to HREGS;
	call ioa_ ("^/MACHINE CONDITIONS AT ^p:^/", cond_info.mcptr);
	call dump_machine_cond_ (addr (cond_info), faultsp, "user_output", 2);
						/* print the MC */

HREGS:
	if ^h_sw then return;
	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_sw);
	     end;

	return;
     end display_mc;
%page;

/* This procedure will establish the number of, and type of conditions
   expected for each test case and any additional info that may be helpful
   to a user when a test case fails, including FCO(s) that may be required. */

set_up_conds:
     proc (num_to_expect, conds, add_info, fco_info);

dcl  (num_to_expect, idx, start_idx, end_idx) fixed bin;
dcl  (conds, add_info, fco_info) char (256) var;

	num_expected_cond = num_to_expect;
	start_idx = 1;				/* init for first pass */
	do idx = 1 to num_to_expect;
	     end_idx = index (substr (conds, start_idx), ",");

	     if end_idx ^= 0 then			/* not the last condition name */
		expected_condition (idx) = substr (conds, start_idx, end_idx - 1);
	     else expected_condition (idx) = substr (conds, start_idx, (length (conds) - start_idx + 1));
	     start_idx = end_idx + start_idx;
	end;

	pertinent_info = add_info;
	if fco_info ^= "" then
	     FCO_required = "FCO(s) " || fco_info || " MUST be installed for this test to run sucessfully.";
	else FCO_required = "";
	return;

     end set_up_conds;

     end test_cpu;
  



		    test_speed.alm                  11/15/82  1905.9rew 11/15/82  1535.3       58617


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

	name	test_speed
	entry	test_speed

"
"	This subroutine times 15 different code sequences for the "instr_speed"
"	command. The call is:
"
"	call test_speed (type, time, long_run, cutoff, page_faults, instr_count, temp_segp)
"
"	type	is from 1 to 12 and selects the instructions to time
"	time	is the time to execute the instructions
"	long_run	is non-zero if the run took what is probably too long
"		(probably due to interrupt)
"	cutoff	time limit that instructions must finish by
"	page_faults is currently returned as zero (can't happen?)
"	instr_count is the number of instructions executed.
"	temp_segp is a temporary segment for running this impure program
"
"	The 15 types are as follows:
"
"	1)	lda	even
"		sta	odd
"
"	2)	lda	odd
"		sta	even
"
"	3)	lda
"		lda
"		lda
"
"	4)	lda	even	bit 29
"		sta	odd	bit 29
"
"	5)	eppbp	even
"		spribp	odd
"
"	6)	eppbp	odd
"		spribp	even
"
"	7)	eppbp	even	indirect
"		spribp	odd
"
"	8)	eppbp	odd	indirect
"		spribp	even
"
"	9)	eppbp	even	bit 29
"		spribp	odd	bit 29
"
"	10)	eppbp	even	bit 29 indirect
"		spribp	odd	bit 29
"
"	11)	eppbp	odd	bit 29 indirect
"		spribp	even	bit 29
"
"	12)	random mix
"
"	13)	lda	0,du
"		lda	0,du
"		lda	0,du
"
"	14)	nop	0,du
"		nop	0,du
"		nop	0,du
"
"	15)	lprpbp	even	bit 29
"		sprpbp	odd	bit 29
"
"
"	The origin of this program is unknown, as it predates
"	recorded history.  It was unearthed by J. Bongiovanni
"	in June 81 while excavating in the Trouble REport
"	system.  It was modified to use ALM instead of mexp,
"	to run the timing loops inhibited, and to run the
"	impure code in a temporary segment
"
" " " " " " " " " " " " " " " " " " " " " " " " " "

	equ	loops_1,20
	equ	loops_2,20
	equ	loops_3,20
	equ	loops_4,20
	equ	loops_5,20
	equ	loops_6,20
	equ	loops_7,20
	equ	loops_8,20
	equ	loops_9,20
	equ	loops_10,20
	equ	loops_11,20
	equ	loops_12,20
	equ	loops_13,20
	equ	loops_14,20
	equ	loops_15,20

	equ	count_1,50
	equ	count_2,50
	equ	count_3,50
	equ	count_4,50
	equ	count_5,50
	equ	count_6,50
	equ	count_7,50
	equ	count_8,50
	equ	count_9,50
	equ	count_10,50
	equ	count_11,50
	equ	count_12,50
	equ	count_13,50
	equ	count_14,50
	equ	count_15,50

	macro	type_gen

type_&1:
	eax1	loops_&1

	inhibit	on	<+><+><+><+><+><+><+><+><+><+><+><+><+><+><+>

	even
	rccl	ab|0,*
	staq	time_start
type_&1_loop:
dup	25
	&2	&3
	&4	&5
dupend
	eax1	-1,1
	tnz	type_&1_loop
	rccl	ab|0,*

	inhibit	off	<-><-><-><-><-><-><-><-><-><-><-><-><-><-><->
	
	sbaq	time_start
	cmpq	instr_limit-1,0
	tmi	*+2
	aos	ap|6,*
	staq	ap|4,*
	return

&end

test_speed:

"	copy code to temp segment provided, since code is impure

	epplb	ap|14,*		pointer to pointer to temp segment
	epbplb	lb|0,*		lb -> temp segment
	eax0	copy_begin	relocated begin address
	epplb	lb|0,0		within temp segment
	epbpab	*		ab -> base of procedure segment
	eppab	ab|0,0		ab -> begin of code to copy
	mlr	(pr),(pr)		move the code
	desc9a	ab|0,copy_chars
	desc9a	lb|0,copy_chars
	eppab	sys_info$clock_	copied code doesn't have linkage section
	epbplb	lb|0		lb -> base of temp segment
	eax0	test_speed_join	where to pick up execution
	tra	lb|0,0		off into impure land (what trouble)
	
copy_begin: 			" begin of code to copy
test_speed_join: 			" execution picks up here
	push
	lxl0	ap|2,*		get instruction type
	ldq	instr_count-1,0	get number of instructions in loop
	stq	ap|12,*		return value to caller

	stz	ap|6,*		assume no long sample
	stz	ap|10,*		no page faults


	ldq	instr_limit-1,0	get probably limit on execution time
	stq	ap|8,*		return to caller

	eppbp	data
	spribp	data
	spribp	data+2
	eppbb	data+2
	sprpbp	data+7
	tra	subr-1,0*		go to routine for "type" test

subr:
	arg	type_1
	arg	type_2
	arg	type_3
	arg	type_4
	arg	type_5
	arg	type_6
	arg	type_7
	arg	type_8
	arg	type_9
	arg	type_10
	arg	type_11
	arg	type_12
	arg	type_13
	arg	type_14
	arg	type_15

	type_gen	1,lda,data,sta,data+1
	type_gen	2,sta,data,lda,data+1
	type_gen	3,lda,data,lda,data+2
	type_gen	4,lda,bp|0,sta,bb|0
	type_gen	5,eppbp,data,spribp,data+2
	type_gen	6,spribp,data,eppbp,data+2
	type_gen	7,eppbp,(data,*),spribp,data+2
	type_gen	8,spribp,data+2,eppbp,(data,*)
	type_gen	9,eppbp,(bp|0),spribp,(bb|0)
	type_gen	10,eppbp,(bp|0,*),spribp,(bb|0)
	type_gen	11,spribp,bb|0,eppbp,(bp|0,*)
	type_gen	13,lda,(0,du),lda,(0,du)
	type_gen	14,nop,(0,du),nop,(0,du)
	type_gen	15,lprpbp,data+7,sprpbp,data+7

type_12:
	eax1	loops_12

	inhibit	on	<+><+><+><+><+><+><+><+><+><+><+><+><+><+><+>
	
	even
	rccl	ab|0,*
	staq	time_start
type_12_loop:
	eppbp	data,*
	spribp	data+2
	eppbp	data
	spribp	data+2
	lda	data
	als	9
	cana	=o400,du
	tnz	*+1
	fld	0,dl
	fad	=1e2
	fst	data+4
	eppbp	data+4
	eppbp	bp|0
	lda	bp|0
	sta	data+4
	stz	data+5
	stz	data+6
	ldq	data+6
	canq	=o777000,dl
	tze	*+2
	nop	0,du
	ldq	data+2,*
	asq	data
	stq	data+2,*
	eppbp	data
	spribp	data+2
	spribp	data
	eppbp	data,*
	spribp	data+2
	eppbp	data
	spribp	data+2
	lda	data
	als	9
	cana	=o400,du
	tnz	*+1
	fld	0,dl
	fad	=1e2
	fst	data+4
	eppbp	data+4
	eppbp	bp|0
	lda	bp|0
	sta	data+4
	stz	data+5
	stz	data+6
	ldq	data+6
	canq	=o777000,dl
	tze	*+2
	nop	0,du
	ldq	data+2,*
	asq	data
	eax1	-1,1
	tnz	type_12_loop
	rccl	ab|0,*

	inhibit	off	<-><-><-><-><-><-><-><-><-><-><-><-><-><-><->
	
	sbaq	time_start
	cmpq	instr_limit-1,0
	tmi	*+2
	aos	ap|6,*
	staq	ap|4,*
	return

instr_count:
	zero	0,(count_1+2)*loops_1+2
	zero	0,(count_2+2)*loops_2+2
	zero	0,(count_3+2)*loops_3+2
	zero	0,(count_4+2)*loops_4+2
	zero	0,(count_5+2)*loops_5+2
	zero	0,(count_6+2)*loops_6+2
	zero	0,(count_7+2)*loops_7+2
	zero	0,(count_8+2)*loops_8+2
	zero	0,(count_9+2)*loops_9+2
	zero	0,(count_10+2)*loops_10+2
	zero	0,(count_11+2)*loops_11+2
	zero	0,(count_12+2)*loops_12+2
	zero	0,(count_13+2)*loops_13+2
	zero	0,(count_14+2)*loops_14+2
	zero	0,(count_15+2)*loops_15+2

instr_limit:
	dec	1200
	dec	1400
	dec	900
	dec	1400
	dec	2000
	dec	2100
	dec	2900
	dec	2800
	dec	2000
	dec	2900
	dec	2800
	dec	1700
	dec	1200
	dec	900
	dec	2400

	even
time_start:
	oct	0,0

data:
	bss	,8

	equ	copy_end,*	end of code to copy
	equ	copy_words,copy_end-copy_begin
	equ	copy_chars,4*copy_words
	
	end
   



		    write_notify_test.pl1           08/06/87  1417.4rew 08/06/87  1305.0      284976


/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(87-05-18,Lippard), approve(87-02-09,MCR7616),
     audit(87-06-03,Farley), install(87-08-06,MR12.1-1064):
     Modified to use hcs_$set_procs_required instead of
     phcs_$set_procs_required.
                                                   END HISTORY COMMENTS */


/* format: style4 */
write_notify_test: proc;

/* Originally coded by R. Fakoury 08/83 */
/* Modified Feb 1984 by Paul Farley to:
   *   add error handling
   *   if called as active_function, return "true" if error occurs
   *   allow tracing of writes and reads
   *   each process will get its own data segment in the pdir
   *   limit testing to a pair of CPUs, one of which must be a DPS8
   * Modified April 1984 by Paul Farley to:
   *   use current working dir for data segs
   *   use seperate data seg for each seperate invokation
   *   use scs$controller_data from ring_0 to define what SCU bad address
   *   is from.
   *   use dseg and sst_seg to find where page is located before reading and
   *   use this to meter SCU usage.
   * Modified May 1984 by Paul Farley to:
   *   remove tracing code
   *   accept more than a pair of CPUs and do the pairing internally
   *   limit to 1 l68, but many 8/70's which will be internally paired
   * Modified MAY 1984 by R. A. Fawcett to:
   *   Use the scs$processor_data instead of the config_deck
   *   Run only on DPS8M cpus if more than one selected.
   *   Meter page addresses
   *   add the -brief and -long arguments
   *   add "some" diagnostics
   *   require hphcs_ access
   *   add the -word_increment argument and change default to 52
   *   change the starting offset in the page at half the loop_count argument
   *   eleminate the use of history regesters
   *
   * Modified OCT 1984 R. A. Fawcett to make active_function work
   *
   * Modified November 1984 by M. Pandolf to include hc_lock.
*/

/* Labels */

dcl  NEXT_READ_LABEL label;

/* Conditions */
dcl  (cleanup, linkage_error) condition;

/* Static */

dcl  error_count fixed bin int static;
dcl  start_of_sst fixed bin (24) aligned int static init (0);


/* Automatic */

dcl  orig_cpus bit (8) aligned;			/* returned value of CPUs required */
dcl  default_flag bit (1) init ("0"b);			/* ON => process has default CPUs required */
dcl  total_mem fixed bin;
dcl  major_loop_error fixed bin;
dcl  sub_loop_error fixed bin;
dcl  word_inc fixed bin init (52);
dcl  foo_len fixed bin (21);
dcl  dseg_ptr ptr init (null);
dcl  (argp, retP) ptr;
dcl  (argl, retL) fixed bin (21);
dcl  AF_sw bit (1) init ("0"b);
dcl  (long_sw, same_bad) bit (1) init ("0"b);
dcl  (arg_no, cpu, i, j, loop, times, n_args, rd, total_l68, total_dps8,
     wrt, cpus_to_test, deact_loop_cnt, pair_idx,
     cpu_st_ind) fixed bin init (0);
dcl  maj_loop_max fixed bin init (10);
dcl  sub_loop_max fixed bin init (12);
dcl  maj_max_err_count fixed bin;
dcl  sub_max_err_count fixed bin;
dcl  bit_bucket bit (36);
dcl  code fixed bin (35) init (0);
dcl  (HAD_ERROR, phcs_ok, meter_sw, testing_sw, need_page_meter, need_revert_cpu) bit (1) init ("0"b);
dcl  check_cpu_string char (8) varying aligned init ("");
dcl  (dps8_cpu, l68_cpu, test_cpu_string) char (8) init ("");

dcl  pattern bit (36) aligned;
dcl  (data_page, meter_idx) fixed bin;
dcl  mem_meters (0:8) fixed bin (71) aligned;
dcl  1 data_sdw aligned like sdw;
dcl  1 data_ptw aligned like ptw;
dcl  1 last_ptw aligned like ptw;
dcl  1 mem_data (0:7) aligned like scs$controller_data;
dcl  1 processor_data (0:7) aligned like scs$processor_data;
dcl  DPS8M fixed bin (2) unsigned init (1) static options (constant);
dcl  who_ami char (18) init ("write_notify_test") static options (constant);
dcl  1 pair_sets (4),
       2 pair char (2),
       2 set (2),
         3 cpu_bits bit (8) aligned,
         3 is_dps8 bit (1) aligned;
dcl  number_of_pairs fixed bin;
dcl  inc_start fixed bin (17) init (0);
dcl  inc_time fixed bin (17);
dcl  high_wc fixed bin;
dcl  acc_var entry variable;

dcl  wct_offset fixed bin;
dcl  pages_used (0:total_mem) fixed bin (35) based (pages_ptr);
dcl  pages_ptr ptr;
dcl  error_data_ptr ptr init (null);
dcl  (address_lines, page_add_lines) bit (36);
dcl  (bad_cpu, bad_scu) fixed bin;
dcl  pat_idx fixed bin (17) init (1);
dcl  BAD_MEM (0:4) char (1) init (" ", " ", " ", " ", " ");
dcl  BAD_CPU (0:8) char (1) init (" ", " ", " ", " ", " ", " ", " ", " ", " ");
dcl  1 my_apte aligned like apte;			/* APTE for this process */
dcl  r0_aptep ptr;					/* ptr to APTE for this process */
dcl  1 my_wce like wct_entry;
dcl  real_time_wc bit (1);
						/* Based */

dcl  ret char (retL) based (retP) var;
dcl  arg char (argl) based (argp);
dcl  1 error_data (error_count) based (error_data_ptr),
       2 CPU1 char (1),
       2 CPU2 char (1),
       2 ERRCPU char (1),
       2 MEM char (1),
       2 ADD fixed bin (35);


dcl  data_seg (0:1023) bit (36) based (dseg_ptr) aligned;

dcl  1 akst aligned like kst_attributes;

/* Constants */

dcl  CPU_TAGS char (16) int static options (constant) init ("ABCDEFGHabcdefgh");
dcl  (hbound, null, addr, baseno, clock, fixed, bin, divide,
     index, mod, substr, unspec, verify, size,
     rel, search, translate) builtin;
dcl  tags (0:7) char (1) static options (constant) init
	("a", "b", "c", "d", "e", "f", "g", "h");

dcl  1 PATTERN (2) static options (constant),
       2 data bit (36) aligned init ("252525252525"b3, "525252525252"b3),
       2 next_idx fixed bin (17) init (2, 1);


/* External entries */

dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  complain entry variable options (variable);
dcl  (com_err_, active_fnc_err_) entry () options (variable);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  delete_$ptr entry (ptr, bit (36) aligned, char (*), fixed bin (35));
dcl  get_pdir_ entry () returns (char (168));
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$set_procs_required entry (bit (8) aligned, fixed bin (35));
dcl  hphcs_$set_process_work_class entry (bit (36) aligned, fixed bin, fixed bin, fixed bin (35));
dcl  ioa_ entry () options (variable);
dcl  ioa_$ioa_switch entry () options (variable);
dcl  ioa_$nnl entry () options (variable);
dcl  ioa_$rsnnl entry () options (variable);
dcl  iox_$error_output ptr ext static;
dcl  phcs_$deactivate entry (ptr, fixed bin (35));
dcl  phcs_$set_kst_attributes entry (fixed bin (35), ptr, fixed bin (35));
dcl  release_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  ring_zero_peek_ entry (ptr, ptr, fixed bin (19), fixed bin (35));
dcl  ring_zero_peek_$by_name entry (char (*), fixed bin (18), ptr, fixed bin (19), fixed bin (35));
dcl  ring_zero_peek_$by_definition entry (char (*), char (*), fixed bin (18), ptr, fixed bin (19), fixed bin (35));
dcl  unique_chars_ entry (bit (*)) returns (char (15));
						/* External static */

dcl  error_table_$not_act_fnc fixed bin (35) ext static;
dcl  error_table_$namedup fixed bin (35) ext static;
dcl  error_table_$segknown fixed bin (35) ext static;


%page;
	error_data_ptr, pages_ptr, tcmp, dseg_ptr = null ();
	call cu_$af_return_arg (n_args, retP, retL, code);
	if code = 0 then do;
	     AF_sw = "1"b;
	     complain = active_fnc_err_;
	end;
	else if code = error_table_$not_act_fnc then do;
	     AF_sw = "0"b;
	     complain = com_err_;
	end;
	else do;
	     call com_err_ (code, who_ami);
	     return;
	end;


	on cleanup begin;
	     goto RETURN;
	end;


/* check the access for the process  must have phcs_ and hphcs_ */
/* hphcs_ is to restrict command usage and if ever put in ring_0 */
/* then no user interface will need changed */

	on linkage_error begin;
	     call complain (0, who_ami,
		"User does not have access for ^[hphcs_^;phcs_^].",
		phcs_ok);
	     goto NO_ACC_RET;
	end;

	acc_var = phcs_$set_kst_attributes;
	phcs_ok = "1"b;
	acc_var = hphcs_$set_process_work_class;
	revert linkage_error;

/* find APTE */
	call ring_zero_peek_$by_definition ("pds", "apt_ptr", 0, addr (r0_aptep), 2, code);
	if code ^= 0
	then return;

/* copy APTE */
	call ring_zero_peek_ (r0_aptep, addr (my_apte), size (apte), code);
	if code ^= 0
	then return;

/* find out what cpu(s) we are set for and remember */
	default_flag = my_apte.flags.default_procs_required;
	orig_cpus = my_apte.procs_required;

/* see if we are in a realtime workclass */
	if ^AF_sw then call find_real_time_class;

/* get data from scs for processors and memories */
	call ring_zero_peek_$by_definition ("scs", "processor_data", 0,
	     addr (processor_data), size (processor_data), code);
	if code ^= 0 then do;
	     call complain
		(code, who_ami, "getting scs$processor_data.");
	     return;
	end;
	call ring_zero_peek_$by_definition ("scs", "controller_data", 0,
	     addr (mem_data), size (mem_data), code);
	if code ^= 0 then do;
	     call complain (code, who_ami, "getting scs$controller_data.");
	     return;
	end;


/* calculate the maj_loop number 1% of total mem pages */
	total_mem = 0;
	do i = 0 to 3;
	     if mem_data (i).info.online = "1"b then
		total_mem = mem_data (i).size + total_mem;
	end;
	maj_loop_max = divide ((total_mem * 1), 100, 17);
	if maj_loop_max = 0 then maj_loop_max = 5;


/* parse the args */
	do arg_no = 1 to n_args;
	     call cu_$arg_ptr (arg_no, argp, argl, code);
	     if substr (arg, 1, 1) ^= "-" then do;
		if verify (arg, CPU_TAGS) ^= 0 then do;
		     call complain (0, who_ami, "Invalid CPU Tag(s) ^a", arg);
		     goto NO_ACC_RET;
		end;
		check_cpu_string = translate (arg, "abcdefgh", "ABCDEFGH");

/* loop through processor_data */
		do i = 0 to hbound (processor_data, 1);
		     cpu_st_ind = search (check_cpu_string, tags (i));
		     if cpu_st_ind ^= 0 then do;
			if processor_data (i).online = "1"b then do;
			     if processor_data (i).cpu_type = DPS8M
			     then do;
				total_dps8 = total_dps8 + 1;
				substr (dps8_cpu, (total_dps8), 1) =
				     tags (i);
			     end;
			     else do;
				if total_l68 = 0 then do;
						/* only need one */
				     total_l68 = 1;
				     substr (l68_cpu, (total_l68), 1) =
					tags (i);
				end;
			     end;
			end;
			else do;
			     call complain (0, who_ami,
				"CPU ^a is currently OFF", tags (i));
			end;
		     end;
		end;
		if total_dps8 = 0 then do;
		     call complain (0, who_ami, "At least one CPU must be a DPS8.");
		     goto NO_ACC_RET;
		end;
	     end;

	     else if arg = "-long" | arg = "-lg" then do;
		if AF_sw then goto bad_af_arg;
		long_sw = "1"b;
	     end;
	     else if arg = "-deactivate_count" | arg = "-dc" then do;
		arg_no = arg_no + 1;
		call cu_$arg_ptr (arg_no, argp, argl, code);
		if code ^= 0 then do;
		     call complain (code, who_ami, "Getting major loop count.");
		     goto NO_ACC_RET;
		end;
		maj_loop_max = cv_dec_check_ (arg, code);
		if maj_loop_max <= 0 | code ^= 0 then do;
		     call complain (0, who_ami, "Invalid major loop count.");
		     goto NO_ACC_RET;
		end;
	     end;

	     else if arg = "-loop_count" | arg = "-lc" then do;
		arg_no = arg_no + 1;
		call cu_$arg_ptr (arg_no, argp, argl, code);
		if code ^= 0 then do;
		     call complain (code, who_ami, "Getting sub loop count.");
		     goto NO_ACC_RET;
		end;
		sub_loop_max = cv_dec_check_ (arg, code);
		if sub_loop_max <= 0 | code ^= 0 then do;
		     call complain (0, who_ami, "Invalid sub loop count.");
		     goto NO_ACC_RET;
		end;
	     end;

	     else if arg = "-brief" | arg = "-bf" then long_sw = "0"b;

	     else if arg = "-word_increment" | arg = "-wi" then do;
		arg_no = arg_no + 1;
		call cu_$arg_ptr (arg_no, argp, argl, code);
		if code ^= 0 then do;
		     call complain (code, who_ami,
			"Getting word_increment.");
		     goto NO_ACC_RET;
		end;
		word_inc = cv_dec_check_ (arg, code);
		if code = 0 then do;
		     if word_inc <= 0 | word_inc > 1023 then do;
bad_word_inc:
			call complain (0, who_ami,
			     "Invalid word_increment.");
			goto NO_ACC_RET;
		     end;
		end;
		else goto bad_word_inc;
	     end;
	     else if arg = "-meter" then do;
		if AF_sw then goto bad_af_arg;
		meter_sw = "1"b;
	     end;
	     else do;
		call complain (0, who_ami, "Invalid argument ""^a"".", arg);
		goto NO_ACC_RET;
bad_af_arg:
		call complain (0, who_ami, "^a invalid for active function", arg);
		goto NO_ACC_RET;
	     end;
	end;


	if total_dps8 = 0 then do;			/* caller wants auto cpu selection */
	     do i = 0 to hbound (processor_data, 1);
		if processor_data (i).online = "1"b then do;
		     if processor_data (i).cpu_type = DPS8M then do;
			total_dps8 = total_dps8 + 1;
			substr (dps8_cpu, (total_dps8), 1) = tags (i);
		     end;
		     else do;
			if total_l68 = 0 then do;
						/* only need one */
			     total_l68 = 1;
			     substr (l68_cpu, (total_l68), 1) = tags (i);
			end;
		     end;
		end;
	     end;
	end;
	if total_dps8 = 0 then do;
	     call complain (0, who_ami, "There is no dps8 on-line");
	     goto NO_ACC_RET;
	end;
	else if total_dps8 > 1 then do;
	     test_cpu_string = dps8_cpu;
	     cpus_to_test = total_dps8;
	     total_l68 = 0;
	end;
	else if total_dps8 = 1 then do;
	     if total_l68 ^= 0 then do;
		test_cpu_string = substr (dps8_cpu, 1, 1) ||
		     substr (l68_cpu, 1, 1);
		l68_cpu = substr (l68_cpu, 1, 1);
		cpus_to_test = 2;
	     end;
	     else do;
		cpus_to_test = total_dps8;
		test_cpu_string = dps8_cpu;
	     end;
	end;

	if cpus_to_test = 1 then do;
	     call complain (0, who_ami, "Must have at least two CPUs defined to run this test.");
	     goto NO_ACC_RET;
	end;


/* create the data segment in the process dir */
make_ds:	call hcs_$make_seg ((get_pdir_ ()),
	     "wnt_data_seg." || (unique_chars_ ("0"b)), "",
	     10, dseg_ptr, code);
	if code = error_table_$namedup | code = error_table_$segknown
	then code = 0;
	if code ^= 0 then do;
	     call complain (code, who_ami);
	     goto NO_ACC_RET;
	end;


/* find ptw base */
	if start_of_sst = 0 then do;
	     allocate sst set (sstp);
	     call ring_zero_peek_$by_name ("sst_seg",
		0, sstp, size (sst), code);
	     if code ^= 0 then do;
		call complain (code, who_ami, "getting sst header.");
		return;
	     end;
	     start_of_sst = bin (sst.ptwbase, 24);
	     free sst;
	end;

/* get a segment for page metering */
	call get_temp_segment_ (who_ami, pages_ptr, code);

/* init the meter data */
	call reset_meters;


/* get a segment for the error data of analizing maybe */
	call get_temp_segment_ (who_ami, error_data_ptr, code);

/* set up KST so we can deactivate the data_seg */
	unspec (akst) = "0"b;
	akst.set.explicit_deactivate_ok,
	     akst.value.explicit_deactivate_ok = "1"b;
	call phcs_$set_kst_attributes (fixed (baseno (dseg_ptr), 17),
	     addr (akst), code);			/* now set permissions */
	if code ^= 0 then do;
	     call complain (code, who_ami, "set kst attributes.");
	     return;
	end;
	error_count = 0;


/* Tell the user what cpus we have decided to use if not called as an active function */
	if ^AF_sw then do;
	     call ioa_$nnl ("^3xUsing ^d DPS8M CPU^[S^] (^a)", total_dps8,
		(total_dps8 > 1),
		translate (dps8_cpu, "ABCDEFGH", "abcdefgh"));
	     if total_l68 ^= 0 then call ioa_ ("^xand^xL68 CPU (^a).",
		     translate (l68_cpu, "ABCDEFGH", "abcdefgh"));
	     else call ioa_ (".");
	end;


/* divid the test_cpu_string into pairs if an odd number use the first over again */
	pair_idx = 1;
	number_of_pairs = divide (cpus_to_test, 2, 17);
	do i = 1 to number_of_pairs;
	     pair_sets (i).pair = substr (test_cpu_string, pair_idx, 2);
	     do cpu = 1 to 2;
		pair_sets (i).set (cpu).cpu_bits = "0"b;
		substr (pair_sets (i).set (cpu).cpu_bits,
		     mod (index (CPU_TAGS, substr (pair_sets (i).pair, cpu, 1)) - 1, 8) + 1, 1) = "1"b;
		if index (dps8_cpu, substr (pair_sets (i).pair, cpu, 1)) ^= 0
		then pair_sets (i).set (cpu).is_dps8 = "1"b;
		else pair_sets (i).set (cpu).is_dps8 = "0"b;
	     end;
	     pair_idx = pair_idx + 2;
	end;
	if mod (cpus_to_test, 2) = 1 then do;
	     number_of_pairs = number_of_pairs + 1;
	     i = number_of_pairs;
	     pair_sets (i).pair =
		substr (test_cpu_string, 1, 1) ||
		substr (test_cpu_string, pair_idx, 1);
	     do cpu = 1 to 2;
		pair_sets (i).set (cpu).cpu_bits = "0"b;
		substr (pair_sets (i).set (cpu).cpu_bits,
		     mod (index (CPU_TAGS, substr (pair_sets (i).pair, cpu, 1)) - 1, 8) + 1, 1) = "1"b;
		if index (dps8_cpu, substr (pair_sets (i).pair, cpu, 1)) ^= 0
		then pair_sets (i).set (cpu).is_dps8 = "1"b;
		else pair_sets (i).set (cpu).is_dps8 = "0"b;
	     end;
	end;


	maj_max_err_count = (divide (maj_loop_max, 4, 17)) + 2;
	sub_max_err_count = (divide (sub_loop_max, 4, 17)) + 2;
	inc_time = divide (sub_loop_max, 2, 17);
	error_count = 0;


/**** ************************************ ****/
/*           The test starts here           */
/**** ************************************ ****/


/* outer most loop is for by pairs of cps */
	do pair_idx = 1 to number_of_pairs;
	     major_loop_error = 0;
	     page_add_lines = "0"b;
	     address_lines = "0"b;

/* deactivation loop try for new real mem address */
	     do times = 1 to maj_loop_max;
		call deactivate_the_seg;
		testing_sw = "1"b;
		call set_cpu;
		inc_start = 0;
		pat_idx = 1;
		call write;
		sub_loop_error = 0;

/* subloop used to insure we get the correct types of hits */
		do loop = 1 to sub_loop_max;
		     call set_cpu;
		     call read;
		     if loop = inc_time then inc_start = inc_start + 4;
		     call write;
		end;
sub_loop_err_exit:
	     end;
maj_loop_err_exit:

/* print the meters for this cpu pair */
	     if meter_sw then call print_meters;
	end;


RETURN:						/* test over */

/* get running on the the original cpu set */
	if need_revert_cpu then do;
	     if default_flag then call hcs_$set_procs_required ("0"b, code); /* reset to default */
	     else call hcs_$set_procs_required (orig_cpus, code); /* reset to default */
	     need_revert_cpu = "0"b;
	end;
						/* if called as active function just tell if ok or not ok */
	if testing_sw then do;
						/* if we got started and no errors tell the user we had none */
	     if ^HAD_ERROR then do;
		if AF_sw then ret = "passed";
		else call ioa_ ("^a: No errors detected.", who_ami);

/* if we saw some erros try to fine out what could be wrong */
	     end;
	     else do;
		bad_cpu = 0;
		bad_scu = 0;
		if long_sw then
		     call ioa_ ("^/Error on cpu in mem  address  using pair");
		do i = 1 to error_count;
		     if long_sw then
			call ioa_ ("^10x^a^6x^a^2x^8o^8x^a^a",
			     error_data (i).ERRCPU, error_data (i).MEM,
			     error_data (i).ADD,
			     error_data (i).CPU1,
			     error_data (i).CPU2);
		     same_bad = "0"b;
		     do j = 0 to bad_cpu;
			if BAD_CPU (j) = error_data (i).ERRCPU
			then same_bad = "1"b;
		     end;
		     if ^same_bad then do;
			bad_cpu = bad_cpu + 1;
			BAD_CPU (bad_cpu) = error_data (i).ERRCPU;
		     end;
		     same_bad = "0"b;
		     do j = 0 to bad_scu;
			if BAD_MEM (j) = error_data (i).MEM
			then same_bad = "1"b;
		     end;
		     if ^same_bad then do;
			bad_scu = bad_scu + 1;
			BAD_MEM (bad_scu) = error_data (i).MEM;
		     end;
		end;
		if error_count > 0 then do;
		     if ^long_sw & ^AF_sw then do;
			call ioa_ ("^/Error summary");
			call ioa_$nnl
			     ("^/errors detected in cpu^[s^]^x",
			     (bad_cpu >= 2));
			do j = 1 to bad_cpu;
			     call ioa_$nnl ("^a^x", BAD_CPU (j));
			end;
			call ioa_ (" ");
			call ioa_$nnl ("errors detected in scu^[s^]^x",
			     (bad_scu >= 2));
			do j = 1 to bad_scu;
			     call ioa_$nnl ("^a^x", BAD_MEM (j));
			end;
			call ioa_ (" ");
		     end;
		     if (bad_cpu >= 2) & (bad_scu >= 2) & AF_sw
		     then do;
			ret = "failed";
			do j = 1 to bad_cpu;
			     call ioa_$rsnnl ("^a^xCPU_^a", ret, foo_len,
				ret, BAD_CPU (j));
			end;
			do j = 1 to bad_cpu;
			     call ioa_$rsnnl ("^a^xSCU_^a", ret, foo_len,
				ret, BAD_MEM (j));
			end;
		     end;
		     else if (bad_cpu = 1) & (bad_scu = 1) & AF_sw then
		        call ioa_$rsnnl ("failed CPU_^a SCU_^a",ret,
		        foo_len,BAD_CPU(1),BAD_MEM(1));
		     else if (bad_cpu >= 2) & (bad_scu = 1) then do;
			if AF_sw then call ioa_$rsnnl ("failed SCU_^a",
				ret, foo_len, BAD_MEM (1));
			else call ioa_ ("^/^-MEM ^a is defective",
				BAD_MEM (1));
		     end;

		     else if (bad_scu >= 2) & (bad_cpu = 1) then do;
			if AF_sw then call ioa_$rsnnl ("failed CPU_^a",
				ret,foo_len, BAD_CPU (1));
			else call ioa_ ("^/^-CPU ^a is defective",
				BAD_CPU (1));
		     end;

		end;
	     end;
	end;


NO_ACC_RET:
	if dseg_ptr ^= null then
	     call delete_$ptr (dseg_ptr, "440000000000"b3, "", code);

	if need_revert_cpu then do;
	     if default_flag then call hcs_$set_procs_required ("0"b, code); /* reset to default */
	     else call hcs_$set_procs_required (orig_cpus, code); /* reset to default */
	end;
	if error_data_ptr ^= null () then do;
	     call release_temp_segment_ (who_ami, error_data_ptr, code);
	     error_data_ptr = null ();
	end;
	if tcmp ^= null () then do;
	     call release_temp_segment_ (who_ami, tcmp, code);
	     tcmp = null ();
	end;
	if pages_ptr ^= null () then do;
	     call release_temp_segment_ (who_ami, pages_ptr, code);
	     pages_ptr = null ();
	end;
	return;


%page;


count_error: proc;

/* count_error counts the errors and decides whem to move to next loop */
/* display is called from here */

	major_loop_error = major_loop_error + 1;
	sub_loop_error = sub_loop_error + 1;
	error_count = error_count + 1;
	HAD_ERROR = "1"b;
	call display_fault_data;
	if sub_loop_error >= sub_max_err_count
	then do;
	     pat_idx = PATTERN (pat_idx).next_idx;
	     goto sub_loop_err_exit;
	end;
	if major_loop_error >= maj_max_err_count
	then goto maj_loop_err_exit;
	goto NEXT_READ_LABEL;

     end count_error;
%page;

deactivate_the_seg:
     proc;

/* This proc deactivates the  data segment in hopes that when */
/* reactivated the pages will be in a differen area of memory */
	call phcs_$deactivate (dseg_ptr, code);
	if code ^= 0 then do;
	     call complain (code, "phcs_$deactivate");
	     return;
	end;
	need_page_meter = "1"b;
     end deactivate_the_seg;
%page;
find_real_time_class:
     proc;

/* This proc check to see if the user is in a realtime workclas. If not  */
/* display warning message and if long mode display parameters for each  */
/* realtime workclass.					   */

dcl  Q1 float bin;
dcl  Q2 float bin;
dcl  R1 float bin;
dcl  R2 float bin;

	wct_offset = fixed (my_apte.wct_index, 17);
	call ring_zero_peek_$by_name ("tc_data", (wct_offset),
	     addr (my_wce), (size (my_wce)), code);
	if code ^= 0 then do;
	     call complain (0, who_ami, "getting work_class_info");
	     goto RETURN;
	end;
	if my_wce.realtime = 0 then do;
	     call ioa_$ioa_switch (iox_$error_output,
		"Warning: User not in a realtime workclass.");
	     real_time_wc = "0"b;
	end;
	else real_time_wc = "1"b;
	if real_time_wc | ^long_sw then return;
	call get_temp_segment_ (who_ami, tcmp, code);
	wct_offset = fixed (rel (addr (tcm.work_class_table)), 17);
	call ring_zero_peek_$by_name ("tc_data", (wct_offset),
	     addr (tcm.work_class_table), (size (wct_entry) * 17), code);
	if code ^= 0 then do;
	     call complain (0, who_ami, "getting work_class_info");
	     goto RETURN;
	end;
	call ioa_ ("WC^4xIRESP^2xIQUANT^4xRESP^3xQUANT");
	high_wc = 0;
	do i = 0 to 16;
	     if wcte (i).flags.defined then do;
		if high_wc = 0 then high_wc = i;
		if wcte (i).realtime ^= 0 then do;
		     R1 = 1e-6 * wcte (i).resp1;
		     R2 = 1e-6 * wcte (i).resp2;
		     Q1 = 1e-6 * wcte (i).quantum1;
		     Q2 = 1e-6 * wcte (i).quantum2;
		     call ioa_$ioa_switch (iox_$error_output,
			"^2d ^8.2f^8.2f^8.2f^8.2f", i, R1, Q1, R2, Q2);
		end;
	     end;
	end;
	call release_temp_segment_ (who_ami, tcmp, code);
	tcmp = null ();
     end find_real_time_class;
%page;

/* The three procs wrie, read, set_cpu make up the heart of the test  */

write: proc;

/* Write the CACHE */

	pattern = PATTERN (pat_idx).data;
	do wrt = inc_start to hbound (data_seg, 1) by word_inc;

/* make sure it is in cache */
	     bit_bucket = data_seg (wrt);
	     data_seg (wrt) = pattern;
	end;
     end write;
%skip (4);
read: proc;

/* Read what was written by the other cpu */
dcl  P_null ptr init (null);

	NEXT_READ_LABEL = next_loc;			/* used to continue after error */
	if pair_sets (pair_idx).set (cpu).is_dps8 = "1"b then do;
						/* waste of time on L68! */

	     if need_page_meter then call meter_the_page;
	     do rd = inc_start to hbound (data_seg, 1) by word_inc;
		page_add_lines = page_add_lines | unspec (rd);
		if data_seg (rd) ^= pattern then do;
		     call count_error;
		end;
next_loc:
	     end;
	end;
	pat_idx = PATTERN (pat_idx).next_idx;
     end read;
%skip (4);
set_cpu: proc;

/* switch to the other cpu */
	if cpu = 2 then cpu = 1;
	else cpu = 2;
	call hcs_$set_procs_required (pair_sets (pair_idx).set (cpu).cpu_bits, code);
	if code ^= 0 then do;
	     call complain (code, who_ami);
	     goto RETURN;
	end;
	need_revert_cpu = "1"b;
     end set_cpu;
%page;

meter_the_page: proc;
	call page_peek;
	deact_loop_cnt = deact_loop_cnt + 1;
	if data_ptw.add_type ^= "1000"b then do;	/* lost race, page gone! */
	     mem_meters (8) = mem_meters (8) + 1;	/* count losses */
	     return;
	end;
	last_ptw = data_ptw, by name;
	data_page = divide (bin (data_ptw.add, 18), 16, 17, 0);
	pages_used (data_page) = pages_used (data_page) + 1;
	do meter_idx = 0 to 7;
	     if (data_page >= mem_data (meter_idx).base) then do;
		if data_page < (mem_data (meter_idx).base + mem_data (meter_idx).size) then do;
		     mem_meters (meter_idx) = mem_meters (meter_idx) + 1;
		     need_page_meter = "0"b;
		     address_lines = address_lines | unspec (data_page);
		     return;
		end;
	     end;
	end;
	call complain (0, who_ami, "Page frame ^oo, not found within scs$controller_data definition.", data_page);
	return;
     end meter_the_page;
%page;
page_peek:
     proc;
	call ring_zero_peek_$by_name ("dseg", (2 * bin (baseno (dseg_ptr), 17)), addr (data_sdw), 1, code);
	if code ^= 0 then do;
	     call complain (code, "getting sdw from dseg. Resetting metering switch.");
	     meter_sw = "0"b;
	     return;
	end;
	call ring_zero_peek_$by_name ("sst_seg", (bin (data_sdw.add, 24) - start_of_sst), addr (data_ptw), 1, code);
	if code ^= 0 then do;
	     call complain (code, "getting ptw from sst_seg. Resetting metering switch.");
	     meter_sw = "0"b;
	     return;
	end;
     end page_peek;
%page;
reset_meters:
     proc;
	if pages_ptr ^= null () then pages_used (*) = 0;
	mem_meters (*) = 0;
	deact_loop_cnt = 0;
     end reset_meters;
%page;
print_meters:
     proc;
	if AF_sw then return;
	if unspec (mem_meters (*)) ^= "0"b then do;
	     call ioa_ ("^2/Meters for cpu pair ^a",
		pair_sets (pair_idx).pair);
	     total_mem = 0;
	     call ioa_$nnl ("^23x");
	     do i = 0 to 3;
		if mem_data (i).info.online = "1"b then do;
		     total_mem = mem_data (i).size + total_mem;
		     call ioa_$nnl ("^4x^a^5x", substr ("ABCD", i + 1, 1));
		end;
	     end;
	     call ioa_$nnl ("^/^23x");
	     do i = 0 to 3;
		if mem_data (i).info.online = "1"b then do;
		     call ioa_$nnl ("^2x^5d.^2x", mem_data (i).size);
		end;
	     end;
	     call ioa_$nnl ("^/^2xMemory size relation:");
	     do i = 0 to 3;
		if mem_data (i).info.online = "1"b then
		     call ioa_$nnl ("^7.2f%^2x",
			divide (mem_data (i).size * 100, total_mem, 17, 7));
	     end;
	     call ioa_$nnl ("^/^2xMemory usage meters: ");
	     do i = 0 to 3;
		if mem_data (i).info.online = "1"b then do;
		     if mem_meters (i) ^= 0 then do;
			call ioa_$nnl ("^7.2f%^2x",
			     divide (mem_meters (i) * 100,
			     deact_loop_cnt, 17, 7));
		     end;
		     else call ioa_$nnl ("^7.2f%^2x", (0));
		end;
	     end;
	     if mem_meters (8) ^= 0 then
		call ioa_$nnl ("^/ losses=^6.2f%",
		     divide (mem_meters (8) * 100, deact_loop_cnt, 17, 6));
	     call ioa_ ("");
	end;
	if pages_ptr ^= null () then do;
	     call print_page_meters;
	end;
	call reset_meters;
     end print_meters;
%page;
print_page_meters:
     proc;
	address_lines = "0"b;
	do i = 0 to 3;
	     if mem_data (i).info.online = "1"b then do;
		if long_sw then do;
		     call ioa_ ("^/MEM ^a from ^o to ^o",
			substr ("ABCD", i + 1, 1), mem_data (i).base,
			(mem_data (i).base + (mem_data (i).size - 1)));
		     call ioa_ ("^-^xframe^3xused^4xadd bits 0->13");
		end;
		do j = mem_data (i).base to (mem_data (i).base + (mem_data (i).size - 1));
		     if pages_used (j) ^= 0 then do;
			address_lines = unspec (j) | address_lines;
			if long_sw then call ioa_ ("^-^6o^2x^4d^5x^14b",
				j, pages_used (j),
				substr (unspec (j), 23, 14));
		     end;
		end;
	     end;
	end;
	call ioa_ ("^/address lines checked^6x0 -> 13^4x^3x14 -> 23^/^23x^14b^3x^10b",
	     substr (address_lines, 23),
	     substr (page_add_lines, 27));
	address_lines, page_add_lines = "0"b;
     end print_page_meters;
%page;
display_fault_data:
     proc;

dcl  bad_addr bit (24);
dcl  bad_mem char (1);
dcl  (bad_addr_bin, mem_offset) fixed bin (35);
dcl  the_date_time char (24);
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  temp_mem_add fixed bin (35);
dcl  win bit (1);
dcl  no_luck_reason char (32);
	call date_time_ (clock (), the_date_time);
	win = "0"b;
	call page_peek;
	if data_ptw.add_type ^= "1000"b then do;
	   call ioa_$rsnnl
	      ("page has been evicted", no_luck_reason, foo_len);
	     goto no_luck;
	end;
	if last_ptw.add ^= data_ptw.add then do;
	   call ioa_$rsnnl
	        ("page address has changed", no_luck_reason, foo_len);
	     goto no_luck;
	end;
	temp_mem_add = 0;
	substr (unspec (temp_mem_add), 13, 24) =
	     substr (unspec (data_page), 23, 14) ||
	     substr (unspec (rd), 27, 10);
	bad_mem = substr ("ABCD", meter_idx + 1, 1);
	bad_addr = substr (unspec (temp_mem_add), 13, 24);
	win = "1"b;
	error_data (error_count).CPU1 =
	   translate (substr (pair_sets (pair_idx).pair, 1, 1),
	   "ABCDEFGH", "abcdefgh");
	error_data (error_count).CPU2 =
	   translate (substr (pair_sets (pair_idx).pair, 2, 1),
	   "ABCDEFGH", "abcdefgh"); 
	error_data (error_count).ERRCPU =
	   translate (substr (pair_sets (pair_idx).pair, cpu, 1),
	   "ABCDEFGH", "abcdefgh"); 
	error_data (error_count).MEM = bad_mem;
	error_data (error_count).ADD = temp_mem_add;
	bad_addr_bin = bin (bad_addr, 35);
	mem_offset = (bad_addr_bin - (mem_data (meter_idx).base * 1024));
	if long_sw then do;
	     call ioa_
		("^/**^2xERROR at ^24a on CPU ^a in SCU ^a ADDRESS ^8.3b^ **",
		the_date_time,
		error_data (error_count).ERRCPU, bad_mem, bad_addr);
	     call ioa_
		("^5xOffset in data_seg = ^oo, deact_cnt = ^d, loop_cnt = ^d, cpu pair = ^a",
		rd, times, loop, pair_sets (pair_idx).pair);
	end;
	return;
no_luck:
	if AF_sw then return;
	call ioa_ ("^/**^2xERROR at ^24a on CPU ^a^2x**",
	     the_date_time, substr (pair_sets (pair_idx).pair, cpu, 1));
	call ioa_ ("**^2xHowever ^32a^4x**", no_luck_reason);
	return;
     end display_fault_data;
%page;

%include kst_attributes;
%include apte;
%include scs;
%include sst;
%include sdw;
%include ptw;
%include tcm;
%include hc_lock;
     end write_notify_test;


		    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