



		    convert_v1_fdump.pl1            10/01/82  1523.5rew 10/01/82  1523.6       95850



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


convert_v1_fdump:
     procedure options (variable);

/* *	CONVERT_V1_FDUMP
   *
   *	This command converts a version 1 FDUMP image (from before MR9.0) into
   *	a version 2 FDUMP image. The change is that the dump header has been
   *	reorganized, and is now two pages long, rather than one.
   *
   *	03/18/81, W. Olin Sibert
   */

dcl  arg char (al) based (ap);
dcl  al fixed bin (21);
dcl  ap pointer;
dcl (nargs, argno) fixed bin;
dcl  code fixed bin (35);

dcl  page (1024) bit (36) aligned based;

dcl 1 old_dump aligned like v1_dump automatic;
dcl 1 new_dump aligned like dump automatic;

dcl  fs_mode fixed bin (5);
dcl  ename_prefix char (32) varying;
dcl  ename_suffix char (32) varying;
dcl  ename char (32);

dcl  dump_seg_lth fixed bin;
dcl  total_pages fixed bin;
dcl  remaining_pages fixed bin;
dcl  idx fixed bin;
dcl  error_sw bit (1) aligned;
dcl  in_place bit (1) aligned;
dcl  seg_zero_ename char (32);

dcl  old_dname char (168);
dcl  old_ptrs (0 : 31) pointer;
dcl  n_old_segs fixed bin;
dcl  old_bc (0 : 31) fixed bin (24);
dcl  old_lth (0 : 31) fixed bin;
dcl  old_page_ptr pointer;
dcl  old_seg fixed bin;

dcl  new_dname char (168);
dcl  new_equal_name char (32);
dcl  new_ptrs (0 : 31) pointer;
dcl  new_name (0 : 31) char (32) unaligned;
dcl  n_new_segs fixed bin;
dcl  new_page_ptr pointer;
dcl  new_seg fixed bin;

dcl  absolute_pathname_ entry (char (*), char (*), fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  copy_acl_ entry (char (*), char (*), char (*), char (*), bit (1) aligned, fixed bin (35));
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, pointer, fixed bin (21), fixed bin (35));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  get_equal_name_ entry (char (*), char (*), char (32), fixed bin (35));
dcl  hcs_$fs_get_mode entry (pointer, fixed bin (5), fixed bin (35));
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), pointer, fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), pointer, fixed bin (35));
dcl  hcs_$set_bc_seg entry (pointer, fixed bin (24), fixed bin (35));
dcl  ioa_ entry options (variable);

dcl  sys_info$max_seg_size fixed bin (18) external static;

dcl  error_table_$noentry fixed bin (35) external static;
dcl  error_table_$no_w_permission fixed bin (35) external static;

dcl  WHOAMI char (32) internal static options (constant) init ("convert_v1_fdump");

dcl (addr, char, divide, ltrim, null, pointer, rtrim, substr) builtin;

/*  */

	call cu_$arg_count (nargs, code);
	if code ^= 0 then do;
	     call com_err_ (code, WHOAMI);
MAIN_RETURN:   return;
	end;

	if (nargs < 1) | (nargs > 2) then do;
	     call com_err_ (0, WHOAMI, "Usage: ^a path-of-comp-zero {equal-path-of-new-comp-zero}", WHOAMI);
	     goto MAIN_RETURN;
	end;

	call cu_$arg_ptr (1, ap, al, (0));
	call expand_pathname_ (arg, old_dname, ename, code);
	if code ^= 0 then do;
	     call com_err_ (code, WHOAMI, "^a", arg);
	     goto MAIN_RETURN;
	end;

	seg_zero_ename = ename;
	ename_prefix = substr (ename, 1, 12);		/* MMDDYY.HHMM. */
	ename_suffix = after (substr (ename, 13), ".");	/* ERF number */
	if verify (ename_prefix, "0123456789.") ^= 0 then do;
BAD_ENAME:     call com_err_ (0, WHOAMI, "^a is not the entryname of component zero of an FDUMP.", ename);
	     goto MAIN_RETURN;
	end;

	if ename_suffix = "" then goto BAD_ENAME;
	ename_suffix = "." || rtrim (ename_suffix);
	if substr (ename, 12, 3) ^= ".0." then goto BAD_ENAME;

	if nargs > 1 then do;			/* Get new dirname */
	     call cu_$arg_ptr (2, ap, al, (0));
	     call expand_pathname_ (arg, new_dname, new_equal_name, code);
	     if code ^= 0 then do;
		call com_err_ (code, WHOAMI, "^a", arg);
		goto MAIN_RETURN;
	     end;

	     if index (new_equal_name, "=") = 0 then do;
		call com_err_ (0, WHOAMI, "Entryname for converted dump must be an equal name. ^a", new_equal_name);
		goto MAIN_RETURN;
	     end;
	     in_place = "0"b;
	end;

	else do;
	     new_dname = old_dname;
	     new_equal_name = "==";
	     in_place = "1"b;
	end;

	new_ptrs (*) = null ();
	old_ptrs (*) = null ();

/* First, look for all the segments which are part of this FDUMP image. Stop
   looking when there are no more. This loop also initiates or creates the
   output segments. */

	total_pages = 0;
	do idx = 0 by 1;
	     ename = ename_prefix || rtrim (ltrim (char (idx))) || ename_suffix;

	     call hcs_$initiate_count (old_dname, ename, "", old_bc (idx), 0, old_ptrs (idx), code);
	     if old_ptrs (idx) = null () then do;
		if code = error_table_$noentry then
		     if idx > 0 then
			goto FINISHED_INITIATING;

		call com_err_ (code, WHOAMI, "^a^[>^]^a", old_dname, (old_dname ^= ">"), ename);
		goto MAIN_RETURN;
	     end;

	     old_lth (idx) = divide ((old_bc (idx) + (36 * 1024) - 1), 36 * 1024, 17, 0);
	     total_pages = total_pages + old_lth (idx);

	     call get_equal_name_ (ename, new_equal_name, ename, code);
	     if code ^= 0 then goto BAD_NEW_SEGMENT;
	     new_name (idx) = ename;

	     call hcs_$make_seg (new_dname, ename, "", 01010b, new_ptrs (idx), code);
	     if new_ptrs (idx) = null () then do;
BAD_NEW_SEGMENT:	call com_err_ (code, WHOAMI, "^a^[>^]^a", new_dname, (new_dname ^= ">"), ename);
		goto MAIN_RETURN;
	     end;

	     call hcs_$fs_get_mode (new_ptrs (idx), fs_mode, code);
	     if code ^= 0 then goto BAD_NEW_SEGMENT;
	     code = error_table_$no_w_permission;
	     if substr (bit (binary (fs_mode, 5), 5), 4, 1) = "0"b then goto BAD_NEW_SEGMENT;
	end;

/* Now, figure out how many segments there are, what the max length of the dump
   image segments is, and possibly create another output segment -- this is necessary
   if all the existing segments are completely full, so that adding a page would
   cause an overflow into the next segment. */

FINISHED_INITIATING:
	n_old_segs = idx - 1;
	if n_old_segs > 0 then			/* Zero-Origin */
	     dump_seg_lth = old_lth (0);
	else dump_seg_lth = divide (sys_info$max_seg_size, 1024, 17, 0);

	if old_lth (n_old_segs) + 1 > dump_seg_lth then do;
	     ename = ename_prefix || rtrim (ltrim (char (n_old_segs + 1))) || ename_suffix;
	     n_new_segs = n_old_segs + 1;

	     call get_equal_name_ (ename, new_equal_name, ename, code);
	     if code ^= 0 then goto BAD_NEW_SEGMENT;

	     call hcs_$make_seg (new_dname, ename, "", 01010b, new_ptrs (n_new_segs), code);
	     if new_ptrs (n_new_segs) = null () then goto BAD_NEW_SEGMENT;

	     call hcs_$fs_get_mode (new_ptrs (n_new_segs), fs_mode, code);
	     if code ^= 0 then goto BAD_NEW_SEGMENT;
	     code = error_table_$no_w_permission;
	     if substr (bit (binary (fs_mode, 5), 5), 4, 1) = "0"b then goto BAD_NEW_SEGMENT;
	end;
	else n_new_segs = n_old_segs;

/* Now loop backward through all the pages in the dump, copying page N into page N+1;
   that is, shifting it all right by one page. The pages are numbered zero-origin, but
   the loop terminates at one because the page zero of segment zero is the header page,
   and cannot be simply copied. */

	do idx = total_pages - 1 to 1 by -1;
	     old_seg = divide (idx, dump_seg_lth, 17, 0);
	     old_page_ptr = pointer (old_ptrs (old_seg), (1024 * mod (idx, dump_seg_lth)));
	     new_seg = divide (idx + 1, dump_seg_lth, 17, 0);
	     new_page_ptr = pointer (new_ptrs (new_seg), (1024 * mod (idx + 1, dump_seg_lth)));
	     new_page_ptr -> page = old_page_ptr -> page;
	end;

/* Now, set the bitcounts everywhere to indicate the appropriate sizes -- it's max length
   for all segments but the last. */

	remaining_pages = total_pages;
	do idx = 0 to n_new_segs;
	     if remaining_pages > dump_seg_lth then
		call hcs_$set_bc_seg (new_ptrs (idx), (36 * 1024 * dump_seg_lth), (0));
	     else call hcs_$set_bc_seg (new_ptrs (idx), (36 * 1024 * remaining_pages), (0));
	     remaining_pages = remaining_pages - dump_seg_lth;
	end;

/* Finally, the dump headers are converted. The old dump header is copied into automatic,
   and all the corresponding information is copied into an automatic version of the new
   header, which is finally inserted into the new FDUMP image. This cannot use by-name
   assignment, more's the pity, because there are several arrays with different bounds
   which must be copied, as well as the scalar items. */

	unspec (old_dump) = unspec (old_ptrs (0) -> v1_dump);
	unspec (new_dump) = ""b;

	new_dump.dump_header = old_dump.dump_header;

	do idx = 1 to hbound (old_dump.segs, 1);
	     new_dump.segs (idx) = old_dump.segs (idx);
	end;

	do idx = 0 to hbound (old_dump.amptwregs, 1);
	     new_dump.amptwregs (idx) = old_dump.amptwregs (idx);
	     new_dump.amptwptrs (idx) = old_dump.amptwptrs (idx);
	     new_dump.amsdwregs (idx) = old_dump.amsdwregs (idx);
	     new_dump.amsdwptrs (idx) = old_dump.amsdwptrs (idx);
	end;

	do idx = 0 to hbound (old_dump.ouhist, 1);
	     new_dump.ouhist (idx) = old_dump.ouhist (idx);
	     new_dump.cuhist (idx) = old_dump.cuhist (idx);
	     new_dump.duhist (idx) = old_dump.duhist (idx);
	     new_dump.auhist (idx) = old_dump.auhist (idx);
	end;

	unspec (new_dump.prs) = unspec (old_dump.prs);	/* Avoid validating pointers */
	new_dump.regs = old_dump.regs;

	new_dump.low_order_port = old_dump.low_order_port;
	new_dump.mctime = old_dump.mctime;

	new_dump.misc_registers = old_dump.misc_registers;
	new_dump.ptrlen = old_dump.ptrlen;

	new_dump.coreblocks (*) = old_dump.coreblocks (*);

	new_dump.version = DUMP_VERSION_2;

	unspec (new_ptrs (0) -> dump) = unspec (new_dump);

	if ^in_place then do;			/* Only do this if something actually moved */
	     do idx = 0 to n_new_segs;		/* Now, copy the ACLs to make it all perfectly clean */
		call copy_acl_ (old_dname, seg_zero_ename, new_dname, new_name (idx), error_sw, code);
	     end;					/* Just ignore errors -- they are benign */
	end;

	call ioa_ ("^a: Converted ^d pages from ^a^[>^]^a^[^/^3xinto ^a^[>^]^a^]",
	     WHOAMI, total_pages, old_dname, (old_dname ^= ">"), seg_zero_ename,
	     (^in_place), new_dname, (new_dname ^= ">"), new_name (0));

	goto MAIN_RETURN;

%page; %include bos_dump;

     end convert_v1_fdump;




		    copy_from_dump.pl1              10/01/82  1523.5rew 10/01/82  1523.6       33093



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


copy_from_dump:
     proc (dump_ptrs, seg_index, offset, words, to_ptr, words_copied, code);


/* Subroutine to copy all or a portion of a segment from a BOS dump file.
   The segment is identified by its index in the BOS dump header.
   An array of pointers to the BOS dump components is passed as a parameter
   --this array points to segments of the dump in order (0, 1, 2, ...).

   Written March 1981 by J. Bongiovanni								*/


/* Parameter */

dcl  dump_ptrs (*) ptr;				/* array  of ptrs to dump components, in order	*/
dcl  seg_index fixed bin;				/* index of segment to copy in bos dump array	*/
dcl  offset fixed bin (18);				/* first word in segment to dump		*/
dcl  words fixed bin (18);				/* number of words to dump			*/
dcl  to_ptr ptr;					/* where to copy data			*/
dcl  words_copied fixed bin (18);			/* number of words actually copied		*/
dcl  code fixed bin (35);				/* standard error code			*/

/* Automatic */

dcl  dump_ptr_index fixed bin;
dcl  dump_seg_offset fixed bin (18);
dcl  fp ptr;
dcl  sector fixed bin (24);
dcl  segnum fixed bin;
dcl  tp ptr;
dcl  word_offset fixed bin (24);
dcl  words_left fixed bin (18);
dcl  words_move fixed bin (18);

/* Static */

dcl  HEADER_WORDS fixed bin (18) init (2048) int static options (constant); /* size of header for this version of FDUMP */
dcl  VERSION fixed bin init (2) int static options (constant); /* version expected			*/



/* Based */

dcl  based_move (words_move) fixed bin (35) aligned based;


/* External */

dcl  error_table_$bad_arg fixed bin (35) ext;
dcl  error_table_$improper_data_format fixed bin (35) ext;
dcl  sys_info$max_seg_size fixed bin (18) ext;

/* Builtin */

dcl  addrel builtin;
dcl  bin builtin;
dcl  divide builtin;
dcl  hbound builtin;
dcl  max builtin;
dcl  min builtin;
dcl  mod builtin;
dcl  ptr builtin;


%page;

	code = 0;
	dumpptr = dump_ptrs (1);
	if dump.version ^= VERSION then do;
	     code = error_table_$improper_data_format;	/* bad Fdump				*/
	     return;
	end;


	if seg_index > dump.num_segs then do;		/* segment not in dump			*/
	     code = error_table_$bad_arg;
	     return;
	end;

/* Compute word address of beginning of segment within dump file     					*/

	sector = 0;
	if seg_index > 1 then do segnum = 1 to seg_index - 1;
	     sector = sector + bin (dump.segs (segnum).length, 18);
	end;
	word_offset = sector * 64 + HEADER_WORDS + offset;

	dump_ptr_index = divide (word_offset, sys_info$max_seg_size, 17) + 1;
	dump_seg_offset = mod (word_offset, sys_info$max_seg_size);

	words_left = min (words, 64 * bin (dump.segs.length (seg_index), 18));
	words_copied = max (words_left, 0);
	tp = to_ptr;

	do while (words_left > 0);
	     if dump_ptr_index > hbound (dump_ptrs, 1) then do;
		code = error_table_$bad_arg;
		return;
	     end;
	     fp = ptr (dump_ptrs (dump_ptr_index), dump_seg_offset);
	     words_move = min (sys_info$max_seg_size - dump_seg_offset, words_left);
	     tp -> based_move = fp -> based_move;
	     words_left = words_left - words_move;
	     dump_ptr_index = dump_ptr_index + 1;
	     dump_seg_offset = 0;
	     tp = addrel (tp, words_move);
	end;
%page;

%include bos_dump;


     end copy_from_dump;




		    display_am_.pl1                 10/01/82  1523.5rew 10/01/82  1523.6      167346



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


display_am_: proc ();

	return;					/* should never enter here */

/* Associative memory display program for ol_dump.
   * Last modified 08/25/80 W. Olin Sibert, to make it work properly for PRDS assoc mems
   * Last modified 09/09/80 R. L. Coppola, to make it work for l68 or DPS8/70 cpu's
   * Last Modified June 1981 by Rich Coppola to add consistency checking.
   */

dcl (idx, jdx, type, IDX, first_entry, last_entry, first_level, last_level) fixed bin;
dcl  CPU_NO fixed bin (3);
dcl  tag (0:7) char (1) int static options (constant) init
    ("a", "b", "c", "d", "e", "f", "g", "h");
dcl  AM_LEVEL (1:4) char (1) int static options (constant) init
    ("A", "B", "C", "D");				/* levels of dps8 AMs */
dcl  DPS8xxM bit (1);				/* denotes a dps8 cpu */
dcl  val_btld bit (1) init ("0"b);
dcl  code fixed bin (35);
dcl  def_offset fixed bin (18);
dcl  error bit (1);
dcl (reg_ptr, ptr_ptr) ptr;
dcl  seg_ptr pointer;
dcl  flag_string char (7);
dcl  dup_entry (0:63) bit (1) unal;
dcl (first, last) fixed bin int static;
dcl (sdw_regs_ptr, sdw_ptrs_ptr, ptw_regs_ptr, ptw_ptrs_ptr) pointer;

dcl 1 sdw_regs (0:63) aligned like amsdwreg based (sdw_regs_ptr);
dcl 1 sdw_ptrs (0:63) aligned like amsdwptr based (sdw_ptrs_ptr);
dcl 1 ptw_regs (0:63) aligned like amptwreg based (ptw_regs_ptr);
dcl 1 ptw_ptrs (0:63) aligned like amptwptr based (ptw_ptrs_ptr);

dcl  ioa_ entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  namef_ entry (ptr, ptr) returns (char (*));
dcl  namef_$no_comp entry (ptr, ptr) returns (char (*));
dcl  ring0_get_$definition_given_slt entry (ptr, char (*), char (*), fixed bin (18),
     fixed bin, fixed bin (35), ptr, ptr, ptr);
dcl  ol_dump_util_$get_ptr entry (fixed bin, ptr, fixed bin (35), ptr); /* :: */
dcl  ol_dump_util_$fnd_dbr entry (fixed bin (24), fixed bin (35), fixed bin (35), ptr);
dcl (addr, addrel, binary, baseptr, fixed, null, substr) builtin;
dcl  usage_string char (8);


dcl  nregs fixed bin;				/* number of regs/ptrs in am saved by fim.
						   * Could be 16/64 depending on whether
						   * the cpu is a dpse or l68 */

/*  */

display_am_$sdw: entry (odsp, CPU_NO);


	call get_args ("0"b, error, nregs);		/* get additional args, etc */
	if error then return;			/* if problem, go back to request */


	call validate_am_sdw (nregs, odsp);

	first_entry = 0;
	last_entry = 15;



	if DPS8xxM then do;
	     first_level = 1;
	     last_level = 4;
	end;

	else do;
	     first_level = 1;
	     last_level = 1;
	end;


	call ioa_ (" ADDRESS^2xRINGS^2xBOUND^2xREWPUGC^4xCL F/E USAGE-CT SEG # SEG_NAME");


	do IDX = first_level to last_level;
	     if DPS8xxM then
		call ioa_ ("^/LEVEL [^a]^/", AM_LEVEL (IDX));
	     do idx = first_entry to last_entry;
		call ioa_$rsnnl ("^[R^; ^]^[E^; ^]^[W^; ^]^[P^; ^]^[U^; ^]^[G^; ^]^[C^; ^]",
		     flag_string, (0),		/* generate the REWPUGC string */
		     sdw_regs (idx).read,
		     sdw_regs (idx).execute,
		     sdw_regs (idx).write,
		     sdw_regs (idx).privileged,
		     sdw_regs (idx).unpaged,
		     sdw_regs (idx).entry_bound_sw,
		     sdw_regs (idx).cache);

		if ^DPS8xxM then
		     call ioa_$rsnnl ("^6x^2d", usage_string, (0),
		     binary (sdw_ptrs (idx).usage, 4));

		else call ioa_$rsnnl ("^2x^6b", usage_string, (0),
		     sdw_ptrs (idx).usage);


		call ioa_ ("^8o^2x^1.3b,^1.3b,^1.3b ^6o^2x^7a ^[^5o^;^s^4x-^]^2x^[F^;E^]^2x^8a ^5o ^[^a^;^s N/A^]^[^/^-*** POSSIBLE DUPLICATE ENTRY ***^]",

		     binary (sdw_regs (idx).addr, 24),
		     sdw_regs (idx).r1,
		     sdw_regs (idx).r2,
		     sdw_regs (idx).r3,
		     binary ((sdw_regs (idx).bound || "0000"b), 18),
		     flag_string,
		     ((^sdw_regs (idx).entry_bound_sw) & sdw_regs (idx).execute), /* skip next if there is none */
		     binary (sdw_regs (idx).cl, 14),
		     sdw_ptrs (idx).valid,
		     usage_string,
		     binary (sdw_ptrs (idx).pointer, 15),
		     sdw_ptrs (idx).valid,		/* skip the naming if the entry isn't valid */
		     namef_$no_comp (baseptr (binary (sdw_ptrs (idx).pointer, 15)), odsp),
		     dup_entry (idx));
	     end;

	     first_entry = last_entry + 1;
	     last_entry = first_entry +15;

	end;
	return;

/*  */

display_am_$ptw: entry (odsp, CPU_NO);

	call get_args ("1"b, error, nregs);		/* get additional args, etc */
	if error then return;			/* if problem, go back to request */

	call ioa_ (" ADDRESS^3xM^2xF/E USAGE_CT SEG # PAGE SEG_NAME|OFFSET");
	call validate_am_ptw (nregs, odsp);


	first_entry = 0;
	last_entry = 15;



	if DPS8xxM then do;
	     first_level = 1;
	     last_level = 4;
	end;

	else do;
	     first_level = 1;
	     last_level = 1;
	end;


	do IDX = first_level to last_level;
	     if DPS8xxM then
		call ioa_ ("^/LEVEL [^a]^/", AM_LEVEL (IDX));
	     do idx = first_entry to last_entry;

		seg_ptr = addrel (baseptr (binary (ptw_ptrs (idx).pointer, 15)), (binary (ptw_ptrs (idx).pageno, 12) * 16));
						/* get a pointer to the segment, so we can get its name */

		if ^DPS8xxM then
		     call ioa_$rsnnl ("^6x^2d", usage_string, (0),
		     binary (ptw_ptrs (idx).usage, 4));

		else call ioa_$rsnnl ("^2x^6b", usage_string, (0),
		     ptw_ptrs (idx).usage);


		call ioa_ ("^8o^2x^[yes^;no ^]^2x^[F^;E^]^2x^8a ^5o ^4o ^[^a^;^s N/A^]^[^/^-*** POSSIBLE DUPLICATE ENTRY ***^]",
		     binary ((ptw_regs (idx).addr || "000000"b), 24),
		     ptw_regs (idx).modif,
		     ptw_ptrs (idx).valid,
		     usage_string,
		     binary (ptw_ptrs (idx).pointer, 15),
		     divide (binary (ptw_ptrs (idx).pageno, 12), 16, 12, 0),
		     ptw_ptrs (idx).valid,		/* skip the naming if this PTWAM entry is empty */
		     namef_ (seg_ptr, odsp),
		     dup_entry (idx));
	     end;

	     first_entry = last_entry + 1;
	     last_entry = first_entry +15;

	end;
	return;

/*  */

get_args:	proc (sp_bit, err_bit, nregs);

/* get_args - internal proc to process args for assosiative memory display requests */

dcl (sp_bit, err_bit) bit (1);
dcl  am_data_ptr pointer;
dcl  prds_ptr pointer;
dcl  def_offset fixed bin (18);
dcl  nregs fixed bin;
dcl  tempp ptr;
dcl  last_three_sets bit (48*36) based;			/* # regs * bits/words in the rest of the set */


	     err_bit = "0"b;			/* reset error flag */
	     dumpptr = dumpp (0);			/* set dump ptr to comp. 0 */

	     if argcnt < 1 then do;			/* if no args, prt assosiative mem. from dump */
		sdw_regs_ptr = addr (dump.amsdwregs);
		sdw_ptrs_ptr = addr (dump.amsdwptrs);
		ptw_regs_ptr = addr (dump.amptwregs);
		ptw_ptrs_ptr = addr (dump.amptwptrs);
	     end;

	     else do;				/* user wants them from prds */
		if argcnt > 1 | arg (1) ^= "prds" then do; /* tell user what to type */
		     call ioa_ ("Usage: am^[sdw^;ptw^] {prds}", sp_bit);
		     err_bit = "1"b;		/* set error flag */
		     return;
		end;

		call ol_dump_util_$get_ptr (prdsseg, prds_ptr, code, odsp); /* get ptr to prds */
		if prds_ptr = null then do;		/* did'nt find */
		     err_bit = "1"b;		/* set error flag */
		     return;
		end;

		call ring0_get_$definition_given_slt (null, "prds", "am_data",
		     def_offset, type, code, sltptr, sltnp, defptr);

		am_data_ptr = addrel (prds_ptr, def_offset);

		call ring0_get_$definition_given_slt (null, "prds", "ptw_am_regs",
		     def_offset, type, code, sltptr, sltnp, defptr);
		ptw_regs_ptr = addrel (prds_ptr, def_offset);


		call ring0_get_$definition_given_slt (null, "prds", "ptw_am_ptrs",
		     def_offset, type, code, sltptr, sltnp, defptr);
		ptw_ptrs_ptr = addrel (prds_ptr, def_offset);


		call ring0_get_$definition_given_slt (null, "prds", "sdw_am_regs",
		     def_offset, type, code, sltptr, sltnp, defptr);
		sdw_regs_ptr = addrel (prds_ptr, def_offset);


		call ring0_get_$definition_given_slt (null, "prds", "sdw_am_ptrs",
		     def_offset, type, code, sltptr, sltnp, defptr);

		sdw_ptrs_ptr = addrel (prds_ptr, def_offset);

	     end;

	     call ioa_ ("^[PTW^;SDW^] Associative Memory (from CPU ^a) ^[at time of dump^;at prds$am_data^].",
		sp_bit, tag (CPU_NO), (argcnt = 0));

	     tempp = addrel (ptw_regs_ptr, 16);		/* base to 2'nd set of am */
	     if tempp -> last_three_sets = "0"b then	/* if second set is zero then */
		nregs = 15;			/* am from l68 */
	     else nregs = 63;			/* am from dps8/70m */
	     if nregs = 15 then
		DPS8xxM = "0"b;
	     else DPS8xxM = "1"b;


	     return;
	end get_args;

%page;

validate_am: proc;

dcl  no_regs fixed bin;
dcl (i, j) fixed bin;
dcl  a_odsp ptr;

validate_am_sdw: entry (no_regs, a_odsp);


	     dup_entry (*) = "0"b;

	     do i = 0 to no_regs -1;
		do j = i+1 to no_regs;
		     if (sdw_ptrs (i).valid & sdw_ptrs (j).valid) then do;

			if sdw_regs (i).addr = sdw_regs (j).addr then do;
			     dup_entry (i) = "1"b;
			     dup_entry (j) = "1"b;
			end;

			else if sdw_ptrs (i).pointer = sdw_ptrs (j).pointer then do;
			     dup_entry (i) = "1"b;
			     dup_entry (j) = "1"b;
			end;

			else if sdw_ptrs (i).usage = sdw_ptrs (j).usage then do;
			     if ^DPS8xxM then do;	/* if its not a dps8 */
				dup_entry (i) = "1"b; /* for dps8 it is LRU not usage ctr */
				dup_entry (j) = "1"b;
			     end;
			end;


			if (dup_entry (i) & dup_entry (j)) then do;
			     if sdw_regs (i).addr = sdw_regs (j).addr then
				if sdw_regs (i).bound = sdw_regs (j).bound then
				     if (sdw_regs (i).r2 & sdw_regs (i).r3) ^=
				     (sdw_regs (j).r2 & sdw_regs (j).r3) then
					if sdw_ptrs (i).pointer ^= sdw_ptrs (j).pointer then do;
					     if DPS8xxM then go to cancel_dup_sdw;
					     if sdw_ptrs (i).usage ^= sdw_ptrs (j).usage then do;
cancel_dup_sdw:					dup_entry (i), dup_entry (j) = "0"b;
					     end;
					end;
			end;


			if ((dup_entry (i) & dup_entry (j)) & val_btld) then do;
			     call ioa_ ("^/Possible duplicate entry in SDW associative memory for CPU ^a;^/", tag (CPU_NO));
			     call ioa_ (" ADDRESS^2xRINGS^2xBOUND^2xREWPUGC^4xCL F/E USAGE-CT SEG # SEG_NAME");
			     reg_ptr = addr (sdw_regs (i));
			     ptr_ptr = addr (sdw_ptrs (i));
			     call display_mismatch_sdw (reg_ptr, ptr_ptr);
			     reg_ptr = addr (sdw_regs (j));
			     ptr_ptr = addr (sdw_ptrs (j));
			     call display_mismatch_sdw (reg_ptr, ptr_ptr);
			end;


		     end;
		end;
	     end;
	     return;

validate_am_ptw: entry (no_regs, a_odsp);


	     dup_entry (*) = "0"b;

	     do i = 0 to no_regs -1;
		do j = i+1 to no_regs;
		     if (ptw_ptrs (i).valid & ptw_ptrs (j).valid) then do;
			if ptw_regs (i).addr = ptw_regs (j).addr then do;
			     dup_entry (i) = "1"b;
			     dup_entry (j) = "1"b;
			end;

			else if ptw_ptrs (i).usage = ptw_ptrs (j).usage then do;
			     if ^DPS8xxM then do;	/* if its not a dps8 */
				dup_entry (i) = "1"b;
				dup_entry (j) = "1"b;
			     end;
			end;

			else if (ptw_ptrs (i).pointer = ptw_ptrs (j).pointer)
			& (ptw_ptrs (i).pageno = ptw_ptrs (j).pageno) then do;
			     dup_entry (i) = "1"b;
			     dup_entry (j) = "1"b;
			end;



			if (dup_entry (i) & dup_entry (j)) then do;
			     if ptw_regs (i).addr = ptw_regs (j).addr then
				if ptw_ptrs (i).pointer ^= ptw_ptrs (j).pointer then do;
				     if DPS8xxM then go to cancel_dup_ptw;
				     if ptw_ptrs (i).usage ^= ptw_ptrs (j).usage then do;
cancel_dup_ptw:				dup_entry (i), dup_entry (j) = "0"b;
				     end;
				end;
			end;



			if ((dup_entry (i) & dup_entry (j)) & val_btld) then do;
			     call ioa_ ("^/Possible duplicate entry in PTW associative memory for CPU ^a;^/", tag (CPU_NO));
			     call ioa_ (" ADDRESS^3xM^2xF/E USAGE_CT SEG # PAGE");
			     reg_ptr = addr (ptw_regs (i));
			     ptr_ptr = addr (ptw_ptrs (i));

			     call display_mismatch_ptw (reg_ptr, ptr_ptr);
			     reg_ptr = addr (ptw_regs (j));
			     ptr_ptr = addr (ptw_ptrs (j));
			     call display_mismatch_ptw (reg_ptr, ptr_ptr);
			end;
		     end;
		end;
	     end;
	     return;


	end validate_am;
%page;
/* This routine compares the assoc mem to what is in the dseg/sst to validate
   the contents of SDW and PTW assoc mem are correct */


validate_am_btld: entry (odsp, seg_len, CPU_NO, icode);
dcl (tempp, tdsegp, tasdwp, taptwp, sptp) ptr;
dcl  tdsdw bit (72) based (tdsegp);
dcl  tasdw bit (72) based (tasdwp);
dcl  tdsdw_mask bit (72) init ("777777777770777777777777"b3);
dcl  tsptw bit (36) based (sptp);
dcl  taptw bit (36) based (taptwp);
dcl  tsptw_mask bit (36) init ("777777000100"b3);
dcl (seg_len, icode) fixed bin (35);
dcl (j, ptsz) fixed bin;
dcl  dump_dbr fixed bin (24);
dcl  last_three_sets bit (48*36) based;			/* # regs * bits/words in the rest of the set */


	val_btld = "1"b;
	dumpptr = dumpp (0);			/* set dump ptr to comp. 0 */

	dump_dbr = fixed (substr (dump.dbr, 1, 24), 24);
	ol_dump_struc.boot_dbr = dump_dbr;
	call ol_dump_util_$fnd_dbr (dump_dbr, seg_len, icode, odsp);


	sdw_regs_ptr = addr (dump.amsdwregs);
	sdw_ptrs_ptr = addr (dump.amsdwptrs);
	ptw_ptrs_ptr = addr (dump.amptwptrs);
	ptw_regs_ptr = addr (dump.amptwregs);


	tempp = addrel (sdw_ptrs_ptr, 16);		/* base to 2'nd set of am */
	if tempp -> last_three_sets = "0"b then		/* if second set is zero then */
	     nregs = 15;				/* am from l68 */
	else nregs = 63;				/* am from dps8/70m */
	if nregs = 15 then
	     DPS8xxM = "0"b;
	else DPS8xxM = "1"b;


VALIDATE_SDW:


	call validate_am_sdw (nregs, odsp);


	do idx = 0 to nregs;			/* cycle thru ass mem */
	     if sdw_ptrs (idx).valid then do;		/* only for valid entries */
		tdsegp = addrel (dsegp, (bin (sdw_ptrs (idx).pointer, 15) * 2));
		tasdwp = addr (sdw_regs (idx));
		if (tdsdw & tdsdw_mask) ^= tasdw then do;
		     call ioa_ ("^/Mis-Match between SDWAM and dseg on BOS CPU (^a);^/", tag (CPU_NO));

		     call ioa_ (" ADDRESS^2xRINGS^2xBOUND^2xREWPUGC^4xCL F/E USAGE-CT SEG # SEG_NAME");
		     reg_ptr = addr (sdw_regs (idx));
		     ptr_ptr = addr (sdw_ptrs (idx));
		     call display_mismatch_sdw (reg_ptr, ptr_ptr);
		     call display_dseg_entry (tdsegp);
		end;


	     end;
	end;

VALIDATE_PTW:

	call validate_am_ptw (nregs, odsp);

	if sstptr = null then
	     return;

	sstp = sstptr;

	do idx = 0 to nregs;
	     if ptw_ptrs (idx).valid then do;
		sdwp = addr (dsegp -> sdwa (bin (ptw_ptrs (idx).pointer, 15)));
		ptp = ptr (sstp, fixed (sdw.add, 24) - fixed (sst.ptwbase, 18)); /* get a ptr to page tbl */
		astep = addrel (ptp, -sst.astsize);
		ptsz = sst.pts (fixed (aste.ptsi, 3));
		sptp = addrel (ptp, (divide (binary (ptw_ptrs (idx).pageno, 12), 16, 12, 0)));
		taptwp = addr (ptw_regs (idx));
		if (tsptw & tsptw_mask) ^= taptw then do; /* found a bad one */
		     call ioa_ ("^/Mis-Match between PTWAM and page table on BOS CPU (^a);^/", tag (CPU_NO));
		     call ioa_ (" ADDRESS^3xM^2xF/E USAGE_CT SEG # PAGE");
		     reg_ptr = addr (ptw_regs (idx));
		     ptr_ptr = addr (ptw_ptrs (idx));
		     call display_mismatch_ptw (reg_ptr, ptr_ptr);
		     call display_sst_entry (sptp);
		end;
	     end;
	end;



	return;
%page;
display_mismatch_sdw: proc (a_sdw_reg_ptr, a_sdw_ptr_ptr);
dcl (a_sdw_reg_ptr, a_sdw_ptr_ptr) ptr;
dcl 1 a_sdw_reg aligned like amsdwreg based (a_sdw_reg_ptr);
dcl 1 a_sdw_ptr aligned like amsdwptr based (a_sdw_ptr_ptr);



	     call ioa_$rsnnl ("^[R^; ^]^[E^; ^]^[W^; ^]^[P^; ^]^[U^; ^]^[G^; ^]^[C^; ^]",
		flag_string, (0),			/* generate the REWPUGC string */
		a_sdw_reg.read,
		a_sdw_reg.execute,
		a_sdw_reg.write,
		a_sdw_reg.privileged,
		a_sdw_reg.unpaged,
		a_sdw_reg.entry_bound_sw,
		a_sdw_reg.cache);


	     if ^DPS8xxM then
		call ioa_$rsnnl ("^6x^2d", usage_string, (0),
		binary (a_sdw_ptr.usage, 4));

	     else call ioa_$rsnnl ("^2x^6b", usage_string, (0),
		a_sdw_ptr.usage);



	     call ioa_ ("^8o^2x^1.3b,^1.3b,^1.3b ^6o^2x^7a ^[^5o^;^s^4x-^]^2x^[F^;E^]^2x^8a ^5o",
		binary (a_sdw_reg.addr, 24),
		a_sdw_reg.r1,
		a_sdw_reg.r2,
		a_sdw_reg.r3,
		binary ((a_sdw_reg.bound || "0000"b), 18),
		flag_string,
		((^a_sdw_reg.entry_bound_sw) & a_sdw_reg.execute), /* skip next if there is none */
		binary (a_sdw_reg.cl, 14),
		a_sdw_ptr.valid,
		usage_string,
		binary (a_sdw_ptr.pointer, 15));
	     return;
	end;
%page;

display_dseg_entry: proc (dseg_entp);
dcl  dseg_entp ptr;
dcl  flag_string char (7);
dcl 1 dseg_ent based (dseg_entp),
   (2 addr bit (24),
    2 ring1 bit (3),
    2 ring2 bit (3),
    2 ring3 bit (3),
    2 pad1 bit (4),
    2 bounds bit (14),
    2 rd bit (1),
    2 ex bit (1),
    2 wrt bit (1),
    2 priv bit (1),
    2 unp bit (1),
    2 ebs bit (1),
    2 cache bit (1),
    2 cl bit (14)) unal;


	     call ioa_$rsnnl ("^[R^; ^]^[E^; ^]^[W^; ^]^[P^; ^]^[U^; ^]^[G^; ^]^[C^; ^]",
		flag_string, (0),			/* generate the REWPUGC string */
		dseg_ent.rd,
		dseg_ent.ex,
		dseg_ent.wrt,
		dseg_ent.priv,
		dseg_ent.unp,
		dseg_ent.ebs,
		dseg_ent.cache);

	     call ioa_ ("^8o^2x^1.3b,^1.3b,^1.3b ^6o^2x^7a ^[^5o^]^-(dseg entry)",
		binary (dseg_ent.addr, 24), dseg_ent.ring1, dseg_ent.ring2,
		dseg_ent.ring3, binary ((dseg_ent.bounds || "0000"b), 18),
		flag_string, ((^dseg_ent.ebs) & dseg_ent.ex),
		binary (dseg_ent.cl, 14));


	     return;
	end;
%page;
display_mismatch_ptw: proc (a_ptw_reg_ptr, a_ptw_ptr_ptr);
dcl (a_ptw_reg_ptr, a_ptw_ptr_ptr) ptr;
dcl 1 a_ptw_reg aligned like amptwreg based (a_ptw_reg_ptr);
dcl 1 a_ptw_ptr aligned like amptwptr based (a_ptw_ptr_ptr);


	     if ^DPS8xxM then
		call ioa_$rsnnl ("^6x^2d", usage_string, (0),
		binary (a_ptw_ptr.usage, 4));

	     else call ioa_$rsnnl ("^2x^6b", usage_string, (0),
		a_ptw_ptr.usage);


	     call ioa_ ("^8o^2x^[yes^;no ^]^2x^[F^;E^]^2x^8a ^5o ^4o",
		binary ((a_ptw_reg.addr || "000000"b), 24),
		a_ptw_reg.modif,
		a_ptw_ptr.valid,
		usage_string,
		binary (a_ptw_ptr.pointer, 15),
		divide (binary (a_ptw_ptr.pageno, 12), 16, 12, 0));
	     return;
	end;


%page;
display_sst_entry: proc (a_ptp);

dcl  a_ptp ptr;
dcl 1 page_wd based (a_ptp),
   (2 addr bit (18),
    2 padd1 bit (11),
    2 modifd bit (1),
    2 padd2 bit (6) unal);


	     call ioa_ ("^8o^2x^[yes^;no ^]^2x(page table in memory)",
		binary ((page_wd.addr || "000000"b), 24),
		page_wd.modifd);

	     return;
	end;



%page;

%include ol_dump_struc;

%page;

%include assoc_mem;

%page;

%include bos_dump;

%page;

%include sst;

%page;

%include aste;

%page;

%include sdw;

%page;

%include ptw;


     end display_am_;




		    display_ast_.pl1                10/01/82  1523.5rew 10/01/82  1523.6       97515



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


display_ast_:
     proc (odsp);

/* **********************************************************************
   * Routine to display the ASTE/PT of a segment.                       *
   * Modified June 1981 by Warren Johnson to add the asbadr entrypoint  *
   * to display the absolute address given segment and offset.          *
   * Modified March 1982 by J. Bongiovanni for new PVTE		  *
   * Modified August 1982 by E. N. Kittlitz to move core map.           *
   ********************************************************************** */

dcl  ring0_get_$segptr_given_slt entry (char (*), char (*), ptr, fixed (35), ptr, ptr);
dcl (ioa_$nnl, ioa_, ioa_$rsnnl) entry options (variable);
dcl  cv_oct_check_ entry (char (*), fixed (35)) returns (fixed (35));
dcl  ol_dump_util_$get_ptr entry (fixed, ptr, fixed (35), ptr);
dcl  ol_dump_util_$get_segno entry (char (32) varying, ptr) returns (fixed);
dcl  ol_dump_util_$dump_oct entry (ptr, fixed, fixed);
dcl  namef_$no_comp entry (ptr, ptr) returns (char (*));
dcl  get_line_length_$switch entry (ptr, fixed (35)) returns (fixed);
dcl  date_time_ entry (fixed (71), char (*) aligned);

dcl (i, segno, offset, pts, ll, ln, page, word) fixed;
dcl (segln, code) fixed (35);
dcl  sptp ptr;
dcl  pt_word fixed based (ptp);
dcl  repeat bit (1);
dcl (core_add, fdevadd) fixed (18);
dcl  devadd bit (22);
dcl  devadd_add_type bit (4) defined (devadd) pos (19);
dcl  devadd_nulled_flag bit (1) defined (devadd);
dcl  devadd_record_no bit (18) defined (devadd);
dcl  last_ptw bit (36);
dcl (str, cdevadd) char (16);
dcl  pvtx_name char (16) varying;
dcl  vs char (99) varying;

dcl 1 local_cme aligned like cme;

dcl (ptr, addr, substr, null, addrel, rel, baseno, baseptr, divide, fixed, length, size, unspec, mod) builtin;
%page (1);
	if argcnt < 1
	then do;
	     call ioa_ ("ast segno/name");
	     return;
	end;

	if sstptr = null ()
	then do;
	     call ioa_ ("No sst.");
	     return;
	end;

	if coremapptr = null ()
	then call ioa_ ("No core_map. Device addresses of in-core pages are shown as 0.");

	sstp = sstptr;				/* copy arg */
	ll = get_line_length_$switch (null (), segln);	/* get terminal lin length */
	segno = cv_oct_check_ (substr (arg (1), 1, length (arg (1))), code); /* get segment number in binary */
	if code ^= 0
	then do;					/* non-octal, try special name */
	     segno = ol_dump_util_$get_segno (arg (1), odsp);
	     if segno = -1
	     then return;
	     else;
	end;
	else;

	sdwp = addr (dsegp -> sdwa (segno));		/* get a pointer to the SDW for the segment */
	if sdw.unpaged
	then do;					/* see if the segment is paged */
	     call ioa_ ("Segment ^a is not paged.", arg (1));
	     return;
	end;
	else;

	astep = ptr (sstp, fixed (sdw.add, 24) -
	     fixed (sst.ptwbase, 18) - sst.astsize);	/* get a pointer to the ast entry */
	offset = fixed (rel (astep), 18) - fixed (rel (sstp), 18);
	call ioa_ ("ASTE For Segment ^a (seg ^o), at SST|^o^/",
	     namef_$no_comp (baseptr (segno), odsp), segno, offset);
	call ol_dump_util_$dump_oct (astep, offset, sst.astsize);
	call ring0_get_$segptr_given_slt ("", "pvt", pvtp, code, sltptr, sltnp); /* get ptr to pvt */
	if code ^= 0
	then pvtx_name = "??????";
	else do;
	     call ol_dump_util_$get_ptr (fixed (baseno (pvtp), 15), pvtp, segln, odsp);
	     if pvtp = null ()
	     then pvtx_name = "??????";
	     else do;
		pvt_arrayp = addr (pvt.array);
		pvtep = addr (pvt_array (aste.pvtx));
		if substr (pvte.devname, 1, 3) = "dsk" then
		     call ioa_$rsnnl ("^a device ^d", pvtx_name, ln, pvte.devname, pvte.logical_area_number);
		else pvtx_name = "";
	     end;
	end;

	call ioa_ ("^/uid = ^w, vtocx ^o on pvtx ^o^[ (^a)^]",
	     fixed (aste.uid, 35), aste.vtocx, aste.pvtx, pvtx_name ^= "", pvtx_name);
	call ioa_ ("max len ^d, ^d recs used, ^d in core, cur len ^d",
	     fixed (aste.msl, 9), fixed (aste.records, 9), fixed (aste.np, 9), fixed (aste.csl, 9));
	if aste.dtu
	then call ioa_ ("Used ^a", dtc (aste.dtu));
	else call ioa_ ("Not updated as used.");
	if aste.dtm
	then call ioa_ ("Modified ^a", dtc (aste.dtm));
	else call ioa_ ("Not updated as modified.");
	if aste.par_astep | aste.infl | aste.infp
	then call ioa_ ("Par astep = ^o, Son = ^o, brother = ^o", fixed (aste.par_astep, 18),
	     fixed (aste.infp, 18), fixed (aste.infl, 18));
	if aste.uid = "0"b
	then call ioa_ ("Hardcore segno = ^o", fixed (aste.strp, 18));
	else if aste.strp
	then call ioa_ ("Trailer thread = ^o", fixed (aste.strp, 18));
	else call ioa_ ("No trailer thread.");

	if aste.dirsw
	then do;
	     if aste.master_dir
	     then call ioa_ ("Aste for a master directory.");
	     else call ioa_ ("Aste for a directory.");
	end;
	else if aste.master_dir
	then call ioa_ ("Says master dir, but not directory.");
	else;
	if aste.quota (0) ^= 0 | aste.quota (1) ^= 0
	then call ioa_ ("     Quota (S D) = (^d ^d)", aste.quota (0), aste.quota (1));
	else;
	if aste.used (0) ^= 0 | aste.used (1) ^= 0
	then call ioa_ ("     QUsed (S D) = (^d ^d)", aste.used (0), aste.used (1));
	else;

	vs = "";
	call ioa_$nnl ("^/");
	if aste.usedf
	then call vput ("usedf ");
	else;
	if aste.init
	then call vput ("init ");
	else;
	if aste.gtus
	then call vput ("gtus ");
	else;
	if aste.hc
	then call vput ("hc ");
	else;
	if aste.hc_sdw
	then call vput ("hc_sdw ");
	else;
	if aste.any_access_on
	then call vput ("aaon ");
	else;
	if aste.write_access_on
	then call vput ("waccon ");
	else;
	if aste.inhibit_cache
	then call vput ("inhcch ");
	else;
	if aste.explicit_deact_ok
	then call vput ("xdok ");
	else;
	if aste.ehs
	then call vput ("ehs ");
	else;
	if aste.nqsw
	then call vput ("nqsw ");
	else;
	if aste.tqsw (0)
	then call vput ("seg-tqsw ");
	else;
	if aste.tqsw (1)
	then call vput ("dir-tqsw ");
	else;
	if aste.fmchanged
	then call vput ("fmch ");
	else;
	if aste.fms
	then call vput ("fms ");
	else;
	if aste.npfs
	then call vput ("npfs ");
	else;
	if aste.gtpd
	then call vput ("gtpd ");
	else;
	if aste.dnzp
	then call vput ("dnzp ");
	else;
	if aste.per_process
	then call vput ("per_proc ");
	else;
	if aste.fmchanged1
	then call vput ("fmch1 ");
	else;
	if aste.damaged
	then call vput ("damaged ");
	else;
	if aste.ddnp
	then call vput ("ddnp ");
	else;
	if aste.pack_ovfl
	then call vput ("oopv ");
	else;

	call vput ("FLUSH");
	pts = sst.pts (fixed (aste.ptsi, 3));
	call ioa_ ("^/PAGE      PT        DEVADD^/");

	repeat = "0"b;
	sptp = addrel (astep, size (aste));

	do i = 0 to pts-1 by 1;
	     ptp = addr (sptp -> ptwa (i));
	     devadd = ptp -> mptw.devadd;
	     if i ^= 0 & i ^= pts - 1 & unspec (ptw) = last_ptw
	     & devadd_add_type = "000"b & ^ptw.df
	     then repeat = "1"b;
	     else do;
		if repeat
		then do;
		     repeat = "0"b;
		     call ioa_ ("====");
		end;
		else;
		if ptw.df
		then do;
		     core_add = fixed (devadd_record_no);
		     core_add = divide (core_add, 16, 18, 0);
		     if coremapptr ^= null then do;
		          cmep = addr (coremapptr -> cma (core_add));
		          devadd = cme.devadd;
		     end;
		     else devadd = "0"b;
		end;
		fdevadd = fixed (devadd_record_no);
		if devadd_add_type & add_type.non_null
		then call ioa_$rsnnl ("^6o", cdevadd, ln, fdevadd);
		else cdevadd = " null";
		if devadd_nulled_flag & devadd_add_type = add_type.disk
		then do;
		     devadd_nulled_flag = "0"b;
		     fdevadd = fixed (devadd_record_no);
		     call ioa_ ("^4o  ^w  ^6o (nulled)", i, pt_word, fdevadd);
		end;
		else call ioa_ ("^4o  ^w  ^6a", i, pt_word, cdevadd);
	     end;
	     last_ptw = unspec (ptw);
	end;

	return;
%page (1);
absadr:	entry (odsp);

	if argcnt < 1
	then do;
absadr_label:
	     call ioa_ ("absadr segno/name {offset}");
	     return;
	end;
	else;


	if sstptr = null ()
	then do;
	     call ioa_ ("No sst.");
	     return;
	end;
	else;

	sstp = sstptr;
	segno = cv_oct_check_ (substr (arg (1), 1, length (arg (1))), code); /* get segment number in binary */
	if code ^= 0
	then do;					/* non-octal, try special name */
	     segno = ol_dump_util_$get_segno (arg (1), odsp);
	     if segno = -1
	     then return;
	     else;
	end;
	else;

	if argcnt < 2 then do;
	     offset = 0;
	     go to GET_SDWP;
	end;


	offset = cv_oct_check_ (substr (arg (2), 1, length (arg (2))), code); /* get segment offset */
	if code ^= 0
	then go to absadr_label;
	else;

GET_SDWP:
	sdwp = addr (dsegp -> sdwa (segno));		/* get a pointer to the SDW for the segment */
	if sdw.unpaged				/* see if the segment is paged */
	then if sdw.df				/* segment fault? */
	     then do;				/* nope, got the address */
		offset = fixed (sdw.add, 24) + offset;
		call ioa_ ("^o", offset);
		return;
	     end;
	     else do;				/* segment not active */
		call ioa_ ("Segment ^o is unpaged and faulted.", segno);
		return;
	     end;
	else;

	word = mod (offset, 1024);			/* get word within page */
	page = divide (offset, 1024, 17, 0);		/* get PTW index */

	ptp = ptr (sstp, fixed (sdw.add, 24) - fixed (sst.ptwbase, 18)); /* get a pointer to page table */
	astep = addrel (ptp, -sst.astsize);		/* get ptr to ASTE */
	pts = sst.pts (fixed (aste.ptsi, 3));
	if page >= pts
	then do;
	     call ioa_ ("Offset ^o not found in segment ^o.", offset, segno);

	     return;

	end;
	else ptp = addrel (ptp, page);		/* get ptr to PTW */
	if ptw.df					/* is page in memory? */
	then do;					/* yes, it's there */
	     offset = fixed (ptw.add, 18) * 64;
	     offset = offset + word;
	     call ioa_ ("^o", offset);
	end;
	else call ioa_ ("Page ^o of segment ^o is not in main memory.",
	     page, segno);

	return;
%page (1);
vput:	proc (x);

dcl  x char (*) parameter;

	     if x = "FLUSH" | length (vs) > ll - 10
	     then do;
		if vs = ""
		then call ioa_ ("No Flags.");
		else call ioa_ ("Flags: ^a", vs);
		vs = "";
	     end;
	     else;
	     vs = vs || x;

	     return;

	end vput;
%page (1);
dtc:	proc (b) returns (char (24));

dcl  b bit (36) parameter;
dcl  buf bit (72);
dcl  fbuf fixed (71);
dcl  date char (24) aligned;

	     buf = "0"b;
	     substr (buf, 21) = b;
	     unspec (fbuf) = unspec (buf);
	     call date_time_ (fbuf, date);

	     return (date);

	end dtc;
%page (1);
%include ol_dump_struc;
%page (1);
%include sst;
%page (1);
%include aste;
%page (1);
%include cmp;
%page (1);
%include pvt;
%page (1);
%include pvte;
%page (1);
%include add_type;
%page (1);
%include sdw;
%page (1);
%include ptw;


     end display_ast_;




		    display_dump_.pl1               11/10/82  1713.3rew 11/10/82  0916.5       83070



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

/*  Modified Oct 1982 by Rich Coppola to not change DBR when dumping HC seg
   as it was a needless operation.
*/

display_dump_: proc (odsp);

% include ol_dump_struc;

dcl  db_print entry (ptr, char (*) aligned, ptr, char (*), fixed bin, fixed bin, ptr, fixed bin, fixed bin);
dcl  cv_oct_check_ entry (char (*), fixed bin) returns (fixed bin);
dcl  object_info_$display entry (ptr, fixed bin (24), ptr, fixed bin (35));
dcl  ring0_get_$name_given_slt entry (char (*) aligned, char (*) aligned, ptr, fixed bin, ptr, ptr);
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl (ioa_, com_err_) entry options (variable);
dcl  ol_dump_util_$fnd_dbr entry (fixed bin (24), fixed bin (35), fixed bin, ptr);
dcl  ol_dump_util_$get_ptr entry (fixed bin, ptr, fixed bin (35), ptr); /* :: */
dcl  ol_dump_util_$get_segno entry (char (32) varying, ptr) returns (fixed bin); /* :: */
dcl  ol_dump_util_$fnd_hcseg entry (char (32) aligned, ptr, fixed bin (24), ptr); /* :: */
dcl  ol_dump_util_$dump_oct entry (ptr, fixed bin, fixed bin);
dcl  ol_dump_util_$is_hardcore_seg entry (fixed bin, ptr) returns (bit (1));
dcl  namef_ entry (ptr, ptr) returns (char (*));

dcl (segln, bcode) fixed bin (35);
dcl (i, j, count, first, segno, code, k, edoc, offset) fixed bin;
dcl (substr, unspec, fixed, length, ptr, addr, addrel, rel, divide, null, baseptr) builtin;
dcl 1 oi aligned like object_info;			/* For compatibility with new object segment */
dcl  char_type char (1) aligned;
dcl  ename char (32) aligned;
dcl (mem_add, dbrsvm, sdwad) fixed bin (24) aligned;
dcl  bitcnt fixed bin (24);
dcl (p, pm) ptr;
dcl (init_hard, premature_end, mem_dump, offset_flag) bit (1) unaligned;
dcl  paged char (7) varying;
dcl  off18 fixed bin (18) aligned;
dcl  saved_kstseg fixed bin;
dcl  saved_kstptr ptr;


/*  */
	if argcnt < 1 | argcnt > 5 then do;		/* user goofed, tell him what to type in */
dump_label:
	     call ioa_ ("dump segno/name/mem {addr {+_offset}} {count} {mode}");
	     return;
	end;
	char_type = "o";				/* set up default mode (octal dump) */
	count = 1;				/* and unit count */
	first = 0;				/* and starting address */
	saved_kstseg = kstseg;			/* save values of the */
	saved_kstptr = kstptr;			/* process as it will change */
	dbrsvm = dbrsv;
	sstp = sstptr;

/*  process arguments */

	if argcnt = 1 then				/* only segno/name specified */
	     if arg (1) = "mem" then			/* mem dump needs address */
		go to dump_label;
	     else count = -1;			/* set count later (segment length) */
	else if argcnt >= 2 then do;
	     mem_add = cv_oct_check_ (substr (arg (2), 1, length (arg (2))), code);
	     if code ^= 0 then
		go to dump_label;
	     if arg (1) ^= "mem" then
		first = mem_add;
	end;
	if argcnt >= 3 then do;			/* process count or offset arg */
	     if substr (arg (3), 1, 1) = "+" | substr (arg (3), 1, 1) = "-" then do;
		offset = cv_oct_check_ (substr (arg (3), 2, length (arg (3)) - 1), code);
		if code ^= 0 then
		     go to dump_label;
		if substr (arg (3), 1, 1) = "+" then
		     first = first + offset;
		else first = first - offset;
		if first < 0 then
		     first = 0;
		offset_flag = "1"b;
	     end;
	     else do;
		count = cv_oct_check_ (substr (arg (3), 1, length (arg (3))), code);
		if code ^= 0 then
		     go to dump_label;
		offset_flag = "0"b;
	     end;
	end;
	if argcnt >= 4 then do;
	     if offset_flag then do;
		count = cv_oct_check_ (substr (arg (4), 1, length (arg (4))), code);
		if code ^= 0 then
		     go to dump_label;
	     end;
	     else char_type = arg (4);
	end;
	if argcnt = 5 then
	     char_type = arg (5);
	if arg (1) = "mem" then do;
	     if code ^= 0 then go to dump_label;
	     off18 = 0;
	     mem_dump = "1"b;
	     if offset_flag then
		mem_add = mem_add + first;
	     substr (unspec (off18), 19, 14) = substr (unspec (mem_add), 13, 14);

	     do k = 0 to no_apt;
		aptep = addrel (aptap, k * apt_entry_size);
		sdwp = addr (aptep -> apte.dbr);
		call ol_dump_util_$fnd_dbr (fixed (sdw.add, 24), segln, edoc, odsp);
		if edoc ^= -1 then do;
		     edoc = divide (segln, 2, 17, 0) - 1;
		     do i = 0 to edoc;
			sdwp = addrel (dsegp, i * 2);
			if sdw.add | i = 1 then do;
			     sdwad = fixed (sdw.add, 24);
			     if sdw.unpaged then do;
				j = ((fixed (sdw.bound, 14) + 1) * 16) - 1;
				if mem_add >= sdwad & mem_add <= sdwad + j then do;
				     first = mem_add - sdwad;
				     paged = "unpaged";
				     go to match;
				end;
				else go to nxt_lap;
			     end;
			     else do;
				ptp = addrel (sstptr, sdwad - fixed (sst.ptwbase, 18));
				astep = addrel (ptp, - (sst.astsize));
				do j = 0 to fixed (aste.csl, 9);
				     if ^ptw.df then go to pt_lap;
				     if fixed (ptw.add, 18) = off18 then do;
					first = j * 1024 + mod (mem_add, 1024);
					paged = "paged";
					go to match;
				     end;
pt_lap:
				     ptp = addrel (ptp, 1);
				end;
			     end;
			end;
nxt_lap:
		     end;
		end;
	     end;
	     call ioa_ ("Memory Address ^o is in free store", mem_add);
	     go to restore_dbr;

match:
	     pm = addrel (baseptr (i), first);
	     call ioa_ ("^o = ^a segment ^p ^a Process DBR ^o", mem_add, paged, pm,
		namef_ (pm, odsp), dbrsv);
	     segno = i;
	end;
	else do;					/* a segment dump requested */
	     segno = cv_oct_check_ (substr (arg (1), 1, length (arg (1))), code);
	     if code ^= 0 then do;
		segno = ol_dump_util_$get_segno (arg (1), odsp);
		if segno = -1 then return;
	     end;
	     mem_dump = "0"b;
	end;


	call ol_dump_util_$get_ptr (segno, p, segln, odsp);
	if count = -1 then count = segln;		/* requested to dump entire segment */
	premature_end, init_hard = "0"b;


	if p ^= null then do;
	     if first > segln then do;		/* check limits */
		call ioa_ ("Offset ^o not found in segment ^o. Last location = ^o",
		     first, segno, segln);
		go to restore_dbr;
	     end;

	     if char_type = "a" then do;
		if first + count * 4 > segln then do;
		     count = (segln - first) * 4;
		     premature_end = "1"b;
		end;
	     end;

	     else do;
		if first + count > segln then do;
		     count = segln - first;
		     premature_end = "1"b;
		end;
	     end;
	     if char_type = "o" then
		call ol_dump_util_$dump_oct (addrel (p, first), first, count);
	     else call db_print (null, "", addrel (p, first), (char_type), first, count, null, 0, 0);
	     if premature_end then
		call ioa_ ("End of segment");
	     go to restore_dbr;
	end;
ck_mem:
	if mem_dump then
	     go to restore_dbr;


	if p = null then do;			/* Pick up segment from search dirs */
	     p = baseptr (segno);
	     call ring0_get_$name_given_slt ("", ename, p, code, sltptr, sltnp);
	     if code ^= 0 then do;
		call ioa_ ("Segment ^o not found", segno);
		go to restore_dbr;
	     end;
	     call ol_dump_util_$fnd_hcseg (ename, p, bitcnt, odsp); /* go find segment in search dirs */
	     if p = null then
		go to restore_dbr;			/* if not found */
	     init_hard = "1"b;
	     call ioa_ ("Segment ^a (^o) found in ^a", ename, segno, search_dirs (libx));
	     oi.version_number = object_info_version_2;	/* Set version for object_info_ */
	     call object_info_$display (p, bitcnt, addr (oi), bcode);
	     if bcode ^= 0 then do;
		call com_err_ (bcode, "ol_dump");
		go to term_h;
	     end;
	     if first > oi.tlng then do;		/* Requested words not in text section */
		if first < oi.tlng + oi.dlng then do;
		     i = first - fixed (rel (oi.defp));
		     call ioa_ ("^o|^o found in definition section|^o", segno, first, i);
		     go to term_h;
		end;
		else if first < oi.tlng + oi.dlng + oi.llng then do;
		     i = first - fixed (rel (oi.linkp));
		     call ioa_ ("^o|^o found in linkage section|^o", segno, first, i);
		     go to term_h;
		end;
		else if first < oi.tlng + oi.dlng + oi.llng + oi.slng then do;
		     i = first - fixed (rel (oi.symbp));
		     call ioa_ ("^o|^o found in symbol section |^o", segno, first, i);
		     go to term_h;
		end;
		else call ioa_ ("Offset ^o not found in segment ^o", first, segno);
		go to term_h;
	     end;
	     else if first + count > oi.tlng then do;
		count = oi.tlng - first;
		premature_end = "1"b;
	     end;
	end;
	p = addrel (p, first);
	call ioa_ ("^/");				/* print out new line */
	call db_print (null, "", p, "i", first, count, null, 0, 0);
	if premature_end then
	     call ioa_ ("End of text section ");
term_h:
	if init_hard then
	     call hcs_$terminate_noname (p, bcode);	/* terminate segment */

restore_dbr:

	dbrsv = dbrsvm;
	kstseg = saved_kstseg;
	kstptr = saved_kstptr;
	call ol_dump_util_$fnd_dbr (dbrsvm, segln, i, odsp);
	call ol_dump_util_$get_ptr (kstseg, kstptr, segln, odsp);
	return;
%page;
% include aste;
% include sst;
% include object_info;
% include sdw;
% include ptw;
% include apte;

     end display_dump_;




		    display_dump_events.pl1         10/01/82  1523.5rew 10/01/82  1523.6      104013



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


display_dump_events:
     proc;

/* Program to examine an FDUMP, extracting all interesting time-stamped events,
   and printing these events in reverse-chronological order.

   Calling sequence:

   display_dump_events {Control Arguments}

   where Control Arguments are the following:

   -erf <ERF number>         (Required)

   -dump_dir, -dd {dump directory}     Specifies the directory in which the
   dump lives (default is >dumps)

   -last, -lt <number of events>        Specifies the number of events to print
   (default is to print all)

   -time <time in seconds>              Specifies the time in seconds before
   the dump was taken when events were interesting
   (default is 10)

   -long, -lg		       long output format (default)

   -short, -sh		       short output format (1 line/event)


   Subroutine interface:

   dcl display_dump_events_ (char (32), char (168), fixed bin, fixed bin (71), bit (1));

   call display_dump_events_ (erf_no, dump_dir, num_events, time_interval, mode);


   where:
   erf_no          is the erf to be examined.
   dump_dir        directory the containing the erf (null if >dumps).
   num_events      as defined above for last.
   time_interval   as defined above for time.
   mode            specifies long or short output format, a "1"b specifies long.

   Written March 1981 by J. Bongiovanni

   Modified April 1981 by Rich Coppola to add subroutine interface so it
   could be used by ol_dump.
   */


/* Automatic */

dcl  argl fixed bin (21);
dcl  argno fixed bin;
dcl  argp ptr;
dcl  code fixed bin (35);
dcl  definitions_ptr ptr;
dcl  done_segs bit (1);
dcl  dummy_name char (32) varying;
dcl  dump_dir char (168);
dcl  dump_name char (32) varying;
dcl  erf char (32);
dcl  error_message char (40);
dcl  found_erf bit (1);
dcl  have_erf bit (1);
dcl  long_flag bit (1);
dcl  nargs fixed bin;
dcl  nametbl_ptr ptr;
dcl  number_events fixed bin;
dcl  seg_name char (32);
dcl  short_flag bit (1);
dcl  slt_ptr ptr;
dcl  seg_no pic "zzz9";
dcl  temp_segs (N_TEMP_SEGS) ptr init ((N_TEMP_SEGS) null ());
dcl  time_interval fixed bin (71);
dcl  why char (40);


/* Static */

dcl  DEFAULT_DUMP_DIR char (6) init (">dumps") int static options (constant);
dcl  MYNAME char (19) init ("display_dump_events") int static options (constant);
dcl  N_TEMP_SEGS fixed bin init (5) int static options (constant);


/* Based */

dcl  arg char (argl) based (argp);
dcl  based_area area based (temp_segs (1));
dcl 1 erf_segs aligned based (temp_segs (2)),
    2 n_segs fixed bin,
    2 segp (0 refer (n_segs)) ptr;



/* 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_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  ioa_ entry () options (variable);
dcl  process_dump_segments entry ((*) ptr, ptr, ptr, ptr, fixed bin, fixed bin (71), bit (1));
dcl  release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
dcl  setup_dump_segments entry ((*) ptr, ptr, ptr, ptr, fixed bin, char (*), fixed bin (35));


/* External */

dcl  error_table_$badopt fixed bin (35) external;
dcl  error_table_$inconsistent fixed bin (35) external;
dcl  error_table_$namedup fixed bin (35) external;
dcl  error_table_$noarg fixed bin (35) external;
dcl  error_table_$segknown fixed bin (35) external;

/* Condition */

dcl  cleanup condition;
dcl  conversion condition;

/* Builtin */

dcl  addr builtin;
dcl  after builtin;
dcl  before builtin;
dcl  empty builtin;
dcl  fixed builtin;
dcl  ltrim builtin;
dcl  null builtin;
dcl  reverse builtin;
dcl  rtrim builtin;
dcl  sum builtin;


%page;

/* Pick up and validate arguments */

	have_erf = "0"b;
	short_flag, long_flag = "0"b;
	dump_dir = DEFAULT_DUMP_DIR;
	call cu_$arg_count (nargs, code);
	if code ^= 0 then do;
	     call com_err_ (code, MYNAME);
	     return;
	end;

	if nargs = 0 then do;
	     call com_err_ (0, MYNAME, "Usage is: ^a {Control Arguments}^/^10xControl Arguments: -erf {erf no}     -dump_dir {dump directory}^/^20x-time {interval in sec.}     -last {number events}     -short     -long",
		MYNAME);
	     return;
	end;

	number_events = 0;
	time_interval = 10000000;
	do argno = 1 to nargs;
	     call cu_$arg_ptr (argno, argp, argl, code);
	     if arg = "-dump_dir" | arg = "-dd" then do;
		argno = argno + 1;
		if argno > nargs then do;
		     why = "dump_dir";
MISSING:		     call com_err_ (error_table_$noarg, MYNAME, why);
		     return;
		end;
		call cu_$arg_ptr (argno, argp, argl, code);
		call absolute_pathname_ (arg, dump_dir, code);
		if code ^= 0 then do;
		     call com_err_ (code, MYNAME, arg);
		     return;
		end;
	     end;

	     else if arg = "-erf" then do;
		have_erf = "1"b;
		argno = argno + 1;
		why = "erf";
		if argno > nargs then goto MISSING;
		call cu_$arg_ptr (argno, argp, argl, code);
		erf = arg;
	     end;
	     else if arg = "-last" | arg = "-lt" then do;
		why = "Number events";
		argno = argno + 1;
		if argno > nargs then goto MISSING;
		call cu_$arg_ptr (argno, argp, argl, code);
		on conversion goto BAD_ARGUMENT;
		number_events = fixed (arg);
		revert conversion;
	     end;
	     else if arg = "-time" then do;
		why = "Time interval";
		argno = argno + 1;
		if argno > nargs then goto MISSING;
		call cu_$arg_ptr (argno, argp, argl, code);
		on conversion goto BAD_ARGUMENT;
		time_interval = fixed (arg) * 1000000;
		revert conversion;
	     end;
	     else if arg = "-short" | arg = "-sh"
	     then short_flag = "1"b;
	     else if arg = "-long" | arg = "-lg"
	     then long_flag = "1"b;
	     else do;
		call com_err_ (error_table_$badopt, MYNAME, arg);
		return;
	     end;
	end;

	if ^have_erf then do;
	     call com_err_ (error_table_$noarg, MYNAME, "erf");
	     return;
	end;

	if short_flag & long_flag then do;
	     call com_err_ (error_table_$inconsistent, MYNAME, "-short and -long");
	     return;
	end;
	long_flag = ^short_flag;

	go to start;


%page;

display_dump_events_:
	entry (sub_erf_no, sub_dump_dir, sub_events, sub_time, sub_mode);


dcl  sub_erf_no char (32);
dcl  sub_dump_dir char (168);
dcl  sub_events fixed bin;
dcl  sub_time fixed bin (71);
dcl  sub_mode bit (1);

	why = "";
	if sub_erf_no ^= "" then do;
	     erf = sub_erf_no;
	     have_erf = "1"b;
	end;

	else do;
	     why = "erf";
	     go to MISSING;
	end;


	if sub_dump_dir ^= "" then do;
	     call absolute_pathname_ (sub_dump_dir, dump_dir, code);

	     if code ^= 0 then do;
	        why = "dump_dir";
		go to MISSING;
		end;
	end;

	else dump_dir = DEFAULT_DUMP_DIR;


	if sub_events ^= 0 then
	     number_events = sub_events;
	else number_events = 0;

	if sub_time ^= 0 then
	     time_interval = sub_time * 1000000;
	else time_interval = 10000000;

	if sub_mode = "0"b then
	     short_flag = "1"b;
	else short_flag = "0"b;

	long_flag = ^short_flag;

start:

	on cleanup call Mr_Clean;			/* who else?				*/

	call get_temp_segments_ (MYNAME, temp_segs, code);
	if code ^= 0 then do;
	     call com_err_ (code, MYNAME, "Getting temp segs.");
	     return;
	end;

	based_area = empty ();
	erf_segs.n_segs = 0;


/* Find the first segment of the dump segment, thereby its name					*/


	call hcs_$star_ (dump_dir, "**.*." || erf, 3, addr (based_area),
	     star_entry_count, star_entry_ptr, star_names_ptr,
	     code);				/* setup for subroutine			*/
	if code = 0 then
	     found_erf = find_prefix_suffix ("", ".0." || erf, dump_name);
	if code ^= 0 | ^found_erf then do;
	     call com_err_ (code, MYNAME, "ERF ^a not found", erf);
	     call Mr_Clean;
	     return;
	end;

/* Fill array with pointers to components of dump segment						*/

	done_segs = "0"b;
	do while (^done_segs);
	     seg_no = erf_segs.n_segs;
	     seg_name = "." || ltrim (seg_no) || "." || erf;
	     if find_prefix_suffix (dump_name, seg_name, dummy_name) then do;
		seg_name = dump_name || seg_name;
		call hcs_$initiate (dump_dir, seg_name, "", 0, 1, segp (erf_segs.n_segs + 1), code);
		if code ^= 0 then
		     if code ^= error_table_$namedup & code ^= error_table_$segknown then do;
			call com_err_ (code, MYNAME, seg_name);
			call Mr_Clean;
			return;
		     end;
		erf_segs.n_segs = erf_segs.n_segs + 1;
	     end;
	     else done_segs = "1"b;
	end;

/* Setup some critical segment from the dump file							*/

	slt_ptr = temp_segs (3);
	definitions_ptr = temp_segs (4);
	nametbl_ptr = temp_segs (5);
	call setup_dump_segments (segp, slt_ptr, definitions_ptr,
	     nametbl_ptr, 0, error_message, code);
	if code ^= 0 then do;
	     call Mr_Clean;
	     call com_err_ (code, MYNAME, "Error from setup_dump_segments. ^a.",
		error_message);
	     return;
	end;

/* Process the dump 									*/

	call ioa_ ("^/^/Dump Events from ERF ^a^7xDumped on ^a at ^a^/^/",
	     erf, before (dump_name, "."), after (dump_name, "."));

	call process_dump_segments (segp, slt_ptr, definitions_ptr, nametbl_ptr, number_events,
	     time_interval, long_flag);


	call Mr_Clean;
	return;


BAD_ARGUMENT:
	call com_err_ (error_table_$badopt, MYNAME, why);
	return;

%page;
/* Internal procedure to scan array of names returned by star_
   based on suplied prefix and suffix criteria							*/


find_prefix_suffix:
	proc (prefix, suffix, name) returns (bit (1));

dcl  name char (*) varying;
dcl  prefix char (*) varying;
dcl  suffix char (*);

dcl  found bit (1);
dcl  name_no fixed bin;
dcl  reverse_suffix char (32) varying;
dcl  star_no fixed bin;


	     reverse_suffix = reverse (rtrim (suffix));
	     found = "0"b;
	     star_no = 1;

	     do while (^found & star_no <= star_entry_count);
		if star_entries (star_no).type ^= star_DIRECTORY then do; /* don't want directories		*/
		     name_no = star_entries (star_no).nindex;
		     do while (^found & name_no <= star_entries (star_no).nnames
			     + star_entries (star_no).nindex);
			if before (star_names (name_no), prefix) = "" then
			     if before (reverse (rtrim (star_names (name_no))),
			     reverse_suffix) = "" then do;
				name = reverse (after (reverse (rtrim (star_names (name_no))),
				     reverse_suffix));
				if name ^= "" then found = "1"b;
			     end;
			name_no = name_no + 1;
		     end;
		end;
		star_no = star_no + 1;
	     end;


	     return (found);
	end find_prefix_suffix;


%page;
/* Internal Procedure to to cleanup								*/


Mr_Clean:
	proc;

dcl  code fixed bin (35);
dcl  n fixed bin;

	     if temp_segs (2) ^= null ()
	     then if erf_segs.n_segs > 0 then do n = 1 to erf_segs.n_segs;
		     call hcs_$terminate_noname (segp (n), code);
		end;
	     if temp_segs (1) ^= null () then
		call release_temp_segments_ (MYNAME, temp_segs, code);

	end Mr_Clean;

%page;

%include star_structures;

     end display_dump_events;




		    display_frame_args_.pl1         10/01/82  1523.5rew 10/01/82  1523.6      170604



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


display_frame_args_: proc (segno, stkp, stkbp, odsp);

/* Modified August, 1980 by Rich Coppola to fix bug causing oob when number */
/* of args ^= number expected. */
/* Modified April 1981 by Rich Coppola to fix bug causing causing OOSB attempting to output too many chars */

dcl  segno fixed bin;				/* segno of current stack seg */
dcl (stkp, stkbp) ptr;
% include ol_dump_struc;
dcl  ol_dump_util_$get_ptr entry (fixed bin, ptr, fixed bin (35), ptr);
dcl  ol_dump_util_$get_ptr_quiet entry (fixed bin, ptr, fixed bin (35), ptr);
dcl  ol_dump_util_$fnd_hcseg entry (char (32) aligned, ptr, fixed bin (24), ptr);
dcl  ol_dump_util_$p_valid entry (ptr) returns (bit (1));
dcl  hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (24),
     fixed bin (2), ptr, fixed bin (35));
dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  namef_$no_comp entry (ptr, ptr) returns (char (*));
dcl  namef_ entry (ptr, ptr) returns (char (*));
dcl (ioa_, ioa_$rsnnl) entry options (variable);
dcl  get_entry_arg_descs_ entry (ptr, fixed bin, (*) ptr, fixed bin (35));
dcl  decode_descriptor_ entry (ptr, fixed bin, fixed bin,
     bit (1) aligned, fixed bin, fixed bin, fixed bin);

dcl 1 arglist aligned based (ap),
    2 arg_count bit (17) unaligned,
    2 pad1 bit (1) unaligned,
    2 argcode bit (18) unaligned,			/* 4 for interproc call, 8 for internal call */
    2 desc_count bit (17) unaligned,
    2 pad2 bit (1) unaligned,
    2 argzero bit (18) unaligned;

dcl 1 desc based aligned,
    2 version bit (1) unal,
    2 type fixed bin (5) unal,
    2 packed bit (1) unal,
    2 ndims bit (4) unal,
    2 length fixed bin (23) unal;

dcl (sl, code) fixed bin (35);
dcl (i, j, k, a_cnt, d_cnt, epargs, type, dims, strl, scale) fixed bin;
dcl (ap, sb, tp, ep, dp, argp, fabp, fsbp) ptr;
dcl  b_ptr ptr based;
dcl  b_cnt fixed bin (24);
dcl  dir_name char (168) aligned;
dcl  sname char (32) aligned;
dcl  p_buf char (64);
dcl  argstr char (30);
dcl  descp (64) ptr;
dcl  h_desc (64) bit (36);
dcl  argptr (64) ptr;
dcl  c75 char (75) aligned;
dcl  ptr_array (0: 10) ptr based (argp);
dcl  bit17 bit (17) unaligned based (argp);
dcl  fword (4) fixed bin (35) based (argp);
dcl  flword (2) float bin based (argp);
dcl  dblword (2) float bin (63) based (argp);
dcl  dblfix (2) fixed bin (71) based (argp);
dcl  power float bin;
dcl  bit_string bit (strl) based (argp);
dcl  char_string char (strl) based (argp);
dcl  ttype char (20);

dcl (null, length, addr, addrel, baseno, divide, fixed, rel, hbound, substr, index, bin, float, max, min, search, verify, mod) builtin;

dcl (wordfix, wordfix1) fixed bin (35),
     hword fixed bin (35) based (argp),
     owordfix bit (36) aligned based (addr (wordfix)),
     owordfix1 bit (36) aligned based (addr (wordfix1)),
    (word_dblfix, word_dblfix1) fixed bin (71),
     oword_dblfix bit (72) aligned based (addr (word_dblfix)),
     oword_dblfix1 bit (72) aligned based (addr (word_dblfix1)),
    (wordflo, wordflo1) float bin (63),
     owordflo bit (72) aligned based (addr (wordflo)),
     owordflo1 bit (72) aligned based (addr (wordflo1)),
    (worddec, worddec1) fixed dec (59),
     oworddec char (60) based (addr (worddec)),
     oworddec1 char (60) based (addr (worddec1)),
    (worddecflo, worddecflo1) float dec (59),
     oworddecflo char (61) based (addr (worddecflo)),
     oworddecflo1 char (61) based (addr (worddecflo1));

dcl  bbits bit (1000) based (argp);
dcl  bchrs char (1000) based (argp);

dcl  packed bit (1) aligned;


dcl 1 fab based (fabp) aligned,
    2 switch bit (36),
    2 filename char (32);

dcl  packptr ptr based unal;

dcl 1 lv based (argp) aligned,
    2 ptr ptr,
    2 stack ptr;

dcl  NTYPES fixed bin int static options (constant) init (24);
dcl  argtypes (23) char (20) aligned int static init
    ("fixed bin",					/* real, short */
     "fixed bin",					/* real, long */
     "float bin",					/* real, short */
     "float bin",					/* real, long */
     "cplx fixed bin",				/* short */
     "cplx fixed bin",				/* long */
     "cplx float bin",				/* short */
     "cplx float bin",				/* long */
     "fixed dec",
     "float dec",
     "Cplx fixed dec",
     "Cplx float dec",
     "Pointer",
     "Offset",
     "Label",
     "Entry",
     "Structure",
     "Area",
     "Bit",
     "Varying bit",
     "Char",
     "Char varying",
     "File");

dcl  LEGAL char (96) int static options (constant) init	/* Printables except PAD, but with BS */
    (" !""#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~");

/*  */

	sb = stkbp;
	sp = stkp;
	if ^ol_dump_util_$p_valid (addr (arg_ptr)) then do; /* make sure we have a good ptr */
badap:
	     call ioa_ ("^/^8xARG Pointer invalid^/");
	     return;
	end;
	if arg_ptr = null then			/* we don't need to look at null arg ptrs */
	     go to badap;
	ap = arg_ptr;
	call ioa_ ("^/^8xARG list @ ^p", ap);

/* find out if arg list is in this stack seg */

	if fixed (baseno (ap)) ^= segno then do;
	     call ol_dump_util_$get_ptr_quiet (fixed (baseno (ap)), tp, sl, odsp);
	     if tp = null then			/* can't find seg in dump */
		call find_seg (ap, tp);		/* try search dirs */
	     if tp = null then do;			/* no luck give the bad news */
		call ioa_ ("^8xCannot initiate segment #^o (^a)",
		     fixed (baseno (ap)), namef_$no_comp (ap, odsp));
		return;
	     end;
	     ap = addrel (tp, rel (ap));
	     sb = tp;
	end;
	else ap = addrel (sb, rel (ap));
	a_cnt = fixed (arg_count);
	d_cnt = fixed (desc_count);

/* do some consistancy checking on the arg list first */

	if argzero ^= (18)"0"b then
	     go to badah;
	if argcode ^= "000004"b3 then
	     if argcode ^= "000010"b3 then
	     if argcode ^= "000000"b3 then
		go to badah;
	if d_cnt ^= 0 then
	     if d_cnt ^= a_cnt then do;
badah:
		call ioa_ ("^8xARG list header invalid^/");
		return;
	     end;
	if a_cnt = 0 then do;
	     call ioa_ ("^8xNo arguments^/");
	     return;
	end;

/* process arg pointers */

	dp = addrel (ap, 2);
	do i = 1 to a_cnt;				/* set up each arg ptr */
	     if ^ol_dump_util_$p_valid (addr (dp -> b_ptr)) then
		argptr (i) = null;
	     else do;
		if baseno (dp -> b_ptr) = baseno (sp -> stack_frame.arg_ptr) then
		     argptr (i) = addrel (sb, fixed (rel (dp -> b_ptr)));
		else do;
		     call ol_dump_util_$get_ptr_quiet (fixed (baseno (dp -> b_ptr)), tp, sl, odsp);
		     if tp = null then
			call find_seg (dp -> b_ptr, tp);
		     if tp = null then
			argptr (i) = null;
		     else argptr (i) = addrel (tp, fixed (rel (dp -> b_ptr)));
		end;
		if dp -> its.bit_offset &
		argptr (i) ^= null then do;
		     tp = addr (argptr (i));
		     tp -> its.bit_offset = dp -> its.bit_offset;
		end;
	     end;
	     dp = addrel (dp, 2);			/* get nxt arg pointer */
	end;

	if d_cnt = 0 then do;			/* no descriptors, use entry ptr or hueristics */
	     if ^ol_dump_util_$p_valid (addr (entry_ptr)) then
		go to hur_desc;			/* entry ptr invalid, use huristics */
	     call find_seg (entry_ptr, ep);		/* initiate the entry ptr segment */
	     if ep = null then			/* can't initiate seg, use huristics */
		go to hur_desc;
	     call huristicate_desc;

	     ep = addrel (ep, rel (entry_ptr));
	     call get_entry_arg_descs_ (ep, epargs, descp, code); /* get descriptors from entry seq */
	     if code ^= 0 then do;			/* no luck, huristicate descriptors */
hur_desc:
		call huristicate_desc;
	     end;
	end;

/* we will use the descriptors from the arg list */

	else do;
	     dp = addrel (ap, (a_cnt * 2) + 2);
	     do i = 1 to a_cnt;			/* set up each descriptor ptr */
		if argptr (i) ^= null then do;
		     if ^ol_dump_util_$p_valid (addr (dp -> b_ptr)) then
			go to hur_desc;		/* form descriptor with huristics */
		     else do;
			if baseno (dp -> b_ptr) = baseno (sp -> stack_frame.arg_ptr) then /* found desc in this stack seg */
			     descp (i) = addrel (sb, fixed (rel (dp -> b_ptr)));
			else do;
			     call ol_dump_util_$get_ptr_quiet (fixed (baseno (dp -> b_ptr)), tp, sl, odsp);
			     if tp = null then	/* can't find in dump, look online */
				call find_seg (dp -> b_ptr, tp);
			     if tp = null then
				go to hur_desc;	/* form descriptor with huristics */
			     else descp (i) = addrel (tp, fixed (rel (dp -> b_ptr)));
			end;
			if dp -> its.bit_offset then do;
			     tp = addr (descp (i));
			     tp -> its.bit_offset = dp -> its.bit_offset;
			end;
		     end;
		     if descp (i) -> desc.type > 23 | descp (i) -> desc.type <= 0 then
			go to hur_desc;
		end;
		else descp (i) = null;

		dp = addrel (dp, 2);		/* get nxt descriptor */
	     end;
	end;

/* We now should have valid pointers to args and descriptors. Now process args */

	dp = addrel (ap, 2);			/* set up dump arg ptr */
	do j = 1 to a_cnt;
	     call ioa_$rsnnl ("^8xARG ^2d @ ^p", argstr, i, j, dp -> b_ptr);
	     if argptr (j) = null then
		call ioa_ ("^29a Arg pointer invalid", argstr);
	     else do;
		call decode_descriptor_ (descp (j), 0, type, packed, dims, strl, scale);
		argp = argptr (j);			/* copy arg ptr */
		if type < -1 then go to unknown_type;
		if type > NTYPES then go to unknown_type;
		if type <= 12 then
		     call ioa_$rsnnl ("^a (^d,^d):^-", ttype, i,
		     argtypes (type), strl, scale);
		go to form (type);


/* Real fixed binary short. */

form (1):		if packed then do;			/* Unpack item if packed. */
		     wordfix = 0;
		     substr (owordfix, 36-strl, strl+1) = substr (bbits, 1, strl+1);
		end;
		else wordfix = fword (1);		/* Else just copy. */
		if scale = 0 then power = 1; else power = 2 ** -scale;
		if wordfix <= 7 then
		     call ioa_ ("^29a - ^a ^d", argstr, ttype, wordfix);
		else call ioa_ ("^29a - ^a ^d (dec) ^o (oct)", argstr, ttype, wordfix, wordfix);
		go to nxtarg;

/* Real fixed binary long. */

form (2):		if packed then do;
		     word_dblfix = 0;
		     substr (oword_dblfix, 72-strl, strl+1) = substr (bbits, 1, strl+1);
		end;
		else word_dblfix = dblfix (1);
		if scale = 0 then power = 1; else power = 2 ** -scale;
		call ioa_ ("^29a - ^a ^w ^w", argstr, ttype, substr (oword_dblfix, 1, 36), substr (oword_dblfix, 37, 36));
		go to nxtarg;

/* Real float binary short. */

form (3):		if packed then do;
		     owordflo = "0"b;
		     substr (owordflo, 1, strl+9) = substr (bbits, 1, strl+9);
		end;
		else wordflo = flword (1);
		call ioa_ ("^29a - ^a ^f", argstr, ttype, wordflo);
		go to nxtarg;

/* Real float binary long. */

form (4):		if packed then do;
		     owordflo = "0"b;
		     substr (owordflo, 1, strl+9) = substr (bbits, 1, strl+9);
		end;
		else wordflo = dblword (1);
		call ioa_ ("^29a - ^a ^f", argstr, ttype, wordflo);
		go to nxtarg;

/* Complex fixed binary short. */

form (5):		if packed then do;
		     wordfix = 0;
		     wordfix1 = 0;
		     substr (owordfix, 36-strl, strl+1) = substr (bbits, 1, strl+1);
		     substr (owordfix1, 36-strl, strl+1) = substr (bbits, strl+2, strl+1);
		end;
		else do;
		     wordfix = fword (1);
		     wordfix1 = fword (2);
		end;
		if scale = 0 then power = 1; else power = 2 ** -scale;
		call ioa_ ("^29a - ^a ^d + ^di", argstr,
		     wordfix, wordfix1);
		go to nxtarg;

/* Complex fixed binary long. */

form (6):		if packed then do;
		     word_dblfix = 0;
		     word_dblfix1 = 0;
		     substr (oword_dblfix, 72-strl, strl+1) = substr (bbits, 1, strl+1);
		     substr (oword_dblfix1, 72-strl, strl+1) = substr (bbits, strl+2, strl+1);
		end;
		else do;
		     word_dblfix = dblfix (1);
		     word_dblfix1 = dblfix (2);
		end;
		if scale = 0 then power = 1; else power = 2 ** -scale;
		call ioa_ ("^29a - ^a ^w ^w + ^w ^wi", argstr,
		     substr (oword_dblfix, 1, 36), substr (oword_dblfix, 37, 36),
		     substr (oword_dblfix1, 1, 36), substr (oword_dblfix1, 37, 36));
		go to nxtarg;

/* Complex float binary short. */

form (7):		if packed then do;
		     owordflo = "0"b;
		     owordflo1 = "0"b;
		     substr (owordflo, 1, strl+9) = substr (bbits, 1, strl+9);
		     substr (owordflo1, 1, strl+9) = substr (bbits, strl+10, strl+9);
		end;
		else do;
		     wordflo = flword (1);
		     wordflo = flword (2);
		end;
		call ioa_ ("^29a - ^a ^f + ^fi", argstr,
		     wordflo, wordflo1);
		go to nxtarg;

/* Complex float binary long. */

form (8):		if packed then do;
		     owordflo = "0"b;
		     owordflo1 = "0"b;
		     substr (owordflo, 1, strl+9) = substr (bbits, 1, strl+9);
		     substr (owordflo1, 1, strl+9) = substr (bbits, strl+10, strl+9);
		end;
		else do;
		     wordflo = dblword (1);
		     wordflo = dblword (2);
		end;
		call ioa_ ("^29a - ^a ^f + ^fi", argstr,
		     wordflo, wordflo1);
		go to nxtarg;

/* Real fixed decimal. */

form (9):		oworddec = (60)"0";
		substr (oworddec, 1, 1) = substr (bchrs, 1, 1);
		substr (oworddec, 60-strl, strl) = substr (bchrs, 2, strl);
		if scale = 0 then power = 1; else power = 10 ** -scale;
		call ioa_ ("^29a - ^a ^f", argstr, ttype, bin (float (worddec*power)));
		go to nxtarg;

/* Real float decimal. */

form (10):	oworddecflo = (61)"0";
		substr (oworddecflo, 1, 1) = substr (bchrs, 1, 1);
		substr (oworddecflo, 60-strl, strl+1) = substr (bchrs, 2, strl+1);
		call ioa_ ("^29a - ^a ^f", argstr, ttype, bin (worddecflo));
		go to nxtarg;

/* Complex fixed decimal. */

form (11):	oworddec, oworddec1 = (60)"0";
		substr (oworddec, 1, 1) = substr (bchrs, 1, 1);
		substr (oworddec, 60-strl, strl) = substr (bchrs, 2, strl);
		substr (oworddec1, 1, 1) = substr (bchrs, strl+2, 1);
		substr (oworddec, 60-strl, strl) = substr (bchrs, strl+3, strl);
		if scale = 0 then power = 1; else power = 10 ** -scale;
		call ioa_ ("^29a - ^a ^f + ^fi", argstr,
		     bin (float (worddec*power)), bin (float (worddec1*power)));
		go to nxtarg;

/* Complex float decimal */

form (12):	oworddecflo, oworddecflo1 = (61)"0";
		substr (oworddecflo, 1, 1) = substr (bchrs, 1, 1);
		substr (oworddecflo, 60-strl, strl+1) = substr (bchrs, 2, strl+1);
		substr (oworddecflo1, 1, 1) = substr (bchrs, strl+3, 1);
		substr (oworddecflo1, 60-strl, strl+1) = substr (bchrs, strl+4, strl+1);
		call ioa_ ("^29a - ^a ^f + ^fi", argstr,
		     bin (worddecflo), bin (worddecflo1));
		go to nxtarg;

/* Pointer. */

form (13):	if packed then do;			/* packed ptr */
		     tp = argp -> packptr;
		     go to pptr;
		end;
		if ol_dump_util_$p_valid (addr (argp -> b_ptr)) then do;
		     tp = argp -> ptr_array (0);
pptr:
		     call ioa_ ("^29a - ^[Packed ^;^]^a:^-^p ^a", argstr, packed,
			argtypes (type), tp, namef_ (tp, odsp));
		end;
		else call ioa_ ("^29a - ^w ^w", argstr, fword (1), fword (2));
		go to nxtarg;

/* Label, entry. */

form (15): form (16):
		call ioa_ ("^29a - ^p ^p ^a^a", argstr, argp -> lv.ptr, argp -> lv.stack,
		     namef_ (argp -> lv.ptr, odsp), namef_ (argp -> lv.stack, odsp));
		go to nxtarg;

/* Bit string. */

form (20):	strl = addrel (argp, -1) -> fword (1);

form (19):	c75 = """";			/* initial quote */
		k = 0;				/* count 1-bits */
		do i = 1 to min (strl, 72);
		     if substr (bit_string, i, 1) then do;
			k = k + 1;
			substr (c75, i+1, 1) = "1";
		     end;
		     else substr (c75, i+1, 1) = "0";
		end;
		substr (c75, i+1, 2) = """b";
		if (strl <= 72 & strl > 1) then	/* Maybe compress representation */
		     if k = 0 then call ioa_$rsnnl (" (^d)""0""b", c75, k, strl);
		     else if k = strl then call ioa_$rsnnl (" (^d)""1""b", c75, k, strl);
		k = mod (strl, 3);
		if k = 0 then
		     call ioa_$rsnnl ("""^.3b""b3", c75, k, substr (bbits, 1, strl));
		call ioa_ ("^29a - ^a (^d):^-^a", argstr, argtypes (type), strl, c75);
		go to nxtarg;

/* Character strings. */

form (22):	strl = max (addrel (argp, -1) -> fword (1), 0);



form (21):	strl = min (80, strl);
		call ioa_ ("^29a - ^a (^d):^-""^a""", argstr, argtypes (type),
		     strl, char_string);
		go to nxtarg;

/* File. */

form (23):	fsbp = ptr_array (2);		/* Locate File Static Block. */
		fabp = ptr_array (1);
		if fsb.open then
		     call ioa_ ("^29a - File ^a - ^a", argstr,
		     fsb.filename, fsb.title);
		else call ioa_ ("^29a - File ^a", argstr, fab.filename);
		go to nxtarg;

/* undetermined type from huristicate_desc */

form (24):
		call ioa_ ("^29a - ^w^-*Bad Descriptor*", argstr, hword);
		go to nxtarg;

/* Offset, or cannot determine type. */

form (-1): form (0): form (14):
		call ioa_ ("^29a - ^w", argstr, fword (1)); /* full word octal */
		go to nxtarg;

/* Types we cannot handle: Area, Structure. */

unknown_type:	call ioa_$rsnnl ("type ^d", ttype, strl, type);
		go to default;

form (17): form (18):
		ttype = argtypes (type);
default:		call ioa_ ("^29a - (^a at ^p) ^w", argstr, ttype, argp, fword (1));

		if dims > 0 then call ioa_ ("^- (^d-dim array)", dims);
		end;
nxtarg:	       dp = addrel (dp, 2);		/* increment arg ptr */

skiparg:	end;
	call ioa_ (" ");
	return;

/*  */

/* find_seg - internal procedure to initiate segment */


find_seg:	proc (inptr, otptr);
dcl (inptr, otptr) ptr;
	     p_buf = namef_$no_comp (inptr, odsp);
	     if substr (p_buf, 1, 1) = ">" then		/* if not hardcore */
		call expand_path_ (addr (p_buf), length (p_buf), addr (dir_name), addr (sname), code);
	     else sname = p_buf;			/* copy for compatibility */
	     if substr (p_buf, 1, 1) ^= ">" | substr (p_buf, 1, 4) = ">sl1" then
		call ol_dump_util_$fnd_hcseg (sname, otptr, b_cnt, odsp);
	     else call hcs_$initiate_count (dir_name, sname, "", b_cnt, 0, otptr, code);
	end find_seg;

/* huristicate_desc - internal procedure to form data descriptors by huristicates */

huristicate_desc: proc;

	     do i = 1 to a_cnt;			/* process 1 descriptor for each arg */
		if argptr (i) ^= null then do;
		     dp, descp (i) = addr (h_desc (i));
		     h_desc (i) = "0"b;
		     dp -> desc.version = "1"b;
		     tp = addr (argptr (i));
		     if substr (tp -> its.offset, 18, 1) ^= "1"b then /* if even offset */
			if tp -> its.bit_offset = "0"b then /* and no bit offset */
			     if ol_dump_util_$p_valid (argptr (i)) then do; /* valid ptr */
				dp -> desc.type = 13; /* set type = to ptr */
				go to ndesc;
			     end;
		     if verify (substr (argptr (i) -> bchrs, 1, 1), LEGAL) = 0 then do; /* char string */
			dp -> desc.type = 21;	/* set type to char string */
			dp -> desc.length = verify (argptr (i) -> bchrs, LEGAL) - 1;
		     end;
		     else dp -> desc.type = 24;	/* cannot huristicate desc */
		end;
		else descp (i) = null;
ndesc:
	     end;
	end huristicate_desc;

/*  */
% include stack_frame;
% include its;
% include plio2_fsb;

     end display_frame_args_;




		    display_mchist_.pl1             11/10/82  1713.3rew 11/10/82  1051.9       83196



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


display_mchist_: proc (odsp);



% include ol_dump_struc;

dcl  ring0_get_$definition_given_slt entry (ptr, char (*), char (*), fixed bin (18),
     fixed bin, fixed bin (35), ptr, ptr, ptr);
dcl  ol_dump_util_$get_ptr_given_dbr entry (fixed bin (24), fixed bin, ptr, fixed bin (35), ptr);
dcl  ol_dump_util_$get_ptr entry (fixed bin, ptr, fixed bin (35), ptr);
dcl  ol_dump_util_$fnd_dbr entry (fixed bin (24), fixed bin (35), fixed bin, ptr);
dcl (ioa_, ioa_$nnl) entry options (variable);
dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl  display_regs_$prt_mc_ entry (ptr, ptr, fixed bin (18), fixed bin, char (32), bit (1));
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  release_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  com_err_ entry options (variable);

dcl (i, j, count, first, apte_offset, apte_idx, exstate, type, rel_apte) fixed bin;
dcl  def_offset fixed bin (18);
dcl (oct_code, code, segln) fixed bin (35);
dcl (lg_sw, tmr) bit (1);
dcl (fixed, addrel, addr, null, baseno, substr, length) builtin;
dcl  w (0 : 63) fixed bin based;
dcl  usbuf char (32) based (p);
dcl (p, cpup) ptr;
dcl  statopt (0 : 5) char (3) int static options (constant) init
    ("emp", "run", "rdy", "wat", "blk", "stp");
dcl  process_st (0 : 5) char (7) varying int static options (constant) init
    ("empty", "running", "ready", "waiting", "blocked", "stopped");
dcl  tag (0 : 7) char (1) int static options (constant) init
    ("a", "b", "c", "d", "e", "f", "g", "h");
dcl  mcdesc_table (6)char (32) int static options (constant) init (
     "Page Fault Data", "Fim Data", "Signal Data", "Interrupt Data", "System Trouble Data", "Fim Data");
dcl  cpu_prds (0:7) bit (1) aligned;
dcl  cpu_no fixed bin (3) based (cpup) aligned;
dcl  temp_seg_ptr ptr;
dcl  user_ptr ptr;
dcl  hold_dbr fixed bin (24);
dcl  time char (24) aligned;
dcl 01 sort_info based (temp_seg_ptr),
    02 n fixed bin (24),
    02 mce (1:1000) aligned like based_mce;
dcl  mce_ptr ptr;
dcl 01 based_mce aligned based (mce_ptr),
    02 mc_time fixed bin (71),
    02 apte_idx fixed bin,
    02 apte_offset fixed bin,
    02 dbr fixed bin (24),
    02 def_offset fixed bin (18),
    02 user_ptr ptr,
    02 mcptr ptr,
    02 segn fixed bin,
    02 desc_idx fixed bin;

dcl  cleanup condition;

/* apt - entry to display an apt entry */


	if argcnt < 1 then do;
proc_label:
	     call ioa_ ("mchist no/state/cur/all (lg)");
	     return;
	end;

	if tcdp = null then do;

notcd:	     call ioa_ ("No tc_data.");
	     return;
	end;

	lg_sw = "0"b;

	if argcnt = 2 then
	     if arg (2) = "lg" then			/* user wants an octal dump of the apt entry */
		lg_sw = "1"b;
	count = 1;				/* default is only 1 process */

	first = cv_oct_check_ (substr (arg (1), 1, length (arg (1))), oct_code); /* convert the process number to octal */

	if oct_code ^= 0 then do;
	     first = 0;
	     count = no_apt;
	     if arg (1) = "all" | arg (1) = "cur" then go to proc_ok;
	     do i = 0 to 5;
		if arg (1) = statopt (i) then do;
		     exstate = i;
		     go to proc_ok;
		end;
	     end;
	end;

proc_ok:

	temp_seg_ptr = null ();
	call get_temp_segment_ ("ol_dump", temp_seg_ptr, code);

	if code ^= 0 then do;
	     call com_err_ ("ol_dump", code);
	     return;
	end;

	on cleanup begin;
	     call ol_dump_util_$fnd_dbr (hold_dbr, segln, j, odsp);
	     call ol_dump_util_$get_ptr (ol_dump_struc.kstseg, ol_dump_struc.kstptr,
		segln, odsp);
	     call release_temp_segment_ ("ol_dump", temp_seg_ptr, code);
	end;

	sort_info.n = 0;
	cpu_prds (*) = "0"b;


	tmr = "0"b;

	do apte_idx = first to first+count-1 while (^tmr);
	     aptep = addrel (aptap, apte_idx*ol_dump_struc.apt_entry_size); /* get apointer to the process to look at */
	     sdwp = addr (aptep -> apte.dbr);
	     if oct_code = 0 | arg (1) = "all" then go to pproc;
	     if arg (1) = "cur" then
		if fixed (sdw.add, 24) = dbrsv then
		     tmr = "1"b;			/* set terminate condition */
		else go to pproclp;
	     else if fixed (aptep -> apte.flags.state, 18) ^= exstate then go to pproclp;

pproc:
	     apte_offset = fixed (rel (aptep), 18) -fixed (rel (tcdp), 18);

	     user_ptr = null ();
	     call ol_dump_util_$get_ptr_given_dbr (fixed (sdw.add, 24), pdsseg, p, segln, odsp);
	     if p = null () then goto try_prds;

	     call ring0_get_$definition_given_slt (null (), "pds", "process_group_id",
		def_offset, type, code, sltptr, sltnp, defptr);
	     user_ptr = addrel (p, def_offset);

	     call ring0_get_$definition_given_slt (null, "pds", "page_fault_data",
		def_offset, type, code, sltptr, sltnp, defptr);
	     call store_mc (addrel (p, def_offset), def_offset, pdsseg, 1);

	     call ring0_get_$definition_given_slt (null, "pds", "fim_data",
		def_offset, type, code, sltptr, sltnp, defptr);
	     call store_mc (addrel (p, def_offset), def_offset, pdsseg, 2);

	     call ring0_get_$definition_given_slt (null, "pds", "signal_data",
		def_offset, type, code, sltptr, sltnp, defptr);
	     call store_mc (addrel (p, def_offset), def_offset, pdsseg, 3);

try_prds:

	     call ol_dump_util_$get_ptr_given_dbr (fixed (sdw.add, 24), prdsseg, p, segln, odsp);
	     if p = null () then goto pproclp;

	     call ring0_get_$definition_given_slt (null (), "prds", "processor_tag",
		def_offset, type, code, sltptr, sltnp, defptr);
	     cpup = addrel (p, def_offset);
	     if cpu_prds (cpu_no) then goto pproclp;

	     cpu_prds (cpu_no) = "1"b;

	     call ring0_get_$definition_given_slt (null, "prds", "interrupt_data",
		def_offset, type, code, sltptr, sltnp, defptr);
	     call store_mc (addrel (p, def_offset), def_offset, prdsseg, 4);

	     call ring0_get_$definition_given_slt (null, "prds", "sys_trouble_data",
		def_offset, type, code, sltptr, sltnp, defptr);
	     call store_mc (addrel (p, def_offset), def_offset, prdsseg, 5);

	     call ring0_get_$definition_given_slt (null, "prds", "fim_data",
		def_offset, type, code, sltptr, sltnp, defptr);
	     call store_mc (addrel (p, def_offset), def_offset, prdsseg, 6);

pproclp:
	end;

	if sort_info.n = 0 then do;
	     call ioa_ ("No machine conditions to sort.");
	     goto exit;
	end;

	call sort_mce;

	hold_dbr = dbrsv;
	do i = 1 to sort_info.n;
	     mce_ptr = addr (sort_info.mce (i));
	     call ioa_ ("^/APTE #^o  ADDR ^o  DBR ^o  USERID ^[^a^;?^s^]",
		based_mce.apte_idx, based_mce.apte_offset, based_mce.dbr,
		based_mce.user_ptr ^= null (), based_mce.user_ptr -> usbuf);

	     call ol_dump_util_$fnd_dbr (based_mce.dbr, segln, j, odsp);
	     call ol_dump_util_$get_ptr (ol_dump_struc.kstseg, ol_dump_struc.kstptr, segln, odsp);
	     call display_regs_$prt_mc_ (odsp, based_mce.mcptr, based_mce.def_offset,
		based_mce.segn, mcdesc_table (based_mce.desc_idx), lg_sw);
	     call ioa_ ("^/^40(- ^)^[^|^]", lg_sw);
	end;

	call ol_dump_util_$fnd_dbr (hold_dbr, segln, j, odsp);
	call ol_dump_util_$get_ptr (ol_dump_struc.kstseg, ol_dump_struc.kstptr, segln, odsp);


exit:	call release_temp_segment_ ("ol_dump", temp_seg_ptr, code);
	return;


/*  This subroutine sorts the mc's into chronoligical order  */

store_mc:	proc (a_mcptr, a_offset, a_segn, a_desc_idx);

dcl  a_mcptr ptr;
dcl  a_offset fixed bin (18);
dcl  a_segn fixed bin;
dcl  a_desc_idx fixed bin;

	     mcp = a_mcptr;


/*	     if mc.fault_time = "0"b then return;	*/


	     sort_info.n = sort_info.n+1;
	     if sort_info.n>1000 then return;

	     sort_info.mce (sort_info.n).mc_time = fixed (mc.fault_time, 71);
	     sort_info.mce (sort_info.n).apte_idx = apte_idx;
	     sort_info.mce (sort_info.n).apte_offset = apte_offset;
	     sort_info.mce (sort_info.n).dbr = fixed (sdw.add, 24);
	     sort_info.mce (sort_info.n).user_ptr = user_ptr;
	     sort_info.mce (sort_info.n).mcptr = mcp;
	     sort_info.mce (sort_info.n).def_offset = a_offset;
	     sort_info.mce (sort_info.n).segn = a_segn;
	     sort_info.mce (sort_info.n).desc_idx = a_desc_idx;

	     return;

	end store_mc;



/* This routine will sort the mc entries into reverse chronological order */


sort_mce:	proc;
dcl (i, j) fixed bin;				/* iteration variables */
dcl 01 temp_mce,
    02 mc_time fixed bin (71),
    02 apte_idx fixed bin,
    02 apte_offset fixed bin,
    02 dbr fixed bin (24),
    02 def_offset fixed bin (18),
    02 user_ptr ptr,
    02 mcptr ptr,
    02 segn fixed bin,
    02 desc_idx fixed bin;

	     do i = 1 to sort_info.n-1;
		do j = i+1 to sort_info.n;
		     if sort_info.mce.mc_time (i) < sort_info.mce.mc_time (j) then do;
			temp_mce = sort_info.mce (i);
			sort_info.mce (i) = sort_info.mce (j);
			sort_info.mce (j) = temp_mce;
		     end;
		end;
	     end;
	     return;
	end sort_mce;


% include apte;

% include sdw;

% include tcm;

%include mc;
     end display_mchist_;




		    display_process_.pl1            11/10/82  1713.3rew 11/10/82  0916.5       96498



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


display_process_: proc (odsp);

/* Modified July, 1980 by R.L. Coppola to fix bug in select of running process
   and display of processes by type.
   Modified Oct 1982 by Rich Coppola to display proc required data properly.

*/

% include ol_dump_struc;

dcl  ring0_get_$definition_given_slt entry (ptr, char (*), char (*), fixed bin (18),
     fixed bin, fixed bin (35), ptr, ptr, ptr);
dcl  ol_dump_util_$get_ptr_given_dbr entry (fixed bin (24), fixed bin, ptr, fixed bin (35), ptr);
dcl  ol_dump_util_$dump_oct entry (ptr, fixed bin, fixed bin);
dcl (ioa_, ioa_$nnl) entry options (variable);
dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin);

dcl (i, j, count, first, offset, exstate, type, rel_apte) fixed bin;
dcl  def_offset fixed bin (18);
dcl (code, segln) fixed bin (35);
dcl (lg_sw, tmr) bit (1);
dcl (fixed, addrel, addr, null, baseno, substr, length) builtin;
dcl  based_bit18 bit (18) aligned based;
dcl  w (0 : 63) fixed bin based;
dcl  usbuf char (32) based (p);
dcl (p, cpup, aptxp) ptr;
dcl  statopt (0 : 6) char (3) int static options (constant) init
    ("emp", "run", "rdy", "wat", "blk", "stp", "ptl");
dcl  statopt1 (6) char (3) int static options (constant) init
    ("run", "rdy", "wat", "blk", "stp", "ptl");
dcl  process_st (0 : 6) char (9) varying int static options (constant) init
    ("empty", "running", "ready", "waiting", "blocked", "stopped", "ptlocking");
dcl  tag (0 : 7) char (1) int static options (constant) init
    ("a", "b", "c", "d", "e", "f", "g", "h");
dcl  cpu_no fixed bin (3) based (cpup) aligned;
dcl  PROCS_REQUIRED char (8) int static options (constant) init
    ("ABCDEFGH");
dcl  cpu_str char (8) var init ("");


dcl  dump_infop ptr;
dcl 1 dump_info based (dump_infop),
    2 no_procs fixed bin,
    2 proc_data (proc_no refer (no_procs)) aligned,
      3 process_no fixed bin,
      3 proc_dbr fixed bin (24),
      3 apte_offs fixed bin,
      3 apte_flags like apte.flags unal,
      3 apte_state bit (18),
      3 apte_process_id bit (36);


/* apt - entry to display an apt entry */

apt:	entry (odsp);

	if argcnt < 1 then do;
proc_label:
	     call ioa_ ("proc no/state/cur/all (lg)");
	     return;
	end;
	if tcdp = null then do;
notcd:	     call ioa_ ("No tc_data.");
	     return;
	end;

	exstate = -123;
	lg_sw = "0"b;
	if argcnt = 2 then
	     if arg (2) = "lg" then			/* user wants an octal dump of the apt entry */
		lg_sw = "1"b;
	count = 1;				/* default is only 1 process */
	first = cv_oct_check_ (substr (arg (1), 1, length (arg (1))), code); /* convert the process number to octal */
	if code ^= 0 then do;
	     first = 0;
	     count = no_apt;
	     if arg (1) = "all" | arg (1) = "cur" | arg (1) = "run" then go to proc_ok;
	     do i = 0 to 6;
		if arg (1) = statopt (i) then do;
		     exstate = i;
		     go to proc_ok;
		end;
	     end;

	     if exstate = -123 then do;		/* bad input */
		call ioa_ ("^/invalid state (^a), accepted states are:^/ ^7(^a, ^) cur.", arg (1), statopt);
		return;
	     end;

	end;
proc_ok:
	call ioa_ ("Active Process Table in tc_data segment (seg. # ^o)^/", tcdseg);
	tmr = "0"b;
	do i = first to first+count-1 while (^tmr);
	     aptep = addrel (aptap, i*ol_dump_struc.apt_entry_size); /* get apointer to the process to look at */
	     sdwp = addr (aptep -> apte.dbr);
	     if code = 0 | arg (1) = "all" | arg (1) = "run" then go to pproc;
	     if arg (1) = "cur" then
		if fixed (sdw.add, 24) = dbrsv then
		     tmr = "1"b;			/* set terminate condition */
		else go to pproclp;
	     else if fixed (aptep -> apte.flags.state, 18) ^= exstate then go to pproclp;
pproc:

	     if arg (1) = "run" & apte.state ^= "000001"b3 then
		go to pproclp;

	     if arg (1) = "run" | arg (1) = "cur" then do;
		call ol_dump_util_$get_ptr_given_dbr (fixed (sdw.add, 24), pdsseg, p, segln, odsp);
		if p = null then go to pproclp;
	     end;
	     offset = fixed (rel (aptep), 18) - fixed (rel (tcdp), 18);
	     call ioa_ ("^/APTE #^o ADDR ^o^/", i, offset);
	     if lg_sw then do;
		call ol_dump_util_$dump_oct (aptep, offset, ol_dump_struc.apt_entry_size);
		call ioa_ (" ");
	     end;
	     call ioa_ ("DBR:^-  ^o^/Processid:  ^12.3b", fixed (sdw.add, 24), apte.processid);
	     if apte.wait_event ^= "0"b then
		call ioa_ ("Event:^-  ^w", apte.wait_event);
	     if apte.lock_id then
		call ioa_ ("Lockid:^-  ^12.3b", apte.lock_id);
	     call ioa_$nnl ("Flags:^-  ");
	     if apte.wakeup_waiting then call ioa_$nnl ("wk_up_waiting ");
	     if apte.stop_pending then call ioa_$nnl ("stop_pending ");
	     if apte.pre_empted then call ioa_$nnl ("pre_empted ");
	     if apte.hproc then call ioa_$nnl ("hproc ");
	     if apte.loaded then call ioa_$nnl ("loaded ");
	     if apte.eligible then call ioa_$nnl ("elig ");
	     if apte.idle then call ioa_$nnl ("idle ");
	     if apte.interaction then call ioa_$nnl ("interaction ");
	     if apte.pre_empt_pending then call ioa_$nnl ("pre_empt_p ");
	     if apte.always_loaded then call ioa_$nnl ("always_loaded ");
	     if apte.dbr_loaded then call ioa_$nnl ("dbr_loaded ");
	     if apte.being_loaded then call ioa_$nnl ("being_loaded ");
	     if apte.procs_required ^= "11111111"b then do;
		cpu_str = "";
		do i = 1 to 8;
		     if substr (apte.procs_required, i, 1) then
			cpu_str = cpu_str || substr (PROCS_REQUIRED, i, 1);
		end;
		call ioa_$nnl ("proc required [^a]", cpu_str);
	     end;
	     if apte.page_wait_flag then call ioa_$nnl ("page_wait ");
	     call ioa_ ("^/State:^-  ^a", process_st (fixed (apte.state, 3)));
	     if arg (1) = "run" | arg (1) = "cur" then do;
		call ring0_get_$definition_given_slt (null, "pds", "process_group_id",
		     def_offset, type, code, sltptr, sltnp, defptr);
		p = addrel (p, def_offset);		/* set ptr to userid area */
		call ioa_ ("Userid:^-  ^a", usbuf);	/* print userid */
		call ol_dump_util_$get_ptr_given_dbr (fixed (sdw.add, 24), prdsseg, cpup, segln, odsp);
		if cpup = null then go to pproclp;
		call ring0_get_$definition_given_slt (null, "prds", "processor_tag",
		     def_offset, type, code, sltptr, sltnp, defptr);
		cpup = addrel (cpup, def_offset);	/* get ptr to cpu number */
		call ioa_ ("ON:^-  cpu ^a (#^o)", tag (cpu_no), cpu_no);
	     end;
pproclp:
	end;
	return;
						/*  */

/* tcq - entry to display  traffic controller queue */

tcq:	entry (dump_infop, odsp);

dcl  FLAG_WORD bit (36) based;
dcl  pidp ptr;
dcl  pid_char char (32) based (pidp);
dcl (pidch, disp_all) bit (1) init ("1"b);


	if tcdp = null then do;
	     call ioa_ ("no tc_data");
	     return;
	end;

	exstate = -123;

	if argcnt < 1 then go to prtlp;		/* give 'em all */
	else do i = 1 to 6;				/* ck for all but emp */
	     if arg (1) = statopt1 (i) then do;
		exstate = i;
		disp_all = "0"b;
		go to prtlp;
	     end;
	end;

	if exstate = -123 then do;			/* bad input */
	     call ioa_ ("^/invalid state (^a), accepted states are:^/^5(^a, ^)ptl.", arg (1), statopt1);
	     return;
	end;

prtlp:
	call ioa_ ("^/PROC^6tREL-APTE^16tFLAGS^26tSTATE^41tDBR^50tPROCESS ID^/");
	if disp_all then
	     call ioa_ ("^18tReady list head");

	tmr = "0"b;

	do i = 1 to dump_info.no_procs;
	     p = addr (dump_info.apte_flags (i));
	     if (dump_info.apte_state (i) = "777777"b3) & disp_all then
		call ioa_ ("^18tReady tail/Idle head");
	     else do;
		if ^disp_all then
		     if fixed (dump_info.apte_state (i), 18) ^= exstate then go to bypprt;
		call ol_dump_util_$get_ptr_given_dbr (dump_info.proc_dbr (i),
		     pdsseg, pidp, segln, odsp);

		if pidp = null then
		     pidch = "0"b;
		call ring0_get_$definition_given_slt (null, "pds", "process_group_id",
		     def_offset, type, code, sltptr, sltnp, defptr);
		pidp = addrel (pidp, def_offset);

		call ioa_ ("^4d^6t^8o^16t^6.3b^26t^a^38t^8o^48t^[^a (^6.3b)^;^2s^]^[^6.3b^]",
		     dump_info.process_no (i), dump_info.apte_offs (i),
		     substr (p -> FLAG_WORD, 1, 18), process_st (fixed (dump_info.apte_state (i), 3)),
		     dump_info.proc_dbr (i), pidch, pid_char, substr (dump_info.apte_process_id (i), 19, 18),
		     ^pidch, substr (dump_info.apte_process_id (i), 19, 18));
	     end;
bypprt:
	end;

	if disp_all then
	     call ioa_ ("^18tIdle tail");
	return;

fdi:	entry (dump_infop, odsp);

dcl (found, proc_no, k) fixed bin;

	if tcdp = null then do;
	     dump_info.no_procs = 0;
	     return;
	end;


	i, found = 1;

	rel_apte = fixed (tcdp -> tcm.eligible_q_head.fp);
	tmr = "0"b;
	proc_no, dump_info.no_procs = 0;
dbr_lp:	do while (^tmr);
	     aptxp = addrel (tcdp, rel_apte);		/* get dbr's and init rest */
	     sdwp = addr (aptxp -> apte.dbr);
	     if fixed (aptxp -> w (1)) = -1 then do;
		if i = 2 then
		     go to DONE_PROC;
		rel_apte = fixed (tcdp -> tcm.eligible_q_tail.fp);
		dump_info.no_procs = dump_info.no_procs +1;
		dump_info.process_no (dump_info.no_procs) = -1;
		dump_info.proc_dbr (dump_info.no_procs) = -1;
		dump_info.apte_state (dump_info.no_procs) = "777777"b3;

		i = 2;
		go to dbr_lp;
	     end;
	     dump_info.no_procs = dump_info.no_procs +1;
	     dump_info.proc_dbr (dump_info.no_procs) = fixed (sdw.add, 24);
	     dump_info.apte_offs (dump_info.no_procs) = rel_apte;


	     if rel_apte = fixed (rel (aptap), 18) - fixed (rel (tcdp), 18) then
		found = 0;
	     rel_apte = fixed (aptxp -> based_bit18);
	end;

DONE_PROC:

	do i = 1 to dump_info.no_procs;
	     if dump_info.apte_state (i) ^= "777777"b3 then
		dump_info.apte_state (i) = "0"b;
	     dump_info.apte_process_id (i) = "0"b;
	end;

	rel_apte = fixed (tcdp -> tcm.eligible_q_head.fp);


	do k = 0 to no_apt-1 while (found ^= dump_info.no_procs);
	     aptep = addrel (aptap, k*ol_dump_struc.apt_entry_size);
	     if fixed (apte.state, 18) = -1 then
		go to fill_idle_;
	     tmr = "0"b;
	     sdwp = addr (aptep -> apte.dbr);


	     do j = 1 to dump_info.no_procs while (^tmr);
		if fixed (sdw.add, 24) = dump_info.proc_dbr (j) then do;
		     dump_info.process_no (j) = found;
		     dump_info.apte_flags (j) = apte.flags;
		     dump_info.apte_state (j) = apte.state;
		     dump_info.apte_process_id (j) = apte.processid;
		     found = found + 1;
		     tmr = "1"b;
		end;
	     end;
fill_idle_:

	end;

	return;


% include apte;

% include sdw;

% include tcm;
     end display_process_;




		    display_regs_.pl1               11/10/82  1713.3rew 11/10/82  0916.5      199089



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


display_regs_: proc;

/*   Modified 08/22/80 by R.L. Coppola for new history register analyzer. */
/*   Modified March 1981 by Rich Coppola for DPS8 support */


	return;					/* should never enter here */

% include ol_dump_struc;

dcl  ol_dump_util_$get_ptr entry (fixed bin, ptr, fixed bin (35), ptr); /* :: */
dcl  ol_dump_util_$output_mode entry returns (bit (1));
dcl  ol_dump_util_$find_cond entry (ptr, ptr, char (32) varying, ptr, ptr);
dcl  ol_dump_util_$get_segno entry (char (32) varying, ptr) returns (fixed bin); /* :: */
dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl (ioa_, ioa_$rsnnl) entry options (variable);
dcl  hran_$hrlgnd_dps8_ entry (ptr);
dcl  hran_$hrlgnd_l68_ entry (ptr);
dcl  hran_$hranl entry (ptr, ptr, bit (1));
dcl  hran_$hran_bos entry (ptr, ptr, bit (1));
dcl  hran_$bos_no_thread entry (ptr, ptr, bit (5));
dcl  hran_$no_thread entry (ptr, ptr, bit (5));
dcl  ring0_get_$definition_given_slt entry (ptr, char (*), char (*), fixed bin (18),
     fixed bin, fixed bin (35), ptr, ptr, ptr);
dcl  prtscu_$dump entry (ptr, ptr, fixed bin (18), bit (1), ptr);
dcl  namef_ entry (ptr, ptr) returns (char (*));
dcl  namef_$no_comp entry (ptr, ptr) returns (char (*));
dcl  date_time_ entry (fixed bin (71), char (*) aligned);

dcl (i, j, k, offset, type, segno) fixed bin;
dcl  def_offset fixed bin (18);
dcl (segln, code) fixed bin (35);
dcl (p, p1, mp, stkp, mcptr, hrptr) ptr;
dcl  time char (24) aligned;
dcl (lg_sw, lo, all_sw) bit (1);
dcl  cname char (32) varying;
dcl  pmcdesc char (32);
dcl (addr, null, addrel, fixed, length, baseptr, rel, substr) builtin;
dcl (label1, label2) label;
						/*  */

/* mcpds - entry to display machine conditions on the pds */

mcpds:	entry (odsp);
	if argcnt < 1 then do;
mcp_label:
	     call ioa_ ("mcpds pgflt|fim|sig|all (lg)");
	     return;
	end;
	call ol_dump_util_$get_ptr (pdsseg, p, segln, odsp);
	if arg (1) = "all" then			/* was user requesting all machine cond */
	     all_sw = "1"b;
	else all_sw = "0"b;
	if argcnt > 1 then				/* does user want long form */
	     if arg (2) = "lg" then
		lg_sw = "1"b;
	     else go to mcp_label;			/* user goofed tell him about it */
	else lg_sw = "0"b;
	if arg (1) ^= "all" & arg (1) ^= "pgflt"
	& arg (1) ^= "fim" & arg (1) ^= "sig" then
	     go to mcp_label;			/* check for illegal requests */
	if all_sw | arg (1) = "pgflt" then do;		/* display page_fault data */
	     call ring0_get_$definition_given_slt (null, "pds", "page_fault_data",
		def_offset, type, code, sltptr, sltnp, defptr);
	     call prt_mc (addrel (p, def_offset), def_offset, pdsseg, "Page Fault Data");
	end;
	if all_sw | arg (1) = "fim" then do;		/* user wants to see fim data */
	     call ring0_get_$definition_given_slt (null, "pds", "fim_data",
		def_offset, type, code, sltptr, sltnp, defptr);
	     call prt_mc (addrel (p, def_offset), def_offset, pdsseg, "Fim Data");
	end;
	if all_sw | arg (1) = "sig" then do;		/* user wants to see signal data */
	     call ring0_get_$definition_given_slt (null, "pds", "signal_data",
		def_offset, type, code, sltptr, sltnp, defptr);
	     call prt_mc (addrel (p, def_offset), def_offset, pdsseg, "Signal Data");
	end;
	return;
						/*  */

/* mcprds - entry to display Machine conditions from the prds */

mcprds:	entry (odsp);
	if argcnt < 1 then do;
mcpr_label:
	     call ioa_ ("mcprds int|systroub|fim|all (lg)");
	     return;
	end;
	call ol_dump_util_$get_ptr (prdsseg, p, segln, odsp);
	if arg (1) = "all" then			/* was user requesting all machine cond */
	     all_sw = "1"b;
	else all_sw = "0"b;
	if argcnt > 1 then				/* does user want long form */
	     if arg (2) = "lg" then
		lg_sw = "1"b;
	     else go to mcpr_label;			/* user goofed tell him about it */
	else lg_sw = "0"b;
	if arg (1) ^= "all" & arg (1) ^= "int"
	& arg (1) ^= "systroub" & arg (1) ^= "fim" then
	     go to mcpr_label;			/* check for illegal requests */
	if all_sw | arg (1) = "int" then do;		/* display interrupt data */
	     call ring0_get_$definition_given_slt (null, "prds", "interrupt_data",
		def_offset, type, code, sltptr, sltnp, defptr);
	     call prt_mc (addrel (p, def_offset), def_offset, prdsseg, "Interrupt Data");
	end;
	if all_sw | arg (1) = "systroub" then do;	/* user wants to see system trouble data */
	     call ring0_get_$definition_given_slt (null, "prds", "sys_trouble_data",
		def_offset, type, code, sltptr, sltnp, defptr);
	     call prt_mc (addrel (p, def_offset), def_offset, prdsseg, "System Trouble Data");
	end;
	if all_sw | arg (1) = "fim" then do;		/* user wants to see fim data */
	     call ring0_get_$definition_given_slt (null, "prds", "fim_data",
		def_offset, type, code, sltptr, sltnp, defptr);
	     call prt_mc (addrel (p, def_offset), def_offset, prdsseg, "Fim Data");
	end;
	return;

/*  */

/* mc - entry to display machine conditions from anywhere */

mc:	entry (odsp);

	if argcnt < 1 then do;			/* not enough args */
mc_label:
	     call ioa_ ("mc segno|name|cond {name|no offset - cond segname|no} {cond offset} {lg}");
	     return;
	end;
	if arg (argcnt) = "lg" then do;		/* does user want long output mode */
	     lg_sw = "1"b;				/* set long output mode */
	     argcnt = argcnt - 1;			/* subtract this arg */
	end;
	else lg_sw = "0"b;				/* no reset switch */
	if arg (1) ^= "cond" then			/* take care of easy one first */
	     if argcnt = 2 then do;
		segno = cv_oct_check_ (substr (arg (1), 1, length (arg (1))), code);
		if code ^= 0 then do;		/* did not get seg number try for name */
		     segno = ol_dump_util_$get_segno (arg (1), odsp);
		     if segno = -1 then return;	/* not name or number forget it */
		end;
		call ol_dump_util_$get_ptr (segno, p, segln, odsp);
		if p = null then return;		/* could not find in dump */
		def_offset = cv_oct_check_ (substr (arg (2), 1, length (arg (2))), code);
		if code ^= 0 then go to mc_label;
		call prt_mc (addrel (p, def_offset), def_offset, segno, ""); /* display M. C. */
	     end;
	     else go to mc_label;			/* user goofed */
	else do;					/* arg 1 = cond */
	     label1 = mc_label;
	     label2 = mc_label2;
	     call fcond;				/* go get condition frame args */
	     def_offset = fixed (rel (mcptr), 18) - fixed (rel (p), 18);
	     if cname ^= "" then
		pmcdesc = cname || " condition";
	     else pmcdesc = "";
	     call prt_mc (mcptr, def_offset, segno, pmcdesc);
	end;
mc_label2:
	return;

/*  */

/* dump - entry to display registers saved at time of dump */

dump:	entry (odsp);
	dumpptr = dumpp (0);
	p = addr (dump.prs);
	if argcnt < 1 then arg (1) = "all";		/* default is all */
	if arg (1) = "ptr" then go to pptrs;
	if arg (1) = "preg" then go to ppregs;
	if arg (1) = "scu" then go to ppscu;
	if arg (1) ^= "all" then do;
	     call ioa_ ("dregs arg");
	     return;
	end;
	lg_sw = "1"b;				/* set conditional switches */
	call ioa_ ("^/Bootload CPU Registers at Time of Dump");
pptrs:
	call prtpr (p, odsp);
	if arg (1) ^= "all" then return;
ppregs:
	call prtregs (p);
	call ioa_ ("Descriptor Segment Base Register - ^12.3b ^12.3b",
	     substr (dump.dbr, 1, 36), substr (dump.dbr, 37, 36));
	if dump.modereg ^= "0"b then
	     call ioa_ ("Mode Register - ^12.3b", dump.modereg);
	if dump.cmodereg ^= "0"b then
	     call ioa_ ("Cache Mode Register - ^12.3b", dump.cmodereg);
	if dump.faultreg ^= "0"b then
	     call interpret_fault_reg ((dump.faultreg));
	if dump.ext_fault_reg ^= "0"b then
	     call interpret_ext_fault_reg ((dump.ext_fault_reg));
	if dump.bar ^= "0"b then
	     call ioa_ ("Base Address Register - ^12.3b", dump.bar);
	if arg (1) ^= "all" then return;
ppscu:
	call ioa_ ("^/SCU Data");
	p = addr (dump.scu);
	call prtscu_$dump (null, p, fixed (rel (p), 18), lg_sw, odsp);
	if arg (1) = "all" then
	     if substr (p -> scu.even_inst, 28, 1) then	/* if eis instruction */
		call epl (addr (dump.ptrlen), fixed (rel (addr (dump.ptrlen))));
	return;


/*  */

/* hregs - entry to display history registers in interpreted format */
hregs:	entry (odsp);

dcl  hreg_type bit (1) init ("0"b);			/* 0 for standard frame of 128 words */
						/* 1 for bos frame of 512 words */
dcl  hregs_saved bit (1) aligned based;			/* hregs saved indicator from PDS */
dcl  hregs_savedp ptr;
dcl (expand_sw, raw_sw, do_ou, do_cu, do_au, do_du, valid_cmd) bit (1);
dcl hran_switches bit (5) init ("0"b);
dcl (from_pds, from_dmp, from_cond, from_seg) bit (1) init ("0"b);

	i = 20;
	valid_cmd, expand_sw, raw_sw = "0"b;
	do_ou, do_cu, do_au, do_du = "0"b;

	lo = ol_dump_util_$output_mode ();		/* get terminal line length */
	if argcnt = 0 then go to do_pds;
						/* check args */
	if arg (1) = "pds" then do;
do_pds:	     call ol_dump_util_$get_ptr (pdsseg, p, segln, odsp);
	     call ring0_get_$definition_given_slt (null, "pds", "hregs_saved",
		def_offset, type, code, sltptr, sltnp, defptr);

	     hregs_savedp = addrel (p, def_offset);
	     if hregs_savedp -> hregs_saved = "0"b then do; /* ensure that hregs were saved so we don't print garbage */
		call ioa_ ("^/History registers not saved in PDS.");
		return;
	     end;
	     call ring0_get_$definition_given_slt (null, "pds", "history_reg_data",
		def_offset, type, code, sltptr, sltnp, defptr);
	     hrptr = addrel (p, def_offset);
	     valid_cmd, from_pds = "1"b;
	     i = 2;				/* for arg processing */
	end;

	else if arg (1) = "dmp" | arg (i) = "dump" then do;
	     hrptr = addr (dumpp (0) -> dump.ouhist (0));
	     hreg_type, valid_cmd, from_dmp = "1"b;
	     i = 2;				/* for arg processing */
	end;

	else if arg (1) = "help" then do;
	     if argcnt < 2 then do;
		call hran_$hrlgnd_l68_ (null);
		call ioa_ ("^/^/^/");
		call hran_$hrlgnd_dps8_ (null);
	     end;
	     else if arg (2) = "l68" then do;
		call hran_$hrlgnd_l68_ (null);
	     end;
	     else
	     call hran_$hrlgnd_dps8_ (null);
	     return;
	end;

	else if arg (1) = "cond" then do;		/* display hregs from condition frame */
	     label1 = hr_label;
	     label2 = hr_label2;
	     call fcond;				/* go find conditoion frame */
	     def_offset = fixed (rel (hrptr), 18) - fixed (rel (p), 18);
	     from_cond, valid_cmd = "1"b;
	     i = 4;				/* for arg processing */
	end;

	else do;					/* user wants to specify hregs somewhere else */
	     if argcnt >= 2 then do;
		segno = cv_oct_check_ (substr (arg (1), 1, length (arg (1))), code);
		if code ^= 0 then do;		/* did not get seg number try for name */
		     segno = ol_dump_util_$get_segno (arg (1), odsp);
		     if segno = -1 then return;	/* not name or number forget it */
		end;
		call ol_dump_util_$get_ptr (segno, p, segln, odsp);
		if p = null then return;		/* could not find in dump */
		def_offset = cv_oct_check_ (substr (arg (2), 1, length (arg (2))), code);
		if code ^= 0 then go to hr_label;
		hrptr = addrel (p, def_offset);
		valid_cmd, from_seg = "1"b;
		i = 3;				/* for arg processing */
	     end;
	  else go to hr_label;
	end;

	if valid_cmd = "0"b then go to hr_label;
	do i = i to argcnt;				/* if we have any more */
	     if arg (i) = "nothread" then
		raw_sw = "1"b;
	     else if arg (i) = "exp" then
		raw_sw, expand_sw = "1"b;
	     else if arg (i) = "ou" then
		do_ou = "1"b;
	     else if arg (i) = "cu" then
		do_cu = "1"b;
	     else if arg (i) = "au" then
		do_au = "1"b;
	     else if arg (i) = "du" then
		do_du = "1"b;
	     else go to hr_label;
	end;

	if from_pds then
	     call ioa_ ("^/History Registers at pds|^o", def_offset);
	else if from_dmp then
	     call ioa_ ("^/History Registers at Time of Dump from the Bootload CPU");
	else if from_cond then
	     call ioa_ ("^/History Registers for ^a condition at ^a|^o",
	     cname, namef_$no_comp (baseptr (segno), odsp), def_offset);
	else if from_seg then
	     call ioa_ ("^/History Registers at ^a|^o",
	     namef_$no_comp (baseptr (segno), odsp), def_offset);

	if (do_ou | do_cu | do_au | do_du) then		/* turn on raw */
	   raw_sw = "1"b;
	if ^(do_ou | do_cu | do_au | do_du) then	/* do all */
	     do_ou, do_cu, do_au, do_du = "1"b;

	hran_switches = expand_sw || do_ou || do_cu || do_au || do_du;

	if hreg_type then do;
	     if raw_sw = "0"b then
		call hran_$hran_bos (hrptr, null, lo);
	     else call hran_$bos_no_thread (hrptr, null, hran_switches);
	end;
	else do;
	     if raw_sw = "0"b then
		call hran_$hranl (hrptr, null, lo);
	     else call hran_$no_thread (hrptr, null, hran_switches);
	end;
hr_label2:

	return;

hr_label:
	call ioa_ ("hisregs pds|dmp|help {cpu_type}|cond|segname|no  {nothread|ou|cu|au|do|exp}^/^9t{cond segname|no | segname|no offset} {cond offset}");
	return;

/*  */


/* prtregs - entry to display processor registers included in machine conditions */
prtregs:	entry (mp);

	call ioa_ ("^/Processor Registers^/");
	call ioa_ ("X0 - ^o X1 - ^o X2 - ^o X3 - ^o X4 - ^o X5 - ^o X6 - ^o X7 - ^o",
	     fixed (mp -> mc.regs.x (0), 18), fixed (mp -> mc.regs.x (1), 18),
	     fixed (mp -> mc.regs.x (2), 18), fixed (mp -> mc.regs.x (3), 18),
	     fixed (mp -> mc.regs.x (4), 18), fixed (mp -> mc.regs.x (5), 18),
	     fixed (mp -> mc.regs.x (6), 18), fixed (mp -> mc.regs.x (7), 18));
	call ioa_ ("A Register - ^12.3b Q Register - ^12.3b E Register - ^o",
	     mp -> mc.regs.a, mp -> mc.regs.q, fixed (mp -> mc.regs.e, 8));
	call ioa_ ("Timer Register - ^9.3b Ring Alarm Register - ^1.3b",
	     mp -> mc.t, mp -> mc.ralr);
	return;

/* epl - entry to display Eis pointers and lengths */

epl:	entry (mp, offset1);
dcl  w (8) fixed bin (35) based (mp);
dcl  offset1 fixed bin;

	call ioa_ ("^/EIS Pointers and Lengths^/");
	call ioa_ ("^6o^-^4(^w ^)^/^-^4(^w ^)", offset1,
	     w (1), w (2), w (3), w (4), w (5), w (6), w (7), w (8));
	return;

/* prtpr - entry to display pointer registers */

prtpr:	entry (mp, odsp);

dcl  ptrfmt char (44) int static options (constant) init
    ("PR^o (^[ap^;ab^;bp^;bb^;lp^;lb^;sp^;sb^]) - ");
dcl 1 pwrd based (p1) aligned,
    2 w1 fixed bin (35),
    2 w2 fixed bin (35);

	call ioa_ ("^/Pointer Registers^/");
	do i = 0 to 7;
	     p1 = addr (mp -> mc.prs (i));
	     if p1 -> its.its_mod ^= "100011"b then
		call ioa_ (ptrfmt || "^w ^w", i, i+1, pwrd.w1, pwrd.w2);
	     else do;
		call ioa_$rsnnl (ptrfmt || "^p", time, j, i, i+1, mp -> mc.prs (i));
		call ioa_ ("^22a ^a", time, namef_ (mp -> mc.prs (i), odsp));
	     end;
	end;
	return;



/* fcond - internal procedure shared by mc and hisregs entry to find condition frame from args specifeied */

fcond:	proc;
	     segno = cv_oct_check_ (substr (arg (2), 1, length (arg (2))), code);
	     if code ^= 0 then do;			/* seg number not spicified, must be name */
		segno = ol_dump_util_$get_segno (arg (2), odsp);
		if segno = -1 then go to label2;	/* could not find in dump */
	     end;
	     call ol_dump_util_$get_ptr (segno, p, segln, odsp);
	     if p = null then go to label2;		/* could not find in dump */
	     if argcnt < 3 then			/* no offset specified */
		stkp = null;			/* find first cond */
	     else do;				/* offset arg specified */
		def_offset = cv_oct_check_ (substr (arg (3), 1, length (arg (3))), code);
		if code ^= 0 then go to label1;	/* must be octal */
		stkp = addrel (p, def_offset);	/* form frame offset */
	     end;
	     call ol_dump_util_$find_cond (p, stkp, cname, mcptr, hrptr);
	     if mcptr = null then do;			/* could not find cond frame */
		if argcnt >= 2 then			/* was he looking in entire stack */
		     call ioa_ ("No condition frames found in ^a",
		     namef_$no_comp (baseptr (segno), odsp));
		else call ioa_ ("^a|^o is not a condition frame",
		     namef_$no_comp (baseptr (segno), odsp), def_offset);
		go to label2;
	     end;
	     call ioa_ ("^/Condition frame at ^a|^o", namef_$no_comp (baseptr (segno), odsp),
		fixed (rel (stkp), 17) - fixed (rel (p), 17));
	end fcond;



/* prt_mc -  procedure to display machine conditions */

prt_mc:	proc (a_mcptr, a_offset, segn, mcdesc);
dcl  a_mcptr ptr;
dcl  segn fixed bin;
dcl (a_offset, mc_offset) fixed bin (18);
dcl  mcdesc char (32);
dcl  pdesc bit (1);
dcl  dps8_cpu bit (1) init ("0"b);

	     mcp = a_mcptr;				/* copy mc pointer */
	     scup = addr (mc.scu);			/* form pointer to scu data */
	     if mc.cpu_type ^= 0 then
		dps8_cpu = "1"b;
	     mc_offset = a_offset + (fixed (rel (addr (mc.scu))) - fixed (rel (mcp)));
	     if mcdesc = "" then			/* if we have a null M. C. description */
		pdesc = "0"b;			/* don't print it out */
	     else pdesc = "1"b;
	     call ioa_ ("^/^[DPS8 CPU ^]Machine Conditions ^[For ^a ^;^s^]At ^a|^o", dps8_cpu, pdesc,
		mcdesc, namef_$no_comp (baseptr (segn), odsp), a_offset);
	     if mc.fault_time ^= "0"b then do;		/* if time available */
		call date_time_ (fixed (mc.fault_time, 71), time); /* print it out */
		call ioa_ ("Time Stored - ^a (^18.3b)", time, mc.fault_time);
	     end;
	     if lg_sw then do;			/* if all regs wanted */
		call prtpr (mcp, odsp);		/* print them out */
		call prtregs (mcp);
		if mc.mask ^= "0"b then		/* if mask register is set */
		     call ioa_ ("SCU masks^-     - ^12.3b ^12.3b",
		     substr (mc.mask, 1, 36), substr (mc.mask, 37, 36));
		if mc.fault_reg ^= "0"b then		/* if fault reg exists, print it out */
		     call interpret_fault_reg ((mc.fault_reg));
		if mc.ext_fault_reg ^= "0"b then
		     call interpret_ext_fault_reg ((mc.ext_fault_reg));
	     end;
	     call ioa_ ("^/SCU Data at ^a|^o^/",
		namef_$no_comp (baseptr (segn), odsp), mc_offset);
	     call prtscu_$dump (null, scup, mc_offset, lg_sw, odsp);
	     if lg_sw then				/* if in long output mode */
		if substr (scu.even_inst, 28, 1) then	/* and if EIS instruction */
		     call epl (addr (mc.eis_info), mc_offset + 16);
	     return;
	end prt_mc;

prt_mc_:	entry (odsp, a_mcptr, a_offset, a_segn, a_mcdesc, a_lg_sw);
dcl  a_mcptr ptr;
dcl  a_offset fixed bin (18);
dcl  a_segn fixed bin;
dcl  a_mcdesc char (32);
dcl  a_lg_sw bit (1);

	lg_sw = a_lg_sw;

	call prt_mc (a_mcptr, a_offset, a_segn, a_mcdesc);
	return;

%page;
/* Internal procedure to print fault reg data */

interpret_fault_reg: proc (fault_reg);

dcl  fault_reg bit (36);
dcl (fault_no, break) fixed bin;
dcl 1 illeg_acts based (addr (fault_reg)),
   (2 pad bit (16),
    2 IA (4) bit (4),
    2 pad1 bit (4)) unal;
dcl  port_name (4) char (3) int static options (constant) init (
     "A: ", "B: ", "C: ", "D: ");

dcl (line1, line2) char (80) varying;
dcl (line1_sw, line2_sw) bit (1) init ("0"b);

dcl  FAULT_TYPES (36) char (15) var int static options (constant) init (
     "ILL OP",
     "ILL MOD",
     "ILL SLV",
     "ILL PROC",
     "NEM",
     "OOB",
     "WRT INH",
     "PROC PAR-UPR",
     "PROC PAR-LWR",
     "$CON A",
     "$CON B",
     "$CON C",
     "$CON D",
     "ONC (DA ERR1)",
     "ONC (DA ERR2)",
     "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "",
     "CACHE-PAR DIR",
     "CACHE-PAR STR",
     "CACHE-PAR IA",
     "CACHE-PAR BLK");


dcl  SC_IA_TYPES (1:15) char (42) var int static options (constant) init (
     "Unassigned (01)",
     "Non-existent Address (02)",
     "Stop on Condition (03)",
     "Unassigned (04)",
     "Data Parity, Store to SC (05)",
     "Data Parity in Store (06)",
     "Data Parity in Store AND Store to SC (07)",
     "Not Control (10)",
     "Port Not Enabled (11)",
     "Illegal Command (12)",
     "Store Not Ready ( 13)",
     "ZAC Parity, Active Module to SC (14)",
     "Data Parity, Active Module to SC (15)",
     "ZAC Parity, SC to Store (16)",
     "Data Parity, SC to Store (17)");


	     if fault_reg = "0"b then
		return;


	     line1, line2 = "";

	     do fault_no = 1 to 15;
		if substr (fault_reg, fault_no, 1) = "1"b then do;
		     line1 = line1 || FAULT_TYPES (fault_no) || ", ";
		     line1_sw = "1"b;
		end;
	     end;

	     break = 0;
	     do fault_no = 1 to 4 while (break = 0);	/* do IAs now */
		if IA (fault_no) then do;
		     line2 = "Ilegal Action on CPU Port " || port_name (fault_no);
		     line2 = line2 || SC_IA_TYPES (bin (IA (fault_no), 4)) || ", ";
		     line2_sw = "1"b;
		     break = 1;
		end;
	     end;

	     do fault_no = 33 to 36;
		if substr (fault_reg, fault_no, 1) = "1"b then do;
		     line1 = line1 || FAULT_TYPES (fault_no) || ", ";
		     line1_sw = "1"b;
		end;
	     end;

	     if line1_sw then			/* remove trailing comma & space */
		line1 = substr (line1, 1, (length (line1) -2));
	     if line2_sw then
		line2 = substr (line2, 1, (length (line2) -2));

	     call ioa_ ("Fault Register - ^12.3b^[  (^a)^;^s^]^[^/^18t(^a)^]",
		fault_reg, line1_sw, line1, line2_sw, line2);

	     return;

%page;
interpret_ext_fault_reg: entry (ext_fault_reg);

dcl  ext_fault_reg bit (15);
dcl  indx fixed bin;

dcl  EXT_FAULT_TYPES (15) char (39) var int static options (constant) init (
     "Bffr. Ovflw - Port A",
     "Bffr. Ovflw - Port B",
     "Bffr. Ovflw - Port C",
     "Bffr. Ovflw - Port D",
     "Bffr. Ovflw - Primary Dir",
     "Write Notify Parity Error on ANY Port",
     "Dup. Dir. LVL 0 Parity Error",
     "Dup. Dir. LVL 1 Parity Error",
     "Dup. Dir. LVL 2 Parity Error",
     "Dup. Dir. LVL 3 Parity Error",
     "Dup. Dir. Multi Match Error",
     "PTW Ass. Mem. Parity Error",
     "PTW Ass. Mem. Match Error",
     "SDW Ass. Mem. Parity Error",
     "SDW Ass. Mem. Match Error");


	     line1 = "";
	     do indx = 1 to 15;
		if substr (ext_fault_reg, indx, 1) = "1"b then
		     line1 = line1 || EXT_FAULT_TYPES (indx) || ", ";
	     end;

	     if line1 ^= "" then do;
		line1 = substr (line1, 1, (length (line1) -2));
		call ioa_ ("DPS8 Extended Fault Register - ^5.3b^/^32t(^a)",
		     ext_fault_reg, line1);
	     end;


	     return;


	end interpret_fault_reg;

%page;
% include bos_dump;
%page;
% include mc;
%page;
% include its;

     end display_regs_;




		    display_segment_.pl1            11/10/82  1713.3rew 11/10/82  0916.5       63405



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



/*  Modified December 1980 by Rich Coppola to make lrn act more intelligently */
/*  Modified Oct 1982 by Rich Coppola to set dbr to first proc dumped instead
   of inzr's as the inzr is not always dumped. */

display_segment_: proc;
	return;					/* should never enter here */

% include ol_dump_struc;
%page;
% include sdw;
%page;



dcl  ring0_get_$segptr_given_slt entry (char (*) aligned, char (*) aligned, ptr, fixed bin, ptr, ptr);
dcl  cv_oct_check_ entry (char (*), fixed bin) returns (fixed bin);
dcl  cv_dec_check_ entry (char (*), fixed bin) returns (fixed bin);
dcl  namef_ entry (ptr, ptr) returns (char (*));
dcl  namef_$no_comp entry (ptr, ptr) returns (char (*));
dcl (ioa_, ioa_$rsnnl) entry options (variable);
dcl  ol_dump_util_$get_ptr entry (fixed bin, ptr, fixed bin (35), ptr);
dcl  ol_dump_util_$fnd_dbr entry (fixed bin (24), fixed bin (35), fixed bin, ptr);
dcl  ol_dump_util_$get_segno entry (char (32) varying, ptr) returns (fixed bin);
dcl (i, j, k, l, segno, code, first, count, last, offset) fixed bin init (0);
dcl  segln fixed bin (35) init (0);
dcl (fixed, substr, null, addrel, rel, addr, length) builtin;
dcl (cp, p, ap, pm) ptr init (null);
dcl  axstring char (7) init ("");
dcl  axbit (7) bit (1) based (ap);
dcl  out char (64) var;				/* output line */
dcl  type bit (2) aligned;				/* field type in config record */

dcl  carda (16) char (4) aligned based (cp),		/* to get config record name in columns 1-4 */
     cardf (16) fixed bin based (cp);			/* to test for "fence" at end of config deck */

dcl 1 card aligned based (cp),
    2 pad (15) fixed bin,
    2 types (18) bit (2) unal;			/* to determine config record field conversion for output */

dcl 1 sdwb based (sdwp) aligned,
   (2 pad1 bit (33),
    2 dfb bit (3),
    2 pad2 bit (36)) unaligned;
dcl  saved_kstseg fixed bin;
dcl  saved_kstptr ptr;
dcl  saved_dbr fixed bin (24);
%page;


name:	entry (odsp);
	if argcnt < 1 then do;
name_label:
	     call ioa_ ("name segno (offset)");
	     return;
	end;
	segno = cv_oct_check_ (substr (arg (1), 1, length (arg (1))), code); /* see if octal number ... */
	if code ^= 0 then go to name_label;
	if argcnt < 2 then do;			/* No offset arg, just name wanted */
	     call ioa_ ("^o = ^a", segno, namef_$no_comp (baseptr (segno), odsp));
	     return;
	end;
	else do;					/* relative offset of bound seg wanted */
	     offset = cv_oct_check_ (substr (arg (2), 1, length (arg (2))), code);
	     if code ^= 0 then go to name_label;
	     p = addrel (baseptr (segno), offset);
	     call ioa_ ("^p = ^a", p, namef_ (p, odsp));
	     return;
	end;
						/*  */

number:	entry (odsp);
	if argcnt < 1 then do;
	     call ioa_ ("segno name");
	     return;
	end;
	segno = ol_dump_util_$get_segno (arg (1), odsp);
	if segno = -1 then return;
	call ioa_ ("^a = ^o", arg (1), segno);
	return;

/*  */

dseg:
	entry (odsp);
	call ol_dump_util_$get_ptr (dsegno, dsegp, segln, odsp); /* get ptr to dseg for this process */
	if dsegp = null then return;
	first = 0;				/* set up default range */
	count = divide (segln, 2, 17, 0) - 1;

	if argcnt < 1 then
	     first = 0;


	if argcnt >= 1 then do;
	     first = cv_oct_check_ (substr (arg (1), 1, length (arg (1))), code);
	     if code ^= 0 then do;
lrnerr:		call ioa_ ("lrn from (oct) {to (oct)}");
		return;
	     end;
	     if first > count then do;		/* let em know its too large */
		call ioa_ ("Segment ^o is not known, last known segment is ^o.", first, count);
		return;
	     end;
	end;


	if argcnt = 2 then do;
	     last = cv_oct_check_ (substr (arg (2), 1, length (arg (2))), code);
	     if code ^= 0 then go to lrnerr;
	     if last < first then go to lrnerr;
	     if last > count then last = count;
	     else count = last;
	end;


	if argcnt = 1 then
	     count = first;

lrndef:						/* print out banner */
	call ioa_ ("^/DSEG ADD   SDW ADD RNGS FLT BOUND  REWPUGC    CL SEG #   SEG NAME");
	do segno = first to count;
	     sdwp = addrel (dsegp, segno * 2);
	     if sdw.add = "0"b & segno ^= 1 then go to lrnlp; /* don't print null segs */
	     offset = fixed (rel (sdwp), 18) - fixed (rel (dsegp), 18);
	     axstring = "REWPUGC";
	     ap = addr (sdw.read);
	     do i = 1 to 7;
		if axbit (i) = "0"b then substr (axstring, i, 1) = " ";
	     end;
	     call ioa_ ("^8o  ^8o  ^o^o^o  ^o  ^5o  ^7a ^5o   ^3o   ^a",
		offset, fixed (sdw.add, 24), fixed (sdw.r1, 3), fixed (sdw.r2, 3), fixed (sdw.r3, 3),
		fixed (sdwb.dfb, 3), fixed (sdw.bound, 14), axstring,
		fixed (sdw.entry_bound, 14), segno,
		namef_$no_comp (baseptr (segno), odsp));
lrnlp:
	end;
	return;

%page;

config:	entry (odsp);


	saved_kstseg = kstseg;			/* save values of the */
	saved_kstptr = kstptr;			/* process as it will change */
	saved_dbr = dbrsv;
	dbrsv = boot_dbr;

	call ol_dump_util_$fnd_dbr (dbrsv, segln, i, odsp);

	call ring0_get_$segptr_given_slt ("", "config_deck", p, code, sltptr, sltnp);
	if code ^= 0 then do;
	     call ioa_ ("Segment ""config_deck"" not found");
	     go to restore_dbr;
	end;
	call ol_dump_util_$get_ptr (fixed (baseno (p), 17), p, segln, odsp);
	if p = null then go to restore_dbr;
	if argcnt < 1 then do;			/*  All cards to be printed */
	     cp = p;
	     do while (cardf (1) ^= -1);
		call output;
		cp = addrel (cp, 16);
	     end;
	end;
	else do;					/*  Only cards spieified by args wanted */
	     do i = 1 to argcnt;
		cp = p;
		j = 0;
		do while (cardf (1) ^= -1);
		     if carda (1) = arg (i) then do;
			call output;
			j = j + 1;
		     end;
		     cp = addrel (cp, 16);
		end;
		if j = 0 then call ioa_ ("Config card ^a not found", arg);
	     end;
	end;
	go to restore_dbr;

output:	proc;

	     out = carda (1);			/* initialize output string */
	     do k = 2 to 15 while (cardf (k) ^= -1);	/* look at all words of the card */
		type = types (k-1);			/* get the type for the current word */
		if type = "01"b then do;
		     if cardf (k) > 8 | cardf (k) < 1 then go to oct;
		     call ioa_$rsnnl ("^a  ^a", out, l, out, substr ("abcdefgh", cardf (k), 1));
		end;
		else if type = "00"b then
oct:		     call ioa_$rsnnl ("^a  ^o", out, l, out, cardf (k));
		else if type = "11"b then call ioa_$rsnnl ("^a  ^d.", out, l, out, cardf (k));
		else
		call ioa_$rsnnl ("^a  ^a", out, l, out, carda (k));
	     end;
	     call ioa_ (out);
	     return;
	end output;
%page;
restore_dbr:

	dbrsv = saved_dbr;
	kstseg = saved_kstseg;
	kstptr = saved_kstptr;
	call ol_dump_util_$fnd_dbr (dbrsv, segln, i, odsp);
	call ol_dump_util_$get_ptr (kstseg, kstptr, segln, odsp);
	return;


     end display_segment_;




		    display_stack_.pl1              10/01/82  1523.5rew 10/01/82  1523.6       86364



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


display_stack_: proc (odsp);


/*        Modified 3/82 by Rich Coppola to do a better job of validating stack ptrs
   to eliminate (to some extent) looping on stack trace. */

/*	Modified 7/80 by R. L. Coppola to add fwd trace arg and to attempt forward trace
   *	if reverse pointer is invalid. Also changed format of output to display seg and offset
   *	of the stack.
*/

% include ol_dump_struc;

dcl  ol_dump_util_$stk_validate_rev entry (ptr, ptr, ptr);
dcl  ol_dump_util_$stk_validate_fwd entry (ptr, ptr, ptr);
dcl  ol_dump_util_$dump_oct entry (ptr, fixed bin (18), fixed bin);
dcl  ol_dump_util_$p_valid entry (ptr) returns (bit (1));
dcl  ol_dump_util_$val_ptr entry (ptr) returns (char (16) aligned); /* :: */
dcl  ol_dump_util_$get_ptr entry (fixed bin, ptr, fixed bin (35), ptr); /* :: */
dcl  ol_dump_util_$get_segno entry (char (32) varying, ptr) returns (fixed bin); /* :: */
dcl  cv_oct_check_ entry (char (*), fixed bin) returns (fixed bin);
dcl  namef_ entry (ptr, ptr) returns (char (*));
dcl  display_frame_args_ entry (fixed bin, ptr, ptr, ptr);
dcl (ioa_, ioa_$nnl) entry options (variable);

dcl (i, j, code, segno, nxarg) fixed bin init (0);
dcl  ring fixed bin (3) unsigned init (0);
dcl  segln fixed bin (35) init (0);
dcl (substr, addrel, addr, null, rel, baseno, baseptr, length, verify, reverse, fixed) builtin;
dcl (p, nextsp, stkv, rptr, lptr, a_sb) ptr init (null);
dcl (rp_char, et_char, pr0_char) char (16) init ("");
dcl  (stkout, stkout2) char (168) init ("");
dcl (offset, offs) fixed bin (18) aligned init (0);
dcl (lg_sw, off_sw, arg_sw, fwd_sw, trm, fim_frame) bit (1) init ("0"b);


/*  */
	if argcnt < 1 then do;
stack_label:
	     call ioa_ ("stack (s) name|no|stack_<n>|(ring <n>) (offset) (fwd) (args) (lg)");
	     return;
	end;


	if arg (1) = "stack_ " | arg (1) = "stack" then
	     go to stack_label;

	if arg (1) = "ring" then do;			/* user wants to trace "stack ring n" */
	     if argcnt < 2 then			/* must specify ring number */
		go to stack_label;
	     segno = cv_oct_check_ ((arg (2)), code);
	     if code ^= 0 | segno > 7 then		/* ring numbers from 0 to 7 */
		go to stack_label;
	     ring = segno;				/* copy ring number */
	     if dsegp -> sdw.entry_bound = "0"b then do;	/* no stacks */
		call ioa_ ("ring ^o stack not found in process", ring);
		return;
	     end;
	     segno = bin (dsegp -> sdw.entry_bound || bit (ring)); /* cancat. ring to stack in dbr */
	     nxarg = 3;				/* nxt arg starts at 3 */
	end;
	else do;
	     nxarg = 2;				/* nxt arg starts at 2 */
	     segno = cv_oct_check_ ((arg (1)), code);	/* convert to binary */
	     if code ^= 0 then do;			/* maybe special name */
		segno = ol_dump_util_$get_segno (arg (1), odsp);
		if segno = -1 then return;
	     end;
	end;
	call ol_dump_util_$get_ptr (segno, a_sb, segln, odsp);
	if a_sb = null then return;
	sb = a_sb;
	fwd_sw, off_sw, arg_sw, lg_sw = "0"b;
	if argcnt >= nxarg then			/* if any more args */
	     do i = nxarg to argcnt;			/* get the args */
	     if verify (arg (i), "01234567") = 0 then do; /* if offset arg speicified */
		offset = cv_oct_check_ ((arg (i)), code);
		if code ^= 0 then
		     go to stack_label;
		off_sw = "1"b;
	     end;

	     else if arg (i) = "lg" then		/* user wants long oct dump */
		lg_sw = "1"b;

	     else if arg (i) = "args" then		/* user wants args displayed */
		arg_sw = "1"b;

	     else if arg (i) = "fwd" then		/* user wants to trace from beginning */
		fwd_sw = "1"b;

	     else go to stack_label;

end_args:	end;


	rptr = baseptr (segno);
	sp = null;

	call ioa_ ("^/Stack Begin PTR = ^p, Stack End PTR = ^p",
	     stack_header.stack_begin_ptr, stack_header.stack_end_ptr);

	if ^fwd_sw then
	     call ol_dump_util_$stk_validate_rev (sb, sp, stkv); /* validate threads from back ptr */
	if sp = null then do;			/* no luck from back ptr, try fwd */
	     call ol_dump_util_$stk_validate_fwd (sb, sp, stkv);
	     if stkv = null then do;			/* no luck at all */
		call ioa_ ("No valid stack frames laid on Segment #^o", segno);
		return;
	     end;

	     else if ^fwd_sw then do;			/* user wanted reverse trace but we must go fwd */
		fwd_sw = "1"b;			/* set fwd trace */
		call ioa_ ("Stack end pointer invalid. Trace will be forward. "); /* let him know */
	     end;
	end;

	if fwd_sw then sp = stkv;			/* reverse begin and end ptrs */
	if off_sw then				/* if user speicified offset */
	     sp = addrel (sb, offset);
	call ioa_ ("^/^3xADDR^5xRETURN POINTER^/^13tENTRY POINTER^/");

	trm = "0"b;
	do while (^trm);				/* go thru all the threads */
	     if ^fwd_sw then offset = fixed (rel (sp), 18) - fixed (rel (sb), 18);
	     else offset = fixed (rel (sb), 18) + fixed (rel (sp), 18);

	     if addrel (rptr, offset) = lptr then do;
		trm = "1"b;
		call ioa_ ("^/Trace loops.  End trace.");
		return;
	     end;

	     rp_char = ol_dump_util_$val_ptr (addr (sp -> stack_frame.return_ptr));
	     if substr (rp_char, 1, 7) ^= "Invalid" then do;
		stkout = namef_ (return_ptr, odsp);
		if index (stkout, "pl1_operators") ^= 0 then do; /* if frame is owned by pl1_operators */
		     pr0_char = ol_dump_util_$val_ptr (addr (sp -> stack_frame.pointer_registers (0)));
		     if substr (pr0_char, 1, 7) ^= "Invalid" then do;
			rp_char = pr0_char;		/* copy it over */
			stkout = rtrim (namef_ (stack_frame.pointer_registers (0), odsp)) || " [pr0]";
		     end;
		end;
	     end;
	     else do;
		trm = "1"b;
		stkout = "";
	     end;


	     et_char = ol_dump_util_$val_ptr (addr (sp -> stack_frame.entry_ptr));
	     if substr (et_char, 1, 7) ^= "Invalid" then do;
		stkout2 = namef_ (entry_ptr, odsp);
		if index (stkout2, "pl1_operators") ^= 0 then do; /* if frame is owned by pl1_operators */
		     pr0_char = ol_dump_util_$val_ptr (addr (sp -> stack_frame.pointer_registers (0)));
		     if substr (pr0_char, 1, 7) ^= "Invalid" then do;
			et_char = pr0_char;		/* copy it over */
			stkout2 = rtrim (namef_ (stack_frame.pointer_registers (0), odsp)) || " [pr0]";
		     end;
		end;
	     end;
	     else 
		stkout2 = "";

	     fim_frame = is_cond_frame (sp);
	     offs = fixed (rel (sp), 18) - fixed (rel (sb), 18);
	     call ioa_ ("^10p  ^15a^a", addrel (rptr, offs), rp_char, stkout);
						/* print out info */
	     call ioa_ ("^13t^15a^a^[^/^21t A fim frame.^]^/", et_char, stkout2, fim_frame);
	     if arg_sw then				/* if we want to display_args */
		call display_frame_args_ (segno, sp, sb, odsp);
	     if lg_sw then do;			/* user wants octal dump also */
		call display_frame_args_ (segno, sp, sb, odsp);

		if ^fwd_sw then do;
		     if substr (rp_char, 1, 7) = "Invalid" then /* if return char invalid */
			i = segln - offset;		/* dump rest of segment */
		     else i = fixed (rel (next_sp), 18) - offset; /* else set length to frame length */
		end;

		else if fwd_sw then do;
		     if substr (rp_char, 1, 7) = "Invalid" then /* if return char invalid */
			i = offset - segln;		/* dump rest of segment */
		     else				/* esle set length to frame length */
		     i = fixed (rel (next_sp), 18) - ((fixed (rel (sp), 18)) - (fixed (rel (sb), 18)));
		end;

		call ol_dump_util_$dump_oct (sp, offset, i);
		call ioa_ (" ");

	     end;

	     if ^fwd_sw then do;

		if ol_dump_util_$p_valid (addr (prev_sp)) then do;
		     p = addrel (sb, rel (prev_sp));
		     if rel (p) >= rel (sp) then go to bad_rev_ptr;
		     else sp = p;
		end;


		else do;
bad_rev_ptr:	     call ioa_ ("Invalid reverse pointer in this frame. Trace stops.");
		     trm = "1"b;			/* lets quit */
		end;
	     end;

	     else if fwd_sw then do;

		if ol_dump_util_$p_valid (addr (next_sp)) then do;
		     p = addrel (sb, rel (next_sp));
		     if rel (p) <= rel (sp) then go to bad_fwd_ptr;
		     else sp = p;
		end;


		else do;
bad_fwd_ptr:	     call ioa_ ("Invalid forward pointer in this frame. Trace stops.");
		     trm = "1"b;			/* lets quit */
		end;
	     end;

	     lptr = addrel (rptr, offset);

	end;

	if (^fwd_sw) & (ol_dump_util_$p_valid (addr (prev_sp))) then do;
	     rp_char = ol_dump_util_$val_ptr (addr (prev_sp)); /* if prev ptr is valid */
	     if substr (rp_char, 1, 7) ^= "Invalid" then
		if prev_sp ^= null then		/* and not a null pointer */
		     call ioa_ ("^/stack_frame.prev_sp = ^a (^a)", rp_char, namef_ (prev_sp, odsp));
	end;

	else if (fwd_sw) & (ol_dump_util_$p_valid (addr (next_sp))) then do;
	     rp_char = ol_dump_util_$val_ptr (addr (next_sp)); /* if next ptr is valid */
	     if substr (rp_char, 1, 7) ^= "Invalid" then
		if next_sp ^= null then		/* and not a null pointer */
		     call ioa_ ("^/stack_frame.next_sp = ^a (^a)", rp_char, namef_ (next_sp, odsp));

	end;



is_cond_frame: proc (stkp) returns (bit (1));

dcl  stkp ptr;
dcl  out char (70);

	     if ol_dump_util_$p_valid (addr (stkp -> stack_frame.return_ptr)) then do;
		out = namef_ (stkp -> stack_frame.return_ptr, odsp);
		if index (out, "return_to_ring_") ^= 0 | index (out, "$fim|") ^= 0 then
		     return ("1"b);
	     end;
	     return ("0"b);
	end is_cond_frame;

/*  */

% include stack_header;
% include stack_frame;
% include sdw;
     end display_stack_;




		    display_syserr_.pl1             11/10/82  1713.3rew 11/10/82  0916.6       56016



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

/*  Modified Oct 1982 by Rich Coppola to set dbr to first proc dumped instead of
   defaulting to inzr process as it is not always dumped. */

display_syserr_: proc;
	return;					/* should never enter here */

% include ol_dump_struc;
%page;
% include syserr_log;
%page;
% include syserr_data;
%page;
%include sdw;
%page;
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl  ring0_get_$segptr_given_slt entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35), ptr, ptr);
dcl  ol_dump_util_$get_ptr entry (fixed bin, ptr, fixed bin (35), ptr); /* :: */
dcl  ol_dump_util_$fnd_dbr entry (fixed bin (24), fixed bin (35), fixed bin, ptr);
dcl  ring0_get_$definition_given_slt entry (ptr, char (*), char (*), fixed bin (18),
     fixed bin, fixed bin (35), ptr, ptr, ptr);
dcl  ioa_ entry options (variable);

dcl (null, addrel, addr, rel, fixed) builtin;
dcl (i, j, count, edoc, segno, offset, mblen, mblenn, type) fixed bin;
dcl  def_offset fixed bin (18);
dcl  msbuf char (mblen) aligned based (p);
dcl  msbuff char (mblenn) aligned based (ap);
dcl (p, pm, ap, savep) ptr;
dcl (segln, code) fixed bin (35);
dcl  repeat_sw bit (1);
dcl  saved_kstseg fixed bin;
dcl  saved_kstptr ptr;
dcl  saved_dbr fixed bin (24);



/*  */
data:	entry (odsp);

	saved_kstseg = kstseg;			/* save values of the */
	saved_kstptr = kstptr;			/* process as it will change */
	saved_dbr = dbrsv;

	dbrsv = boot_dbr;

	call ol_dump_util_$fnd_dbr (dbrsv, segln, i, odsp);

	call ring0_get_$segptr_given_slt ("", "syserr_data", p, code, sltptr, sltnp);
	if code ^= 0 then do;
	     call ioa_ ("No syserr_data segment found.");
	     go to restore_dbr;
	end;
	savep = p;
	segno = fixed (baseno (p), 15);
	call ol_dump_util_$get_ptr (segno, sd_ptr, segln, odsp);
	if sd_ptr = null then
	     go to restore_dbr;
	call ring0_get_$definition_given_slt (null, "syserr_data", "wired_log_area",
	     def_offset, type, code, sltptr, sltnp, defptr);
	wlog_ptr = addrel (sd_ptr, def_offset);		/* Set up ptr to header */
	wmess_ptr = addrel (wlog_ptr, fixed (rel (addr (wlog.buffer)), 18) - fixed (rel (wlog_ptr)));
	edoc = wlog.count;				/* Get number of messages */
	call ioa_ ("^d messages in syserr_data segment (seg. # ^o), most recent first",
	     edoc, fixed (baseno (p), 18));
	if edoc = 0 then
	     go to restore_dbr;			/* If no messages quit */
	call ioa_ ("^/  ADDR   SEQNO   DATE       TIME     CODE  MESSAGE TEXT^/");
	begin;
dcl  wmess_ptrs (edoc) ptr;
	     do i = 1 to edoc;
		wmess_ptrs (i) = wmess_ptr;
		wmess_ptr = addr (wmess.data (wmess.data_size + 1));
	     end;
	     do i = edoc to 1 by -1;
		wmess_ptr = wmess_ptrs (i);
		p = addr (wmess.text);
		mblen = wmess.text_len;		/* Set mess.age buffer length */
		offset = fixed (rel (wmess_ptr), 18) - fixed (rel (sd_ptr), 18);
		if mblen = 0 then do;
		     call ioa_ ("syserr_log entry at ^p is null", addrel (savep, offset));
		     go to psdta_lp;
		end;


		call ioa_ ("^6o  ^6o  ^20a   ^o   ^a", offset, wmess.seq_num,
		     datm (addr (wmess.time)), wmess.code, msbuf);
psdta_lp:
	     end;
	end;
	go to restore_dbr;


/*  */

log:	entry (odsp);
	if argcnt < 1 then do;
errlog_label:
	     call ioa_ ("syserlog number of messages ");
	     return;
	end;
	count = cv_dec_check_ (substr (arg (1), 1, length (arg (1))), code);
	if code ^= 0 then go to errlog_label;


	saved_kstseg = kstseg;			/* save values of the */
	saved_kstptr = kstptr;			/* process as it will change */
	saved_dbr = dbrsv;

	dbrsv = boot_dbr;

	call ol_dump_util_$fnd_dbr (dbrsv, segln, i, odsp);


	call ring0_get_$segptr_given_slt ("", "syserr_log", p, code, sltptr, sltnp);
	if code ^= 0 then do;
	     call ioa_ ("No syserr_log seg.");
	     go to restore_dbr;
	end;
	segno = fixed (baseno (p), 18);
	call ol_dump_util_$get_ptr (segno, slog_ptr, segln, odsp);
	if slog_ptr = null then go to restore_dbr;
	call ioa_ ("Last ^d messages in syserr_log segment (seg. # ^o), most recent first",
	     count, segno);
	offset = fixed (slog_ptr -> slog.head.last, 18);
	call ioa_ ("^/  ADDR   SEQNO   DATE       TIME     CODE  MESSAGE TEXT^/");
	j = 0;
	repeat_sw = "0"b;
	do i = 1 to count;
	     smess_ptr = addrel (slog_ptr, offset);
	     if smess.text_len = 0 then do;
		call ioa_ ("syserr entry at ^p is null", addrel (p, offset));
		go to pellp;
	     end;


	     mblen = smess.text_len;
	     p = addr (smess.text);
	     pm = addrel (slog_ptr, fixed (smess_ptr -> smess.prev, 18));
	     mblenn = pm -> smess.text_len;
	     ap = addr (pm -> smess.text);
	     if msbuf = msbuff then do;
		repeat_sw = "1"b;
		j = j + 1;
		i = i - 1;
		go to pellp;
	     end;
	     else if repeat_sw then do;
		repeat_sw = "0"b;
		call ioa_ ("^d occurrances of message - ""^a""", j + 1, msbuf);
		j = 0;
		go to pellp;
	     end;
	     offset = fixed (rel (smess_ptr), 18) - fixed (rel (slog_ptr), 18);
	     call ioa_ ("^6o  ^6o  ^20a   ^o   ^a", offset, smess.seq_num,
		datm (addr (smess.time)), smess.code, msbuf);
pellp:
	     offset = fixed (smess_ptr -> smess.prev, 18);
	end;
	go to restore_dbr;

datm:	proc (tp) returns (char (20) aligned);
dcl  tp ptr;					/* pointer to time value to convert */
dcl  timcv fixed bin (71);
dcl  timein (2) fixed bin (35) based (tp);
dcl  timeint (2) fixed bin (35) based (addr (timcv));
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  timout char (20);
	     timeint = timein;			/* Copy time value to assure even boundary */
	     call date_time_ (timcv, timout);
	     return (timout);
	end datm;

restore_dbr:

	dbrsv = saved_dbr;
	kstseg = saved_kstseg;
	kstptr = saved_kstptr;
	call ol_dump_util_$fnd_dbr (dbrsv, segln, i, odsp);
	call ol_dump_util_$get_ptr (kstseg, kstptr, segln, odsp);
	return;

     end display_syserr_;




		    hran_.pl1                       11/10/82  1713.3rew 11/10/82  1315.9      179460



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


hran_: proc;

	return;					/* do not enter here */

/* hran_ - history register analyzer
   written by - E. J. Wallman Oct. 1974
   Modified by A. Downing March 1976 to add the set_stream entry for use in Multics HEALS.
   Also, all calls to ioa_ were changed to ioa_$ioa_switch, and calls to ioa_$nnl were changed
   to calls to ioa_$ioa_switch_nnl.
   Modified by RH Morrison in September, 1976 to squeeze the output format
   into 72 columns.  To do this, the octal printout of the history registers
   was eliminated from hran_$hranl since these registers are
   printed by cpu_reports_ prior to calling hranl.
   Modified by J. A. Bush in June 1977 to  allow for general use by heals_, ol_dump,
   and  mc_trace. The set_stream entry point was discarded in favor of a switch entry parameter.
   The long output conditional code was added to allow displaying of octal history  registers
   as well as symbolic data.

   Re-written in October 1980 by R. L. Coppola to accomodate analysis of
   registers for the DPS8 CPU which are different in structure and sometimes
   in length.  The DPS8 contains four sets (OU, DU/OU, and 2 APU) of registers
   each containing 64 double word history registers. However fim will only save
   the 16 MRU hregs in normal operation, BOS dumps will contain all 64.

   The analysis routines for the L68 and DPS8 have been placed in seperate
   external  sub-routines, this procedure will make a determination as to which
   analyzer is appropriate and then call it.
*/

/*	This routine transposed from the original key of GMAP-flat
   to PL/I-sharp in October, 1974.  It decomposes the CP6100
   history register data saved in the prds and formats the data
   into easily readable lines in the order in which the various
   processor cycles occured.

   The routine has four entry points which are independent
   of each other. They are ...

   hrlgnd_l68_ Print a legend giving the definitions of all flags
	     and symbols used in the output of the l68 analyzer.


   hrlgnd_dps8_ Print a legend giving the definitions of all flags
	      and symbols used in the output of the dps8 analyzer.

   hran_bos    Set the history register block size to 512 words
	     instead of the normal 128 words.

   hranl_      Normal entry point for history register analysis.
	     History register block size of 128 words default.


   display_      Normal entry point for display of history regs.
	       No attempt is made to "thread" them. The 
	       interp_sw bit is used to enable interpretation
	       of the registers.

   All output goes to switch "output_switch". If a null iocb pointer
   is passed, then  the switch iox_$user_output is used as a default.
   Otherwise  "output_switch" is used as it is passed. If the long_output_sw = "0"b,
   then the octal contents of the history registers are not printed, therefore allowing
   the output to fit on an 80 character wide terminal. If the long_output_sw = "1"b,
   then the octal contents of the history registers is displayed as well as symbolic data.


   */

/* ENTRIES */

dcl  ioa_$ioa_switch options (variable),
     ioa_$ioa_switch_nnl entry options (variable),
     ioa_$rsnnl entry options (variable);
dcl  hran_l68_$hranl_l68_ entry (ptr, ptr, bit (1));
dcl  hran_dps8_$hranl_dps8_ entry (ptr, ptr, fixed bin, bit (1));
dcl  hran_l68_$hranl_l68_bos entry (ptr, ptr, bit (1));
dcl  hran_l68_$bos_no_thread entry (ptr, ptr, bit (5));
dcl  hran_dps8_$no_thread entry (ptr, ptr, fixed bin, bit (5));
dcl  hran_l68_$no_thread entry (ptr, ptr, bit (5));

/* PARAMETERS */

dcl (hr_data_ptr, a_iocbp) ptr;
dcl  lo_sw bit (1);					
dcl  switches bit (5);				/* switches to display */
						/* each hreg and how to display it */
						/* must be in the following order */
						/* expand_sw */
						/* ou, cu, apu, du */

/* AUTOMATIC STORAGE */


dcl  iocbp ptr,					/* output switch name */
     iox_$user_output ptr ext,			/* default io switch */
     lo fixed;					/* long output sw, 1 => long output 2 => short output */

dcl 1 apu_or_du_word aligned based (apu_or_duhrp),	/* first word of the apu or du regs */
   (2 PAD bit (71),
    2 apu_or_du_bit bit (1) unaligned);			/* always on for a L68 CPU */

dcl  ou_block1 bit (36 * 2 * 16) based;			/* and the second */
dcl  (apu_or_duhrp, ouhrp) ptr;
dcl  nregs fixed bin;
dcl  threaded bit (1);

/* OTHER */

dcl  null builtin;

%page;
hran_bos:	entry (hr_data_ptr, a_iocbp, lo_sw);

	threaded = "1"b;
	go to COMMON_BOS;

bos_no_thread: entry  (hr_data_ptr, a_iocbp, switches);
	     

	threaded = "0"b;

COMMON_BOS:

/* Regs have been saved as a result of a crash (by BOS), need to determine
   the type of CPU they are from */

	     ouhrp = addrel (hr_data_ptr, 32);		/* set ptr to second block of ou data */
	     if ouhrp -> ou_block1 = "0"b then do;
						/* if empty these are from a l68 */

	        if threaded = "1"b then
	        call hran_l68_$hranl_l68_bos (hr_data_ptr, a_iocbp, lo_sw);
						/* for now do same one */
	        else call hran_l68_$bos_no_thread (hr_data_ptr, a_iocbp, switches);
	        return;
	        end;

	     else do;				/* not empty, regs are from a dps8 */
		nregs = 64;			/* 64 regs each are saved */
		if threaded = "1"b then
		call hran_dps8_$hranl_dps8_ (hr_data_ptr, a_iocbp, nregs, lo_sw);
		else call hran_dps8_$no_thread (hr_data_ptr, a_iocbp, nregs, switches);
		return;
	     end;

	  return;
%page;
hranl:	entry (hr_data_ptr, a_iocbp, lo_sw);

	threaded = "1"b;
	go to HRANL_COMMON;
	

no_thread:  entry (hr_data_ptr, a_iocbp, switches);
	
	         threaded = "0"b;

HRANL_COMMON:

/* regs were saved by fim but what type of CPU are they from */


	     nregs = 16;				/* we do know how many regs there are */
	     apu_or_duhrp = addrel (hr_data_ptr, 64);	/* set ptr to appropriate hreg block */

/* Bit 71 of the L68 DU history registers is ALWAYS on, test it to determine CPU type */

	     if apu_or_du_bit = "1"b then do;		/* it is a l68 */
	        if threaded then
		call hran_l68_$hranl_l68_ (hr_data_ptr, a_iocbp, lo_sw) ;
		else call hran_l68_$no_thread (hr_data_ptr, a_iocbp, switches);
		return;
		end;

	     else do;				/* no, its a dps8 */
	        if threaded then
	        call hran_dps8_$hranl_dps8_ (hr_data_ptr, a_iocbp, nregs, lo_sw);
	        else call hran_dps8_$no_thread (hr_data_ptr, a_iocbp, nregs, switches);
	        return;
	        end;

	return;

%page;
hrlgnd_dps8_: entry (a_iocbp);


	if a_iocbp = null then			/* called to use default switch */
	     iocbp = iox_$user_output;
	else iocbp = a_iocbp;
	call ioa_$ioa_switch (iocbp, "^|Abbreviations used in History Register Analysis for the DPS8 CPU^/^/");

	call ioa_$ioa_switch (iocbp, "^2/^12(_^)CU Legend^13(_^)^4x^12(_^)OU Legend^13(_^)");
	call ioa_$ioa_switch (iocbp, "cy = cycle type (d = direct operand)^2x^1-   >>>flags<<<");
	call ioa_$ioa_switch (iocbp, "(i=instr. fetch,o=operand,F=fault)^4xtrgo = transfer condition met");
	call ioa_$ioa_switch (iocbp, "(n=indirect,x=xec,*=nop,e=EIS)^8xdl   = direct lower operand");
	call ioa_$ioa_switch (iocbp, "mc = memory command^2-^8xdu   = direct upper operand");
	call ioa_$ioa_switch (iocbp, "(00=rrs,sp; 04=rrs,dp; 10=rcl,sp)");
	call ioa_$ioa_switch (iocbp, "(12=rmsk,sp; 16=rmsk,dp; 20=cwr,sp)");
	call ioa_$ioa_switch (iocbp, "(24=cwr,dp; 32=smsk,sp; 36=smsk,dp)");
	call ioa_$ioa_switch (iocbp, "(40=rd/lck; 54=rgr; 56=sgr)");
	call ioa_$ioa_switch (iocbp, "(60=wrt/ulck; 62=con; 66=xec; 72=sxc)");
	call ioa_$ioa_switch (iocbp, "^1->>>flags<<<");
	call ioa_$ioa_switch (iocbp, "-y    = memory address invalid^8x<<<Indicator Register>>>");
	call ioa_$ioa_switch (iocbp, "priv  = PRIV mode^2-^8xzero  = zero indicator");
	call ioa_$ioa_switch (iocbp, "inf   = instruction fetch cycle^7xsign  = sign indicator");
	call ioa_$ioa_switch (iocbp, "xint  = execute interrupt cycle^7xcarry = carry indicator");
	call ioa_$ioa_switch (iocbp, "dir   = direct operand^1-^8xovfl  = overflow indicator");
	call ioa_$ioa_switch (iocbp, "pfa   = prepare fault address^1-^8xeovfl = exponent overflow ");
	call ioa_$ioa_switch (iocbp, "ic    = IC value is odd^1-^8xeufl  = exponent underflow");
	call ioa_$ioa_switch (iocbp, "its   = AR/PR reference^1-^8xoflm  = overflow mask");
	call ioa_$ioa_switch (iocbp, "inh   = inhibited instruction^1-^8xhex   = hex mode");
	call ioa_$ioa_switch (iocbp, "poa   = prepare operand address");
	call ioa_$ioa_switch (iocbp, "pai   = prepare interrupt address");
	call ioa_$ioa_switch (iocbp, "pia   = prepare instruction address");
	call ioa_$ioa_switch (iocbp, "pib   = port select logic busy");
	call ioa_$ioa_switch (iocbp, "pon   = prepare operand next");
	call ioa_$ioa_switch (iocbp, "pot   = prepare operand tally");
	call ioa_$ioa_switch (iocbp, "raw   = request alter word");
	call ioa_$ioa_switch (iocbp, "riw   = request indirect word");
	call ioa_$ioa_switch (iocbp, "rpts  = executing repeat");
	call ioa_$ioa_switch (iocbp, "saw   = store alter word");
	call ioa_$ioa_switch (iocbp, "siw   = store indirect word");
	call ioa_$ioa_switch (iocbp, "xde   = execute double from even ICT");
	call ioa_$ioa_switch (iocbp, "xdo   = execute double from odd ICT");
	call ioa_$ioa_switch (iocbp, "port  = memory cycle went to port");
	call ioa_$ioa_switch (iocbp, "internal = memory cycle went to cache or direct");

	call ioa_$ioa_switch (iocbp, "^|^/^12(_^)DU Legend^13(_^)^4x^12(_^)APU Legend^12(_^)");
	call ioa_$ioa_switch (iocbp, "mc     = data mode (b,4,6,9,w)^8xseg# = SDWAMR and PTWAMR numbers if");
	call ioa_$ioa_switch (iocbp, "offset = descriptor counter^1-^8xcorresponding MATCH bits are set.");
	call ioa_$ioa_switch (iocbp, "^1->>>flags<<<^1-^8xoffset = final store address");
	call ioa_$ioa_switch (iocbp, "shftg = shift gate^11xmc = ring number (TSR.TRR)");
	call ioa_$ioa_switch (iocbp, "d1a   = load alpha-num descriptor 1^13x>>>flags<<<");
	call ioa_$ioa_switch (iocbp, "d2a   = load alpha-num descriptor 2^38tfanp      = final address, non-paged");
	call ioa_$ioa_switch (iocbp, "anstr = alpha store^38tfap       = final address, paged");
	call ioa_$ioa_switch (iocbp, "chrcy = character cycle^38tacv/dft   = access violation/directed fault");
	call ioa_$ioa_switch (iocbp, "d1n   = load numeric descriptor 1^38tfdsptw    = fetch descriptor segment PTW");
	call ioa_$ioa_switch (iocbp, "d2n   = load numeric descriptor 2^38tflthld    = acv/dft fault waiting");
	call ioa_$ioa_switch (iocbp, "gstr  = decimal unit store^38tfsdw      = fetch SDW");
	call ioa_$ioa_switch (iocbp, "lrw1  = load re-write reg 1 (1,2,3)^38tmdsptw    = modify descriptor segment PTW");
	call ioa_$ioa_switch (iocbp, "lrw2  = load re-write reg 2^38tmptw      = modify PTW");
	call ioa_$ioa_switch (iocbp, "ndsqf = end of sequence flag^38tfptw      = fetch PTW");
	call ioa_$ioa_switch (iocbp, "dud   = decimal unit idle^38tfptw2     = fetch PTW+1 (for EIS Numerics)");
	call ioa_$ioa_switch (iocbp, "duint = decimal unit interrupted^38tptwm      = MATCH in PTWAM");
	call ioa_$ioa_switch (iocbp, "ndseq = end of sequence^38tsdwm      = MATCH in SDWAM");
	call ioa_$ioa_switch (iocbp, "adcyc = add cycle^38tcache     = cache used for this cycle");
	call ioa_$ioa_switch (iocbp, "sp3   = select pointer 3^38tpiapgbsy  = instruction fetch across");
	call ioa_$ioa_switch (iocbp, "pop   = prepare operand pointer^50ta page boundary");
	call ioa_$ioa_switch (iocbp, "sp1   = select pointer 1^38tpiaoosb   = instruction fetch went");
	call ioa_$ioa_switch (iocbp, "sp2   = select pointer 2^50tout of segment bounds");
	call ioa_$ioa_switch (iocbp, "lptr1 = Load Pointer #1^38tSDWAM-ERR = Multi-Match/Parity Error");
	call ioa_$ioa_switch (iocbp, "lptr2 = Load Pointer #2^50tin SDW Assoc. Memory");
	call ioa_$ioa_switch (iocbp, "addgC = add gate C^38tPTWAM-ERR = Multi-Match/Parity Error in");
	call ioa_$ioa_switch (iocbp, "swseq = single word sequence^50tPTW Assoc. Memory");
	call ioa_$ioa_switch (iocbp, "exh   = length exhaust");
	call ioa_$ioa_switch (iocbp, "addgE = add gate E");
	call ioa_$ioa_switch (iocbp, "addgF = add gate F");
	call ioa_$ioa_switch (iocbp, "addgH = add gate H");
	call ioa_$ioa_switch (iocbp, "btdgA = binary to decimal gate A");
	call ioa_$ioa_switch (iocbp, "dfrst = processing descriptor for^/^8xthe first time.");

	return;

%page;

hrlgnd:	entry (a_iocbp);				/* for compatibility */
hrlgnd_l68_: entry (a_iocbp);

	if a_iocbp = null then			/* called to use default switch */
	     iocbp = iox_$user_output;
	else iocbp = a_iocbp;
	call ioa_$ioa_switch (iocbp, "^|Abbreviations used in History Register Analysis for the L68 CPU^/^/");

	call ioa_$ioa_switch (iocbp, "^2/^12(_^)CU Legend^13(_^)^4x^12(_^)OU Legend^13(_^)");
	call ioa_$ioa_switch (iocbp, "cy = cycle type (d = direct operand)^2x>>flags<<<");
	call ioa_$ioa_switch (iocbp, "(i=instr. fetch,o=operand,F=fault)^4x9b = 9-bit byte (IT modifier only)");
	call ioa_$ioa_switch (iocbp, "(n=indirect,x=xec,*=nop,e=EIS)^8xar = A-register in use");
	call ioa_$ioa_switch (iocbp, "mc = memory command^2-^8xd1 = first divide cycle");
	call ioa_$ioa_switch (iocbp, "(00=rrs,sp; 04=rrs,dp; 10=rcl,sp)^5xd2 = second divide cycle");
	call ioa_$ioa_switch (iocbp, "(12=rmsk,sp; 16=rmsk,dp; 20=cwr,sp)^3xdl = direct lower operand");
	call ioa_$ioa_switch (iocbp, "(24=cwr,dp; 32=smsk,sp; 36=smsk,dp)^3xdu = direct upper operand");
	call ioa_$ioa_switch (iocbp, "(40=rd/lck; 54=rgr; 56=sgr)^1-^8xin = first ou cycle");
	call ioa_$ioa_switch (iocbp, "(60=wrt/ulck; 62=con; 66=xec; 72=sxc)^1xit = IT character modifier");
	call ioa_$ioa_switch (iocbp, ">>>flags<<<^2-^8xoa = mantissa alignment cycle");
	call ioa_$ioa_switch (iocbp, "-y = memory address invalid^1-^8xoe = exponent compare cycle");
	call ioa_$ioa_switch (iocbp, "br = BAR mode^2-^8xof = final OU cycle");
	call ioa_$ioa_switch (iocbp, "cl = control unit load^1-^8xom = general OU cycle");
	call ioa_$ioa_switch (iocbp, "cs = control unit store^1-^8xon = normalize cycle");
	call ioa_$ioa_switch (iocbp, "dr = direct operand^2-^8xos = second cycle of multiple ops");
	call ioa_$ioa_switch (iocbp, "fa = prepare fault address^1-^8xqr = Q-register in use");
	call ioa_$ioa_switch (iocbp, "ic = IC value is odd^1-^8xrb = opcode buffer loaded");
	call ioa_$ioa_switch (iocbp, "it = AR/PR reference^1-^8xrp = primary register loaded");
	call ioa_$ioa_switch (iocbp, "in = inhibited instruction^1-^8xrs = secondary register loaded");
	call ioa_$ioa_switch (iocbp, "ol = operations unit load^1-^8xsd = store data available");
	call ioa_$ioa_switch (iocbp, "os = operations unit store^1-^8x-d = data not available");
	call ioa_$ioa_switch (iocbp, "pa = prepare operand address^1-^8xx0 = index 0 in use");
	call ioa_$ioa_switch (iocbp, "pb = port busy _o_r data from cache^5xx1 = index 1 in use");
	call ioa_$ioa_switch (iocbp, "pi = prepare instruction address^6xx2 = index 2 in use");
	call ioa_$ioa_switch (iocbp, "pl = port select logic not busy^7xx3 = index 3 in use");
	call ioa_$ioa_switch (iocbp, "pn = prepare final indirect address^3xx4 = index 4 in use");
	call ioa_$ioa_switch (iocbp, "pt = prepare operand tally^1-^8xx5 = index 5 in use");
	call ioa_$ioa_switch (iocbp, "ra = request alter word^1-^8xx6 = index 6 in use");
	call ioa_$ioa_switch (iocbp, "ri = request indirect word^1-^8xx7 = index 7 in use");
	call ioa_$ioa_switch (iocbp, "rp = executing repeat");
	call ioa_$ioa_switch (iocbp, "sa = store alter word");
	call ioa_$ioa_switch (iocbp, "si = store indirect word");
	call ioa_$ioa_switch (iocbp, "tr = transfer condition met");
	call ioa_$ioa_switch (iocbp, "wi = request instruction fetch");
	call ioa_$ioa_switch (iocbp, "xa = prepare execute interrupt address");
	call ioa_$ioa_switch (iocbp, "xe = execute double from even ICT");
	call ioa_$ioa_switch (iocbp, "xi = execute interrupt present");
	call ioa_$ioa_switch (iocbp, "xo = execute double from odd ICT");

	call ioa_$ioa_switch (iocbp, "^|^/^12(_^)DU Legend^13(_^)^4x^12(_^)APU Legend^12(_^)");
	call ioa_$ioa_switch (iocbp, "mc = data mode (b,4,6,9,w)^1-^8xseg# = SDWAMR and PTWAMR numbers if");
	call ioa_$ioa_switch (iocbp, "offset = descriptor counter^1-^8xcorresponding MATCH bits are set.");
	call ioa_$ioa_switch (iocbp, ">>>flags<<<^2-^8xoffset = final store address");
	call ioa_$ioa_switch (iocbp, "()a = prepare alignment count for^5xmc = ring number (TSR.TRR)");
	call ioa_$ioa_switch (iocbp, "^6xnumeric operand (1,2)");
	call ioa_$ioa_switch (iocbp, "a() = load alpha operand (1,2)^8x>>>flags<<<");
	call ioa_$ioa_switch (iocbp, "al = adjust length^2-^8xan = final address, non-paged");
	call ioa_$ioa_switch (iocbp, "as = alpha store^2-^8xap = final address, paged");
	call ioa_$ioa_switch (iocbp, "bd = binary-decimal execution^1-^8xf  = access violation or directed fault");
	call ioa_$ioa_switch (iocbp, "bg = blanking gate^2-^8xfd = fetch descriptor segment PTW");
	call ioa_$ioa_switch (iocbp, "c0 = force stc0^2-^8xfh = fault waiting");
	call ioa_$ioa_switch (iocbp, "cg = character operation^1-^8xfs = fetch SDW");
	call ioa_$ioa_switch (iocbp, "d() = descriptor active (1,2,3)^7xmd = modify descriptor segment PTW");
	call ioa_$ioa_switch (iocbp, "da = data available^2-^8xmp = modify PTW");
	call ioa_$ioa_switch (iocbp, "db = decimal-binary execution^1-^8xp1 = fetch PTW");
	call ioa_$ioa_switch (iocbp, "dd = decimal unit idle^1-^8xp2 = fetch PTW+1");
	call ioa_$ioa_switch (iocbp, "di = decimal unit interrupted^1-^8xpm = MATCH in PTWAM");
	call ioa_$ioa_switch (iocbp, "dl = decimal unit load^1-^8xsm = MATCH in SDWAM");
	call ioa_$ioa_switch (iocbp, "ds = decimal unit store");
	call ioa_$ioa_switch (iocbp, "ei = mid-instruction interrupt enabled");
	call ioa_$ioa_switch (iocbp, "en = end instruction");
	call ioa_$ioa_switch (iocbp, "es = end sequence");
	call ioa_$ioa_switch (iocbp, "ff = floating result");
	call ioa_$ioa_switch (iocbp, "fl = first data buffer load");
	call ioa_$ioa_switch (iocbp, "fp = first pointer preparation");
	call ioa_$ioa_switch (iocbp, "fs = end sequence");
	call ioa_$ioa_switch (iocbp, "l() = load descriptor (1,2,3)");
	call ioa_$ioa_switch (iocbp, "ld = length = direct");
	call ioa_$ioa_switch (iocbp, "lf = end first pointer preparation");
	call ioa_$ioa_switch (iocbp, "lv = level < word size");
	call ioa_$ioa_switch (iocbp, "lx = length exhaust");
	call ioa_$ioa_switch (iocbp, "l< = length < 128");
	call ioa_$ioa_switch (iocbp, "mp = executing MOPs");
	call ioa_$ioa_switch (iocbp, "n() = load numeric operand (1,2)");
	call ioa_$ioa_switch (iocbp, "nd = need descriptor");
	call ioa_$ioa_switch (iocbp, "ns = numeric store");
	call ioa_$ioa_switch (iocbp, "op = operand available");
	call ioa_$ioa_switch (iocbp, "pc = alpha packing cycle");
	call ioa_$ioa_switch (iocbp, "pl = prepare operand length");
	call ioa_$ioa_switch (iocbp, "pp = prepare operand pointer");
	call ioa_$ioa_switch (iocbp, "r() = load rewrite register (1,2)");
	call ioa_$ioa_switch (iocbp, "re = write-back partial word");
	call ioa_$ioa_switch (iocbp, "rf = rounding");
	call ioa_$ioa_switch (iocbp, "rl = rewrite register 1 loaded");
	call ioa_$ioa_switch (iocbp, "rw = du=rd+wt control interlock");
	call ioa_$ioa_switch (iocbp, "sa = select address register");
	call ioa_$ioa_switch (iocbp, "sg = shift procedure");
	call ioa_$ioa_switch (iocbp, "xg = exponent network");
	call ioa_$ioa_switch (iocbp, "xm = extended al,ql modifier");
	call ioa_$ioa_switch (iocbp, "+g = add-subtract execution");
	call ioa_$ioa_switch (iocbp, "*g = multiply-divide execution");

	return;

     end hran_;




		    hran_dps8_.pl1                  11/10/82  1713.3rew 11/10/82  1316.0      259569



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


/*  Coded August 1980 by Rich Coppola for support of the DPS8M CPU */

/*  Modified Oct 1982 by Rich Coppola to make 'threading' work properly.
   Some notes: The 870M CPU does not append on PIAs unless it crosses a page
   boundary (apuhr1.piapgbsy). Also direct cycles get entered in the APU hregs
   even though the APU does nothing. This version of the 'threader' attempts to
   follow these 'rules' so that the 'analyzed' registers are threaded properly.
   A new feature has been added as well. If the final address (apuhr1.finadd)
   of the APU does not agree with the address that the CU developed
   (cuhr.ca_value) a diagnostic message is displayed. These mismatches may
   be due to REAL address problems or a failure to strobe the address into
   the appropriate hreg properly.

   Modified Oct 1982 by Rich Coppola to add entries for the display of hregs
   in octal and interpreted, but not threaded, hregs.
*/

hran_dps8_: proc;

	return;					/* do not enter here */


/* PARAMETERS */

dcl  a_iocbp ptr;
dcl  lo_sw bit (1);
dcl  switches bit (5);				/* tell what hregs to display and how */
						/* must be in this order */
						/* expand_sw
						   do_ou
						   do_cu
						   do_au
						   do_du */


/* EXTERNAL DATA */

dcl  ioa_$ioa_switch options (variable),
     ioa_$ioa_switch_nnl entry options (variable),
     ioa_$rsnnl entry options (variable);		/* default io switch */

/* AUTOMATIC STORAGE */

dcl  a_nregs fixed bin;				/* auto copy of number of regs */

dcl 1 a_switches based (addr (switches)),
    (2 expand_sw bit (1),
     2 do_ou bit (1),
     2 do_cu bit (1),
     2 do_au bit (1),
     2 do_du bit (1)) unal;

dcl (i, j, foo, cusegno, ausegno) fixed bin;
dcl  PAD (0:10) char (11) var int static options (constant) init (
     "", " ", "  ", "   ", "    ", "     ", "      ", "       ",
     "        ", "         ", "          ");
dcl (OP_pad, TAG_pad) char (4) var;
dcl  AU_index fixed bin,				/* AU1 data index */
     au_synched bit (1),
     au2 bit (1),
     CU_index fixed bin,				/* index into CU data */
     CU_ptr ptr,					/* pointer to CU data */
     CY_print char (1),				/* cycle type for output */
     DU_mode char (1),				/* DU execution mode symbol */
     IC_cur fixed bin (18) init (1),			/* current IC value for CU entries */
     IC_next fixed bin (18) init (1),			/* next IC value for CU entries */
     IC_last fixed bin (18) init (1),			/* last IC value for CU lines */
     IC_print bit (1),				/* sw to print IC value */
     IC_value fixed bin (18),				/* IC value for output */
     LEVEL (0:3) char (1) init ("A", "B", "C", "D"),	/* level of ASS MEM for printing */
     NOP_flag bit (1) init ("0"b),			/* flag for NOP cycles */
     OP_cur bit (10) init ((10)"0"b),			/* current opcode for CU lines */
     OP_last bit (10) init ((10)"0"b),			/* last opcode for CU lines */
     OP_print char (5) var,				/* opcode string for printing */
     tpr_ca char (6),
     TPR_CA_PR char (8) var,
     DU_OU_ptr ptr,					/* pointer to DU_OU data */
     DU_OU_synch fixed bin init (0),			/* index value at which DU_OU & CU synchronize */
     PTW_print char (3),				/* PTWAM level and reg# for printing */
     SDW_print char (3),				/* SDWAM level and reg# for printing */
     SEG_print bit (1),				/* switch for printing segno */
     AUSEG_pr bit (1),				/*  same for au regs */
    (pr_autag, pr_auop, pr_cuop, pr_cutag) bit (1),
     TAG_cur fixed bin,				/* current TAG table index */
     TAG_print char (3) var,				/* TAG string for printing */
     XD1_flag bit (1) init ("0"b),			/* flag for 1st of XED pair  */
     XD2_flag bit (1) init ("0"b),			/* flag for 2nd of XED pair */
     XEC_flag bit (1) init ("0"b),			/* XEC flag */
     XED_flag bit (1) init ("0"b),			/* XED flag */
     AUOP bit (10),					/* for display of OP and tag */
     AUOP_PR char (5) var,				/* in AU2 */
     AUTAG fixed bin,
     AUTAG_PR char (3) var,
    (temp_char1, temp_char2) char (2),
     null builtin,
     iocbp ptr,					/* output switch name */
     iox_$user_output ptr ext,			/* default io switch */
     fetch_count fixed bin init (0),			/* fetch cycle count */

     pull_count fixed bin init (0);			/* index into instruction pull table */

dcl  au_cycle_done bit (1) init ("0"b);

dcl  repeat_count fixed bin init (0),			/* OU instruction repeat count */
     tag_chain_flag bit (1);				/* tag print control flag  */
dcl  hr_block bit (36*2*4*16) based;			/* #of bits in the prds hr data block  */

dcl 1 cu_regs (64) based (cuhrp),
   (2 cu_flags bit (18),
    2 cu_op bit (18),
    2 cu_addr bit (24),
    2 cu_pt_flags bit (12)) unaligned;

dcl 1 ou_regs (64) based (du_ouhrp),
   (2 du_regs bit (36),
    2 ou_ic bit (18),
    2 ou_rs bit (9),
    2 ou_inds bit (9)) unaligned;

dcl 1 apu1_regs (64) based (aphrp1),
   (2 ap1_segno bit (15),
    2 ap1_flags1 bit (12),
    2 ap1_flags2 bit (8),
    2 ap1_flt bit (1),
    2 ap1_finadd bit (24),
    2 ap1_trr bit (3),
    2 ap1_flags3 bit (9)) unaligned;


dcl 1 apu2_regs (64) based (aphrp2),
   (2 ap2_ca bit (18),
    2 ap2_op bit (18),
    2 ap2_pad bit (36)) unaligned;

dcl  code fixed bin (35);
%page;
hranl_dps8_: entry (hr_data_ptr, a_iocbp, nregs, lo_sw);



	code = 0;
	call setup;
	if code ^= 0 then
	     return;



/* History regs should be valid, print heading and initialize */

	call ioa_$ioa_switch (iocbp, "DPS8 History Register Analysis");
	call ioa_$ioa_switch (iocbp, "^/HR ^[^34x^;^10x^]IC or^12xc^3xMemory", lo_sw);

	call ioa_$ioa_switch_nnl (iocbp,
	     "id^[^9thr contents^8x^;^4t^]  Seg# [tpr.ca] opcode tag y  Address mc flags^/", lo_sw);



/* Merge CU & OU entries up to fault cycle */

HRA01:

	IC_last = 0;
	AU_index = a_nregs + 1;
	OP_last = "777"b3;
	au_synched = "0"b;


	do CU_index = 1 to a_nregs -1;

	     IC_cur = fixed (du_ouhr.ict (CU_index), 18);
	     OP_cur = cuhr.op_code (CU_index);
	     if au_synched = "0"b then call synch_auhr;
	     call cur;
	     OP_last = OP_cur;
	     IC_last = IC_cur;
	end;



/* Do the fault cycles */

do_flt_cycle:


	IC_cur = fixed (du_ouhr.ict (CU_index), 18);
	OP_cur = cuhr.op_code (CU_index);
	call cur;
	call ioa_$ioa_switch (iocbp, "^/");
	return;

cur:	proc;


/* Determine if IC value is to be displayed */


/*  if we are repeating _o_r XEC'ing ... */

	     if cuhr.rpts (CU_index) | XEC_flag then goto cur03;

cur02:

	     if (IC_cur ^= IC_last) then do;		/* if IC or OP has changed since last CU line ... */
	        IC_cur = fixed (du_ouhr.ict (CU_index), 18);
		IC_value = IC_cur;
		IC_print = "1"b;
	     end;

	     else IC_print = "0"b;			/* if IC didn't change, don't print */

	     if XED_flag then do;			/* if  XEDing ... */

		if ^XD1_flag then do;		/* if 1st of XED pair not been done ... */
		     XD1_flag = "1"b;		/* we are about to do it */
		     goto cur03;
		end;

		if ^XD2_flag then do;		/* if 2nd of XED pair has not been done ... */
		     if cuhr.op_code (CU_index) ^= OP_cur then
			XD2_flag = "1"b;		/* we are about to do it */
		     goto cur03;
		end;

		if cuhr.op_code (CU_index) ^= OP_cur then
		     XED_flag, XD1_flag, XD2_flag = "0"b; /* XED finished, reset all flags */
	     end;



cur03:
	     if OP_cur = OP_last & IC_print = "0"b then
						/* if neither IC nor opcode have changed ... */
		pr_cuop = "0"b;			/* this must be the same instruction */

	     else do;
		OP_cur = cuhr.op_code (CU_index);
		OP_print = rtrim (OP.code (fixed (OP_cur, 10)+1));
		pr_cuop = "1"b;
	     end;

cur04:	     if OP.DUOP (fixed (cuhr.op_code (CU_index), 10)+1) /* if a decimal op ... */
	     | cuhr.op_code (CU_index) = STCA		/* or STCA ... */
	     | cuhr.op_code (CU_index) = STCQ		/* or STCQ ... */
	     | cuhr.op_code (CU_index) = STBA		/* or STBA ... */
	     | cuhr.op_code (CU_index) = STBQ		/* or STBQ ... */
	     | cuhr.rpts (CU_index)			/* or its a repeat */
	     then do;				/* print a blank TAG */
		TAG_cur = 0;
		pr_cutag = "0"b;
	     end;

	     else do;
		TAG_cur = fixed (cuhr.tag (CU_index), 10)+1;
		TAG_print = rtrim (TAG.code (TAG_cur));
		pr_cutag = "1"b;
	     end;

	     if TAG_cur > 0 then			/* if its a true tag ... */
		tag_chain_flag = TAG.chain (TAG_cur);	/* set tag chain flag */


	     CY_print = "?";			/* set up for don't know */


	     if cuhr.pfa (CU_index) then CY_print = "F";

	     else if cuhr.xint (CU_index) then CY_print = "x";

	     else if cuhr.pia (CU_index) then do;
		CY_print = "i";
		if cuhr.op_code (CU_index) ^= XED then do;
		     IC_next = fixed (cuhr.ca_value (CU_index), 24);
		     XED_flag, XD1_flag, XD2_flag = "0"b; /* reset XED flags for transfer */
		end;

		else if cuhr.op_code (CU_index) ^= XEC then do;
		     IC_next = fixed (cuhr.ca_value (CU_index), 24);
		     XEC_flag = "0"b;
		end;

	     end;

	     else if cuhr.riw (CU_index) | cuhr.siw (CU_index) then
		CY_print = "n";


	     else if (fixed (cuhr.tag (CU_index), 6) = 3) |
	     (fixed (cuhr.tag (CU_index), 6) = 7)
	     then CY_print = "d";


	     else if OP.DUOP (fixed (OP_cur, 10)+1) then
		CY_print = "e";

	     else if OP_cur = NOP
	     | (OP.TR (fixed (OP_cur, 10)+1) & ^cuhr.rtrgo (CU_index)) then do;
		CY_print = "*";
		NOP_flag = "1"b;
	     end;

	     else if (^cuhr.pia (CU_index)) & (cuhr.poa (CU_index)) then
		CY_print = "o";

	     if au_synched = "1"b then
		if ext_hr.AU1.even (AU_index) ^= "0"b then
		     if apuhr2.opcode (AU_index) = cuhr.op_code (CU_index) then do;
			cusegno = fixed (apuhr1.esn (AU_index), 15);
			SEG_print = "1"b;
		     end;

		     else SEG_print = "0"b;

	     if pr_cuop then do;
		foo = length (OP_print);		/* get proper # of pad chars to right justify */
		foo = 5 - foo;
		OP_pad = PAD (foo);
		OP_print = OP_pad || OP_print;
	     end;

	     if pr_cutag then do;
		foo = length (TAG_print);		/* do same for TAG */
		foo = 3 - foo;
		TAG_pad = PAD (foo);
		TAG_print = TAG_pad || TAG_print;
	     end;
	     else TAG_print = "";


	     call ioa_$ioa_switch_nnl (iocbp, "^/CU ^[^12.3b ^12.3b^;^2s^5t^]^[^5o^;^s^5x^]   ^[^6o^;^s^6x^]  ^[^a^;^s^5x^] ^[^3a^;^s^3x^] ^1a ^8o ^2o ",
		lo_sw, ext_hr.CU.even (CU_index), ext_hr.CU.odd (CU_index),
		SEG_print, cusegno,
		IC_print, IC_value,
		pr_cuop, OP_print,
		pr_cutag, rtrim (TAG_print),
		CY_print,
		fixed (cuhr.ca_value (CU_index), 24),
		2 * fixed (cuhr.pcmd (CU_index), 3));

	     call ioa_$ioa_switch_nnl (iocbp, "^[pia ^]^[poa ^]^[riw ^]^[siw ^]^[pot ^]^[pon ^]",
		cuhr (CU_index).pia, cuhr (CU_index).poa, cuhr (CU_index).riw,
		cuhr (CU_index).siw, cuhr (CU_index).pot, cuhr (CU_index).pon);

	     call ioa_$ioa_switch_nnl (iocbp, "^[raw ^]^[saw ^]^[inf ^]^[xde ^]^[xdo ^]^[ic ^]^[rpts ^]",
		cuhr (CU_index).raw, cuhr (CU_index).saw, cuhr (CU_index).pia,
		cuhr (CU_index).xde, cuhr (CU_index).xdo, cuhr (CU_index).ic, cuhr (CU_index).rpts);

	     call ioa_$ioa_switch_nnl (iocbp, "^[pai ^]^[pfa ^]^[inh ^]^[xint ^]^[pib ^]^[its ^]",
		cuhr (CU_index).pai, cuhr (CU_index).pfa, cuhr (CU_index).inhib,
		cuhr (CU_index).xint, cuhr (CU_index).pib,
		(^OP.DUOP (fixed (OP_cur, 10)+1) & cuhr (CU_index).its_flag));

	     call ioa_$ioa_switch_nnl (iocbp, "^[port ^]^[internal ^]^[cache flush ^]",
		cuhr (CU_index).portf, cuhr (CU_index).internal, cuhr (CU_index).cache_flush);


	     if substr (ext_hr.DU_OU.odd (CU_index), 19, 18) ^= "0"b then do;
		call ioa_$ioa_switch_nnl (iocbp, "^/OU ^[^12.3b ^12.3b^;^2s^4t^]^41x",
		     lo_sw, ext_hr.DU_OU.even (CU_index), ext_hr.DU_OU.odd (CU_index));
		call ioa_$ioa_switch_nnl (iocbp, "RS-REG=^a ^[dtrgo ^]",
		   ltrim (rtrim (OP.code (fixed (du_ouhr (CU_index).rs || "0"b, 10) +1))),
		   du_ouhr (CU_index).dtrgo, du_ouhr (CU_index).dtrgo);

		if ou_regs (CU_index).ou_inds ^= "0"b then do;
		     call ioa_$ioa_switch_nnl (iocbp, "^[zero ^]^[sign ^]^[carry ^]^[ovfl ^]^[eovfl ^]^[eufl ^]^[oflm ^]^[hex ^]",
			du_ouhr (CU_index).ir_reg.zero_, du_ouhr (CU_index).ir_reg.sign_, du_ouhr (CU_index).ir_reg.carry_,
			du_ouhr (CU_index).ir_reg.ovfl_, du_ouhr (CU_index).ir_reg.eovfl_, du_ouhr (CU_index).ir_reg.eufl_,
			du_ouhr (CU_index).ir_reg.oflm_, du_ouhr (CU_index).ir_reg.hex_);
		end;
	     end;

	     if cuhr.op_code (CU_index) = XED then XED_flag = "1"b;
	     if cuhr.op_code (CU_index) = XEC then XEC_flag = "1"b;

	     if cuhr.pfa (CU_index) then return;

	     if (cuhr.pia (CU_index) & ^(apuhr1.piapgbsy (AU_index) | apuhr1.piaoosb (AU_index))) then
		go to display_du;


	     if au_synched = "1"b then
		if ext_hr.AU1.even (AU_index) ^= "0"b then do;
display_apu:	     call aur;
		     AU_index = AU_index +1;
		     if au_cycle_done = "1"b then
			go to display_du;
		     goto display_apu;		/* keep going till APU cycle finished */
		end;

display_du:
	     if OP.DUOP (fixed (OP_cur, 10)+1) & ^cuhr.pia (CU_index) then
		call dur;
	     return;
	end;

aur:	proc;

	     if AU_index > a_nregs then go to AU_DONE;
	     if ext_hr.AU1.even (AU_index) = "0"b then return;
	     SDW_print = " ";
	     au_cycle_done = "0"b;

	     if substr (ext_hr.AU1.even (AU_index), 16, 10) = "0"b then
		go to AU_DONE;			/* not an APU cycle */

	     if cuhr.op_code (CU_index) ^= apuhr2.opcode (AU_index) then
		go to AU_DONE;
	     if (cuhr.tag (CU_index) = "03"b3 | cuhr.tag (CU_index) = "07"b3) |
	     (apuhr2.TAG (AU_index) = "03"b3 | apuhr2.TAG (AU_index) = "07"b3) then do;
AU_DONE:		au_cycle_done = "1"b;
		return;
	     end;

	     if apuhr1.fap (AU_index) = "1"b | apuhr1.fanp (AU_index) = "1"b then
		au_cycle_done = "1"b;


	     if apuhr1.sdwmf (AU_index) then do;
		call ioa_$rsnnl ("^1a", temp_char1, 1,
		     LEVEL (fixed (apuhr1.sdwlvl (AU_index), 2)));
		call ioa_$rsnnl ("^2o", temp_char2, 2,
		     fixed (substr (apuhr1.esn (AU_index), 12, 4), 4));
		SDW_print = ltrim (rtrim (temp_char1)) || ltrim (rtrim (temp_char2));
	     end;


	     PTW_print = " ";

	     if apuhr1.ptwmf (AU_index) then do;
		call ioa_$rsnnl ("^1a", temp_char1, 1,
		     LEVEL (fixed (apuhr1.ptwlvl (AU_index), 2)));
		call ioa_$rsnnl ("^2o", temp_char2, 2,
		     fixed (apuhr1.ptwaddr (AU_index), 4));
		PTW_print = ltrim (rtrim (temp_char1)) || ltrim (rtrim (temp_char2));
	     end;

	     if apuhr2.opcode (AU_index) = "0"b then do;	/* ^trust au2 so.. */
		pr_auop = "0"b;
		pr_autag = "0"b;
		au2 = "0"b;
		go to no_au2;
	     end;



	     pr_auop = "1"b;			/* assume display of opcode */
	     AUOP = apuhr2.opcode (AU_index);
	     AUOP_PR = rtrim (OP.code (fixed (AUOP, 10)+1));
	     foo = length (AUOP_PR);			/* do same thing as we did for CU */
	     foo = 5 -foo;
	     OP_pad = PAD (foo);
	     AUOP_PR = OP_pad || AUOP_PR;
	     if AUOP_PR = OP_print then
		pr_auop = "0"b;


	     pr_autag = "1"b;
	     AUTAG = fixed (apuhr2.TAG (AU_index), 10)+1;
	     AUTAG_PR = rtrim (TAG.code (AUTAG));
	     foo = length (AUTAG_PR);
	     foo = 3 - foo;
	     TAG_pad = PAD (foo);
	     AUTAG_PR = TAG_pad || AUTAG_PR;
	     if AUTAG_PR = TAG_print then
		pr_autag = "0"b;


	     call ioa_$rsnnl ("^6o", tpr_ca, 6,
		fixed (apuhr2.CA (AU_index), 18));
	     TPR_CA_PR = "[" || ltrim (rtrim (tpr_ca)) || "]";
	     foo = length (TPR_CA_PR);
	     foo = 8 - foo;
	     OP_pad = PAD (foo);
	     TPR_CA_PR = OP_pad || TPR_CA_PR;
	     au2 = "1"b;



no_au2:
	     ausegno = fixed (apuhr1.esn (AU_index), 15);
	     if ausegno = cusegno then
		AUSEG_pr = "0"b;
	     else AUSEG_pr = "1"b;

	     call ioa_$ioa_switch_nnl (iocbp, "^/AU ^[^12.3b ^12.3b^;^2s^5t^]^[^5o^;^s^5x^] ^[^8a^;^s^8x^]  ^[^5a^;^s^5x^] ^[^3a^;^s^3x^]^3x^8o r^1o ",
		lo_sw, ext_hr.AU1.even (AU_index), ext_hr.AU1.odd (AU_index),
		AUSEG_pr, ausegno,
		au2, TPR_CA_PR,
		pr_auop, AUOP_PR,
		pr_autag, AUTAG_PR,
		fixed (apuhr1.finadd (AU_index), 25),
		fixed (apuhr1.trr (AU_index), 3));

	     call ioa_$ioa_switch_nnl (iocbp, "^[fdsptw ^]^[mdsptw ^]^[fsdw ^]^[fptw ^]^[fptw2 ^]^[mptw ^]",
		apuhr1 (AU_index).fdsptw, apuhr1 (AU_index).mdsptw, apuhr1 (AU_index).fsdwp,
		apuhr1 (AU_index).fptw, apuhr1 (AU_index).fptw2, apuhr1 (AU_index).mptw);
	     call ioa_$ioa_switch_nnl (iocbp, "^[fanp ^]^[fap ^]^[sdwm (^a) ^]^[ptwm (^a) ^]^[flt ^]^[flthld ^]^[cache ^]",
		apuhr1 (AU_index).fanp, apuhr1 (AU_index).fap, apuhr1 (AU_index).sdwmf, ltrim (rtrim (SDW_print)),
		apuhr1 (AU_index).ptwmf, ltrim (rtrim (PTW_print)), apuhr1 (AU_index).flt, apuhr1 (AU_index).flthld, apuhr1 (AU_index).cache_used);
	     call ioa_$ioa_switch_nnl (iocbp, "^[piapgbsy ^]^[piaoosb ^]^[*SDWAM-ERR* ^]^[*PTWAM-ERR* ^]",
		apuhr1 (AU_index).piapgbsy, apuhr1 (AU_index).piaoosb, apuhr1 (AU_index).sdwerr, apuhr1 (AU_index).ptwerr);

	     if au_cycle_done = "1"b then
	        if apuhr1.finadd (AU_index) ^= cuhr.ca_value (CU_index) then do;
						/* allow for ind cycles */
		 if substr (apuhr1.finadd (AU_index), 16, 9) =
		    substr (cuhr.ca_value (CU_index), 16, 9) then
		    if cuhr.its_flag (CU_index) then return;
		 if substr (apuhr1.finadd (AU_index), 16, 9) = 
		    substr (cuhr.ca_value (CU_index -1), 16, 9) then
		    return;
		 if substr (apuhr1.finadd (AU_index), 16, 9) = 
		    substr (cuhr.ca_value (CU_index -2), 16, 9) then
		    return;
		    call ioa_$ioa_switch_nnl (iocbp, "^/*****Final Address Mismatch CU <=> AU: CU = ^8o :: AU = ^8o*****",
		    cuhr.ca_value (CU_index), apuhr1.finadd (AU_index));
		 end;
	        return;
	        end;

dur:	proc;

	     if ext_hr.DU_OU.even (CU_index) = "0"b
	     then return;				/* no DU entry */

	     if du_ouhr.du_word (CU_index) then DU_mode = "w";
	     else if du_ouhr.nine (CU_index) then DU_mode = "9";
	     else if du_ouhr.six (CU_index) then DU_mode = "6";
	     else if du_ouhr.four (CU_index) then DU_mode = "4";
	     else if du_ouhr.du_bit (CU_index) then DU_mode = "b";
	     else DU_mode = "?";


	     call ioa_$ioa_switch_nnl (iocbp, "^/DU ^[^12.3b ^12.3b^;^2s^4t^]^37x ^1a ",
		lo_sw, ext_hr.DU_OU.even (CU_index), ext_hr.DU_OU.odd (CU_index),
		DU_mode);

	     call ioa_$ioa_switch_nnl (iocbp, "^[d1a ^]^[d2a ^]^[anstr ^]^[lrw1 ^]^[lrw2 ^]",
		^du_ouhr (CU_index).fanld1, ^du_ouhr (CU_index).fanld2, ^du_ouhr (CU_index).fanstr,
		^du_ouhr (CU_index).fldwrt1, ^du_ouhr (CU_index).fldwrt2);

	     call ioa_$ioa_switch_nnl (iocbp, "^[d1n ^]^[d2n ^]^[ndsqflg ^]^[dud ^]^[gstr ^]",
		^du_ouhr (CU_index).fnld1, ^du_ouhr (CU_index).fnld2, du_ouhr (CU_index).endseqf,
		^du_ouhr.fdud (CU_index), ^du_ouhr.fgstr (CU_index));

	     call ioa_$ioa_switch_nnl (iocbp, "^[ndseq ^]^[sp1 ^]^[sp2 ^]^[sp3 ^]^[pop ^]^[addgC ^]",
		^du_ouhr (CU_index).endseq, du_ouhr (CU_index).ptr1, du_ouhr (CU_index).ptr2, du_ouhr (CU_index).ptr3,
		du_ouhr (CU_index).fpop, ^du_ouhr (CU_index).fgeac);

	     call ioa_$ioa_switch_nnl (iocbp, "^[addgE ^]^[addgF ^]^[addgH ^]^[ldptr1 ^]^[swdseq ^]",
		^du_ouhr (CU_index).fgeae, ^du_ouhr (CU_index).fgeaf,
		^du_ouhr (CU_index).fgeah, ^du_ouhr (CU_index).fgldp1,
		^du_ouhr (CU_index).fsweq);

	     call ioa_$ioa_switch_nnl (iocbp, "^[chrcyc ^]^[dfirst ^]^[exh ^]^[addcyc ^]^[intrptd ^]",
		^du_ouhr (CU_index).fgch, du_ouhr (CU_index).dfrst, du_ouhr (CU_index).exh,
		^du_ouhr (CU_index).fgadd, du_ouhr (CU_index).intrptd);

	     call ioa_$ioa_switch_nnl (iocbp, "^[ldptr2 ^]^[gemC ^]^[btdgA ^]^[shftgt ^]",
		^du_ouhr (CU_index).dcode.gldp2, du_ouhr (CU_index).dcode.gemc,
		du_ouhr (CU_index).dcode.gbda, du_ouhr (CU_index).dcode.gsp5);

	end;					/* end dur */

%page;
no_thread: entry (hr_data_ptr, a_iocbp, nregs, switches);

	code = 0;
	call setup;
	if code ^= 0 then
	     return;

	if do_du then do_ou = "1"b;

	if ^expand_sw then do;
	     if (do_cu | do_ou) then do;
		call ioa_$ioa_switch (iocbp, "^/^[CU-FLAGS  OPCODE  ADDRESS  PT^]^[  ^]^[     DU REGS     OU-IC  RS IND^]^[    OU-IC^]",
		     do_cu, ^do_cu, do_ou, ^do_ou);

		do i = nregs to 1 by - 1;
		     call ioa_$ioa_switch (iocbp, "^2d ^[^6.3b ^6.3b ^8.3b ^4.3b^;^4s^]^[^2x^6.3b^;^s^]^[  ^12.3b ^6.3b ^3.3b ^3.3b^]",
			i, do_cu, cu_regs (i).cu_flags, cu_regs (i).cu_op,
			cu_regs (i).cu_addr, cu_regs (i).cu_pt_flags,
			^do_ou, ou_regs (i).ou_ic,
			do_ou, ou_regs (i).du_regs, ou_regs (i).ou_ic,
			ou_regs (i).ou_rs, ou_regs (i).ou_inds);
		end;
	     end;

	     if do_au then do;
		call ioa_$ioa_switch (iocbp, "^/^3x^10tAPU#1 REGISTERS^40tAPU#2 REGISTERS");
		do i = nregs to 1 by -1;
		     call ioa_$ioa_switch (iocbp, "^2d ^5.3b ^4.3b ^3.3b ^.1b ^8.3b ^.3b ^3.3b^7x^6.3b ^6.3b",
			i, ap1_segno (i), ap1_flags1 (i), "0"b || ap1_flags2 (i), ap1_flt (i),
			ap1_finadd (i), ap1_trr (i), ap1_flags3 (i), ap2_ca (i), ap2_op (i));
		end;
	     end;
	     return;
	end;

	if expand_sw then do;
	     if do_cu then do;
		call ioa_$ioa_switch_nnl (iocbp, "^2/EXPANDED CU REGS^/^5tOU-IC^11tOP-CODE^23tADDRESS PC  FLAGS");
		do i = nregs to 1 by -1;
		     call ioa_$ioa_switch_nnl (iocbp, "^/^2d ^6o^10t^10a^22t^8o ^2o  ",
			i, fixed (du_ouhr.ict (i), 18),
			ltrim (rtrim (OP.code (fixed (cuhr.op_code (i), 10) +1)) ||
			" " || ltrim (rtrim (TAG.code (fixed (cuhr.tag (i), 10) +1)))),
			fixed (cuhr.ca_value (i), 24),
			2 * fixed (cuhr.pcmd (i), 3));

		     call ioa_$ioa_switch_nnl (iocbp, "^[pia ^]^[poa ^]^[riw ^]^[siw ^]^[pot ^]^[pon ^]",
			cuhr (i).pia, cuhr (i).poa, cuhr (i).riw,
			cuhr (i).siw, cuhr (i).pot, cuhr (i).pon);

		     call ioa_$ioa_switch_nnl (iocbp, "^[raw ^]^[saw ^]^[inf ^]^[xde ^]^[xdo ^]^[ic ^]^[rpts ^]",
			cuhr (i).raw, cuhr (i).saw, cuhr (i).pia,
			cuhr (i).xde, cuhr (i).xdo, cuhr (i).ic, cuhr (i).rpts);

		     call ioa_$ioa_switch_nnl (iocbp, "^[pai ^]^[pfa ^]^[inh ^]^[xint ^]^[pib ^]^[its ^]",
			cuhr (i).pai, cuhr (i).pfa, cuhr (i).inhib,
			cuhr (i).xint, cuhr (i).pib,
			(substr (cuhr (i).op_code, 10, 1) = "0"b & cuhr (i).its_flag));

		     call ioa_$ioa_switch_nnl (iocbp, "^[port ^]^[internal ^]^[cache flush ^]",
			cuhr (i).portf, cuhr (i).internal, cuhr (i).cache_flush);
		end;
	     end;

	     if do_au then do;
		call ioa_$ioa_switch_nnl (iocbp, "^2/EXPANDED APU REGS^/   SEGNO OFFSET INSTR    FINAL ADDR  FLAGS");

		do i = nregs to 1 by -1;
		     SDW_print = " ";
		     if apuhr1.sdwmf (i) then do;
			call ioa_$rsnnl ("^1a", temp_char1, 1,
			     LEVEL (fixed (apuhr1.sdwlvl (i), 2)));
			call ioa_$rsnnl ("^2o", temp_char2, 2,
			     fixed (substr (apuhr1.esn (i), 12, 4), 4));
			SDW_print = ltrim (rtrim (temp_char1)) || ltrim (rtrim (temp_char2));
		     end;


		     PTW_print = " ";

		     if apuhr1.ptwmf (i) then do;
			call ioa_$rsnnl ("^1a", temp_char1, 1,
			     LEVEL (fixed (apuhr1.ptwlvl (i), 2)));
			call ioa_$rsnnl ("^2o", temp_char2, 2,
			     fixed (apuhr1.ptwaddr (i), 4));
			PTW_print = ltrim (rtrim (temp_char1)) || ltrim (rtrim (temp_char2));
		     end;


		     call ioa_$ioa_switch_nnl (iocbp, "^/^2d ^5.3b ^6o ^10a ^8o  ",
			i, apuhr1.esn (i), apuhr2.CA (i),

			ltrim (rtrim (OP.code (fixed (apuhr2.opcode (i), 10) +1)) ||
			" " || ltrim (rtrim (TAG.code (fixed (apuhr2.TAG (i), 10) +1)))),
			fixed (apuhr1.finadd (i), 24));

		     call ioa_$ioa_switch_nnl (iocbp, "^[fdsptw ^]^[mdsptw ^]^[fsdw ^]^[fptw ^]^[fptw2 ^]^[mptw ^]",
			apuhr1 (i).fdsptw, apuhr1 (i).mdsptw, apuhr1 (i).fsdwp,
			apuhr1 (i).fptw, apuhr1 (i).fptw2, apuhr1 (i).mptw);
		     call ioa_$ioa_switch_nnl (iocbp, "^[fanp ^]^[fap ^]^[sdwm (^a) ^]^[ptwm (^a) ^]^[flt ^]^[flthld ^]^[cache ^]",
			apuhr1 (i).fanp, apuhr1 (i).fap, apuhr1 (i).sdwmf, ltrim (rtrim (SDW_print)),
			apuhr1 (i).ptwmf, ltrim (rtrim (PTW_print)), apuhr1 (i).flt, apuhr1 (i).flthld, apuhr1 (i).cache_used);
		     call ioa_$ioa_switch_nnl (iocbp, "^[piapgbsy ^]^[piaoosb ^]^[*SDWAM-ERR* ^]^[*PTWAM-ERR* ^]",
			apuhr1 (i).piapgbsy, apuhr1 (i).piaoosb, apuhr1 (i).sdwerr, apuhr1 (i).ptwerr);

		end;
	     end;


	     if do_ou then do;
		call ioa_$ioa_switch_nnl (iocbp, "^2/EXPANDED DU/OU REGS^/^5tOU-IC RS-REG ^15tDU/OU-INDS");
		do i = nregs to 1 by -1;
		     call ioa_$ioa_switch_nnl (iocbp, "^/^2d ^6o^10t^a^18t^[zero ^]^[sign ^]^[carry ^]^[ovfl ^]^[eovfl ^]^[eufl ^]^[oflm ^]^[hex ^]^[dtrgo ^]",
			i, fixed (du_ouhr.ict (i), 18),
		        ltrim (rtrim (OP.code (fixed (du_ouhr (i).rs || "0"b, 10) +1))),
			du_ouhr (i).ir_reg.zero_, du_ouhr (i).ir_reg.sign_,
			du_ouhr (i).ir_reg.carry_, du_ouhr (i).ir_reg.ovfl_,
			du_ouhr (i).ir_reg.eovfl_, du_ouhr (i).ir_reg.eufl_,
			du_ouhr (i).ir_reg.oflm_, du_ouhr (i).ir_reg.hex_,
			du_ouhr (i).dtrgo);

		     if substr (cuhr.op_code (i), 10, 1) & ^cuhr.pia (i) then do;
			if du_ouhr.du_word (CU_index) then DU_mode = "w";
			else if du_ouhr.nine (CU_index) then DU_mode = "9";
			else if du_ouhr.six (CU_index) then DU_mode = "6";
			else if du_ouhr.four (CU_index) then DU_mode = "4";
			else if du_ouhr.du_bit (CU_index) then DU_mode = "b";
			else DU_mode = "?";

			call ioa_$ioa_switch_nnl (iocbp, "^[d1a ^]^[d2a ^]^[anstr ^]^[lrw1 ^]^[lrw2 ^]",
			     ^du_ouhr (CU_index).fanld1, ^du_ouhr (CU_index).fanld2, ^du_ouhr (CU_index).fanstr,
			     ^du_ouhr (CU_index).fldwrt1, ^du_ouhr (CU_index).fldwrt2);

			call ioa_$ioa_switch_nnl (iocbp, "^[d1n ^]^[d2n ^]^[ndsqflg ^]^[dud ^]^[gstr ^]",
			     ^du_ouhr (CU_index).fnld1, ^du_ouhr (CU_index).fnld2, du_ouhr (CU_index).endseqf,
			     ^du_ouhr.fdud (CU_index), ^du_ouhr.fgstr (CU_index));

			call ioa_$ioa_switch_nnl (iocbp, "^[ndseq ^]^[sp1 ^]^[sp2 ^]^[sp3 ^]^[pop ^]^[addgC ^]",
			     ^du_ouhr (CU_index).endseq, du_ouhr (CU_index).ptr1, du_ouhr (CU_index).ptr2, du_ouhr (CU_index).ptr3,
			     du_ouhr (CU_index).fpop, ^du_ouhr (CU_index).fgeac);

			call ioa_$ioa_switch_nnl (iocbp, "^[addgE ^]^[addgF ^]^[addgH ^]^[ldptr1 ^]^[swdseq ^]",
			     ^du_ouhr (CU_index).fgeae, ^du_ouhr (CU_index).fgeaf,
			     ^du_ouhr (CU_index).fgeah, ^du_ouhr (CU_index).fgldp1,
			     ^du_ouhr (CU_index).fsweq);

			call ioa_$ioa_switch_nnl (iocbp, "^[chrcyc ^]^[dfirst ^]^[exh ^]^[addcyc ^]^[intrptd ^]",
			     ^du_ouhr (CU_index).fgch, du_ouhr (CU_index).dfrst, du_ouhr (CU_index).exh,
			     ^du_ouhr (CU_index).fgadd, du_ouhr (CU_index).intrptd);

			call ioa_$ioa_switch_nnl (iocbp, "^[ldptr2 ^]^[gemC ^]^[btdgA ^]^[shftgt ^]",
			     ^du_ouhr (CU_index).dcode.gldp2, du_ouhr (CU_index).dcode.gemc,
			     du_ouhr (CU_index).dcode.gbda, du_ouhr (CU_index).dcode.gsp5);

		     end;


		end;
	     end;


	end;
	return;


%page;
setup:	proc;



/* ***********************************************************
   *   check iocbp and long switch, set control accordingly   *
   *********************************************************** */


	     if a_iocbp = null then			/* called to use default io switch */
		iocbp = iox_$user_output;
	     else iocbp = a_iocbp;


	     if hr_data_ptr = null then do;		/* check validity of ptr */
		call ioa_$ioa_switch (iocbp, "^/History Register Pointer is Null");
		code = -1;
		return;				/* must be a bad call */
	     end;

	     a_nregs = nregs;

	     if a_nregs = 64 then do;			/* set up proper offsets to hr data */
		cu_offset = 128;
		au_offset2 = 256;
		au_offset1 = 384;
	     end;


	     du_ouhrp = addrel (hr_data_ptr, du_ou_offset); /* set pointer to Ops Unit data */
	     cuhrp = addrel (hr_data_ptr, cu_offset);	/* set pointer to Control Unit data */
	     aphrp2 = addrel (hr_data_ptr, au_offset2);	/* set pointer to DU data */
	     aphrp1 = addrel (hr_data_ptr, au_offset1);	/* set pointer to App Unit data */
	     OP_ptr = addr (OP_table);		/* set pointer to opcode table */
	     TAG_ptr = addr (TAG_table);		/* set pointer to tag table */



/* ***********************************************************************
   *   If history registers were not saved, fim will zero the block out. *
   *   So we need to see if the block is valid by checking for zeroes.   *
   *********************************************************************** */

	     if hr_data_ptr -> hr_block = "0"b then do;
		call ioa_$ioa_switch (iocbp, "^/History Register Buffer is Empty");
		code = -1;
		return;
	     end;

	     return;
	end setup;


%page;
/* This subroutine is used to get the AU hregs in synch with the CU hregs */

synch_auhr: proc;


	     do AU_index = 1 to a_nregs while (au_synched = "0"b);
		if apuhr2.opcode (AU_index) = cuhr.op_code (CU_index) then
		     if apuhr1.finadd (AU_index) = cuhr.ca_value (CU_index) then
			if ext_hr.AU1.even (AU_index) ^= "0"b then
			     if (apuhr2.TAG (AU_index) ^= "03"b3 | apuhr2.TAG (AU_index) ^= "07"b3) then
				au_synched = "1"b;
	     end;

	     if au_synched = "0"b then
		AU_index = a_nregs +1;

	     else AU_index = AU_index -1;
	     return;
	end synch_auhr;
%page;
%include history_regs_dps8;
%page;
%include opcode_tag_table;


     end hran_dps8_;




		    hran_l68_.pl1                   11/10/82  1713.3rew 11/10/82  1316.0      324018



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


/*  Coded by Rich Coppola August 1980, for DPS8 support of history registers.
   *  This routine was taken, essentially intact, from the old hranl_.  */

hran_l68_: proc;

	return;					/* do not enter here */



/* PARAMETERS */

dcl  a_iocbp ptr;
dcl  lo_sw bit (1);
dcl  switches bit (5);				/* tell what to print and how */
						/* must be in this order */
						/* expand_sw, ou, cu, au, du */

/* EXTERNAL DATA */

dcl  ioa_ entry options (variable),
     ioa_$ioa_switch options (variable),
     ioa_$ioa_switch_nnl entry options (variable),
     ioa_$rsnnl entry options (variable),
     iox_$user_output ptr ext;			/* default io switch */


dcl 1 a_switches based (addr (switches)),
    (2 expand_sw bit (1),
    2 do_ou bit (1),
    2 do_cu bit (1),
    2 do_au bit (1),
    2 do_du bit (1)) unal;

dcl 1 OU_ (16) based (ouhrp),
    2 even bit (36),
    2 odd bit (36);

dcl 1 CU_ (16) based (cuhrp),
    2 even bit (36),
    2 odd bit (36);

dcl 1 DU_ (16) based (duhrp),
    2 even bit (36),
    2 odd bit (36);

dcl 1 AU_ (16) based (aphrp),
    2 even bit (36),
    2 odd bit (36);


/* AUTOMATIC STORAGE */

dcl  AU_index fixed,				/* AU data index */
     AU_ptr ptr,					/* pointer to AU data */
     AU_synch fixed,				/* AU index for synch */
     CU_index fixed,				/* index into CU data */
     CU_ptr ptr,					/* pointer to CU data */
     CU_synch fixed,				/* index value at which CU & OU synchronize */
     CY_print char (1),				/* cycle type for output */
     DU_index fixed,				/* DU entry index */
     DU_mode char (1),				/* DU execution mode symbol */
     EXP_DU_mode char (4),
     DU_ptr ptr,					/* pointer to DU data */
     IC_cur fixed (18) init (0),			/* current IC value for CU entries */
     IC_flag bit (1),				/* IC print control flag */
     IC_next fixed (18) init (0),			/* next =C value for CU lines */
     IC_print char (7),				/* printed IC value */
     IC_synch fixed (18),				/* IC tracker value at synchronization */
     IC_value fixed (18),				/* IC value for output */
     NOP_flag bit (1) init ("0"b),			/* flag for NOP cycles */
     OP_cur bit (10) init ((10)"0"b),			/* current opcode for CU lines */
     OP_print char (5),				/* opcode string for printing */
     OU_ptr ptr,					/* pointer to OU data */
     OU_index fixed bin,				/* index into OU data */
     OU_synch fixed init (0),				/* index value at which OU & CU synchronize */
     PTW_print char (2),				/* PTWAMR number for printing */
     SDW_print char (2),				/* SDWAMR number for printing */
     SEG_print char (5),				/* segment number for printing */
     TAG_cur fixed,					/* current TAG table index */
     TAG_print char (4),				/* TAG string for printing */
     XD1_flag bit (1) init ("0"b),			/* flag for 1st of XED pair  */
     XD2_flag bit (1) init ("0"b),			/* flag for 2nd of XED pair */
     XEC_flag bit (1) init ("0"b),			/* XEC flag */
     XED_flag bit (1) init ("0"b),			/* XED flag */
     count_diff fixed,				/* repeat/repull count difference */
     null builtin,
     iocbp ptr,					/* output switch name */
     fetch_count fixed init (0),			/* fetch cycle count */
     lo fixed,					/* long output sw, 1 => long output 2 => short output */
     index fixed,					/* general loop index */
     pull_count fixed init (0),			/* index into instruction pull table */
     pull_index fixed;				/* index into instruction pull table */

dcl (i, j) fixed bin;
dcl  (a_do_du, a_do_cu) bit (1);
dcl 1 hr,						/* copy of HR data (corrected) */
    2 OU (16),
      3 even bit (36),
      3 odd bit (36),
    2 CU (16),
      3 even bit (36),
      3 odd bit (36),
    2 DU (16),
      3 even bit (36),
      3 odd bit (36),
    2 AU (16),
      3 even bit (36),
      3 odd bit (36);

dcl 1 a_ouhra (16) like ouhra;			/* auto storage for OU hregs */
dcl 1 a_cuhra (16) like cuhra;			/* auto storage for CU hregs */
dcl 1 a_duhra (16) like duhra;			/* auto storage for DU hregs */
dcl 1 a_apuhra (16) like apuhra;			/* auto storage for  AU hregs */


dcl 1 pull_table (16),				/* instruction pull table */
    2 index fixed unal init ((16)0),
    2 pt_addr bit (18) unal init ((16) (18)"0"b);

dcl  repeat_count fixed init (0),			/* OU instruction repeat count */
     repull_count fixed,				/* instruction repull count for loop checking */
     synch_flag bit (1),				/* synchronization flag */
     tag_chain_flag bit (1);				/* tag print control flag  */
dcl  hr_block bit (36*128) based;			/* #of bits in the hr data block */
dcl  code fixed bin (35);
dcl  from_bos bit (1) init ("0"b);


%page;
hranl_l68_bos: entry (hr_data_ptr, a_iocbp, lo_sw);

	from_bos = "1"b;
	go to START;

hranl_l68_: entry (hr_data_ptr, a_iocbp, lo_sw);

	from_bos = "0"b;

START:
	code = 0;
	call setup;
	if code ^= 0 then return;


/* History regs are valid, print heading and initialize */

	call ioa_$ioa_switch (iocbp, "L68 History Register Analysis");
	call ioa_$ioa_switch (iocbp, "^/ HR^[^5-^;^24x^]c", lo);

	call ioa_$ioa_switch_nnl (iocbp,
	     "id##^[^8xhr contents^-^;^3x^]IC_____ opcd__ tag_ y seg#_ offset__ mc flags^/", lo);


/* Copy the data.  There are cases where the data is inconsistent because of hardware timing
   delays and these inconsistencies must be removed before analysis can be done. */

	OU = OU_;					/* copy the entire structure */
	CU = CU_;
	DU = DU_;
	AU = AU_;

	a_ouhra = ouhra;				/* and do it again */
	a_cuhra = cuhra;
	a_duhra = duhra;
	a_apuhra = apuhra;


/* Fix up repeated values of IC Tracker. These occur because of differences
   in timing between the OU, which strobes the data, and the CU, which controls the value */




	do OU_index = 2 to 16;			/* from 2nd to last */
						/* if IC Tracker value is the same, then ... */
	     if a_ouhra.ict (OU_index) = a_ouhra.ict (OU_index-1) then
						/* if all flags are _n_o_t the same, then ...
						   (If IC Tracker _a_n_d all flags are the same,
						   the OU is in multi-cycle or is repeating) */
		if hr.OU.even (OU_index) ^= hr.OU.even (OU_index-1) then
						/* and if the op is _n_o_t LREG or SREG ... */
		     if a_ouhra.rp (OU_index) ^= LREG & a_ouhra.rp (OU_index) ^= SREG then
						/* add one to IC Tracker value */
			a_ouhra.ict (OU_index) = bit (add (fixed (a_ouhra.ict (OU_index)), 1, 17, 0), 18);
	end;

/* Construct an instruction pull table containing the CU_index and addr
   for all true instruction pulls . Also count all fetch cycles (including
   descriptor fetches and dummy fetches */

	do CU_index = 1 to 16;			/* look at all CU entries */
						/* if the instruction fetch flag in port
						   data is set, then ... */
	     if a_cuhra.ins_fetch (CU_index) then do;
		fetch_count = fetch_count+1;		/* count a fetch cycle */
						/* if the CU is preparing an instruction
						   address _o_r taking a transfer ... */
		if (a_cuhra.pia (CU_index) | a_cuhra.trgo (CU_index))
						/* _a_n_d this is not the fault cycle ... */
		& a_cuhra.nflt (CU_index) then do;
		     pull_table.index (pull_count+1) = CU_index; /* save CU_index and ... */
						/* computed address */
		     pull_table.pt_addr (pull_count+1) = a_cuhra.ca_value (CU_index);
		     pull_count = pull_count+1;	/* count an instruction pull */
		end;
	     end;
	end;

/* Test instruction pull count. If zero, then ...

   Hypothesis 1 ---

   The CU will execute 16 (or more) cycles without an instruction pull only if one of the
   following conditions obtain ...

   1)	A long EIS instruction is being executed,
   2)	There is a very long indirect chain,
   3)	The CU is in repeat mode.


   Under this hypothesis, there may be at most four instructions appearing in the CU history
   register with the fault occuring in the last one.  The last instruction pull has been overwritten
   and the fault occurs before or during the next pull.  Thus all instructions appearing are in
   strictly sequential order and the IC Tracker value in OU17 (fault OU) is the value for CU17. */

	if pull_count = 0 then do;



	     IC_synch = fixed (a_ouhra.ict (16));	/* set IC synch point to last value */
	     OU_synch = 16;				/* set OU synch index value */

HRG01C:	     do CU_synch = 16 to 2 by -1;		/* search CU entries backwards */
						/* for the fault opcode */
		if a_cuhra.op_code (CU_synch) = a_ouhra.rp (16) then
						/* found it if OU-load or OU-store are set */
		     if a_cuhra.oul (CU_synch) | a_cuhra.ous (CU_synch) then goto HRG05C;
	     end;
	     goto HRG05C;				/* if no match, must look further */
	end;

/* Pull count is non-zero.  Find the first instruction pulled */

	pull_table.index (pull_count+1) = 16;		/* add fault cycle for table control */
	do pull_index = 1 to pull_count;		/* using all pull table entries */
	     do CU_index = pull_table.index (pull_index) to 16; /* scan all CU entries */
		IC_synch = fixed (pull_table.pt_addr (pull_index), 18); /* tentative IC synch */
		if ^a_cuhra.nflt (CU_index) then goto HRG02F; /* if this the fault cycle, the CU
						   failed to complete the instruction pair
						   during which it pulled the next pair. */
		if OP.TR (fixed (a_cuhra.op_code (CU_index))+1) & a_cuhra.trgo (CU_index) then do;
						/* if this is a transfer taken, then ... */
		     CU_synch = CU_index+1;		/* next CU entry is the one */
		     goto HRG05C;
		end;
						/* if IC is odd, then the next even instruction
						   is from this pull */
		if a_cuhra.ic (CU_index) then do CU_synch = CU_index to 16;
		     if ^a_cuhra.ic (CU_synch) then goto HRG05C;
		end;
	     end;					/* loop on CU_index values */
HRG02A:	end;					/* loop on pull_index */


/* Hypothesis 2 ---

   The CU will fail to complete the current instruction pair ( or fail to reach the even instruction) if ...

   1)	The instruction pull is the last (or only) pull _a_n_d one of the condition of Hypothesis 1
   	applies during the execution of the current pair _a_n_d the CU faults on the instruction pull.

   or 2)	The instruction pull is the only pull and is a "look ahead" pull _a_n_d execution of the
   	current pair leads to one of the conditions of Hypothesis 1.

   or 3)	The processor is in a lock-up loop.

   The conditions for this hypothesis are the same as those to Hypothesis 1 with the
   exception of the single instruction pull allowed. The same procedure may be used. */

HRG02F:	goto HRG01C;

/* Check for a program loop by counting repulls of this instruction pair */

HRG05C:	CU_index = CU_synch;			/* save current CU_synch value */
						/* if the opcode is LREG or SREG, then ... */
	if a_cuhra.op_code (CU_index) = SREG | a_cuhra.op_code (CU_index) = LREG then do
		CU_synch = CU_index to 16 while	/* search for last CU entry with opcode */
		(a_cuhra.op_code (CU_synch) = a_cuhra.op_code (CU_index));
	end;

	if CU_synch = 1 then goto HRG06;		/* if this is the 1st CU entry ... */

	if OP.OUOP (fixed (a_cuhra.op_code (CU_synch))) then /* if this is an OU OP ... */
	     do CU_index = CU_synch-1 to 1 by -1;	/* search CU entries backwards for oldest
						   entry matching this OU entry */
	     if CU_index > 1 then do;			/* if this is _n_o_t the 1st CU entry ... */
						/* and the opcode is the same as the
						   prior entry ... */
		if a_cuhra.op_code (CU_index) = a_cuhra.op_code (CU_synch) then
						/* and it is not lreg or sreg ... */
		     if a_cuhra.op_code (CU_index) ^= LREG & a_cuhra.op_code (CU_index) ^= SREG
						/* and the repeat flag is not set ... */
		     & ^a_cuhra.rpts (CU_index)
						/* or _n_o_t preparing instruction address, _n_o_t
						   fetching or storing and indirect word, and _n_o_t pulling
						   an instruction */
		     | (^a_cuhra.pia (CU_index) & ^a_cuhra.riw (CU_index)
		     & ^a_cuhra.siw (CU_index) & ^a_cuhra.wi (CU_index)) then
			CU_synch = CU_index;
	     end;
	end;
	goto HRG06;

/* Hypothesis 5 ---

   Because the CU is "busier" than the OU, the OU will always contain at least as many occurences
   of an OU instruction as the CU.  However, during "back-to-back" store operations, the IC Tracker
   may fall behand by a count. Most of these cases have already been covered by the ICT scan loop
   at HRG01F but the case of the double store  will be covered here. */

HRG05H:	if OU_synch = 0 then OU_synch = 16;
	do OU_index = 2 to 16;			/* inspect all entries */
	     if a_ouhra.rp (OU_index) ^= LREG & a_ouhra.rp (OU_index) ^= SREG then
		if a_ouhra.ict (OU_index) = a_ouhra.ict (OU_index-1) then do;
		     a_ouhra.ict (OU_index) = bit (add (fixed (a_ouhra.ict (OU_index)), 1, 35, 0), 18);
		     if fixed (a_ouhra.ict (OU_index)) = IC_synch then goto HRG05C;
		end;
	end;

/* Output CU entries up to CU_synch */

HRG06:	IC_value = 0;				/* initialize IC value for printout */
	synch_flag = "0"b;				/* reset synch flag */
	tag_chain_flag, IC_flag = "0"b;		/* reset control flags */
	DU_index = fetch_count+1;			/* initialize DU entry index */
	AU_index = 0;				/* turn off AU lines */
	do AU_synch = 1 to 16 while			/* synch AU to IC_synch */
		((mod (fixed (a_apuhra.finadd (AU_synch)), 1024) ^= mod (IC_synch, 1024)) &
		(hr.AU.even (AU_synch) ^= "0"b));
	end;
	do CU_index = 1 to CU_synch-1;
	     if hr.CU.even (CU_index) ^= "0"b then
		call cur;
	end;

/* Merge CU & OU entries up to fault cycle */

HRG08:	IC_value = IC_synch;
	IC_flag = "1"b;
	OU_index = 0;
	synch_flag = "1"b;
	if CU_index = 16 then goto HRG09;
	do CU_index = CU_index to 15;
	     if ^a_cuhra.nflt (CU_index) then
		go to do_fault_cycle;
	     call cur;
	     if OP.OUOP (fixed (OP_cur)+1) & (a_cuhra.oul (CU_index) | a_cuhra.ous (CU_index))
	     & ^a_cuhra.saw (CU_index) then do;
		if OU_synch = 0 then do OU_synch = 1 to 16 while
			(fixed (a_ouhra.ict (OU_synch), 18) ^= IC_value);
		end;
		if OU_synch = 17 then		/* no synch found */
		     OU_synch = 0;			/* reset for next time */
		else if OU_index = 0 then OU_index = OU_synch; /* setup new found synch */
		if OU_index > 0 & OU_index < 16 then do; /* within range */
		     call our;
		     OU_index = OU_index + 1;
		end;
	     end;
	end;

/* Do the fault cycles */
do_fault_cycle:


HRG09:
	call cur;

	call ioa_$ioa_switch (iocbp, "^/");
	return;

our:	proc;

	     if ^synch_flag then do;
		call ioa_$rsnnl ("^7o", IC_print, 7, fixed (a_ouhra.ict (OU_index)));
		IC_value = fixed (a_ouhra.ict (OU_index));
	     end;
	     else IC_print = " ";

	     if ^synch_flag then OP_print = OP.code (2*fixed (a_ouhra.rp (OU_index))+1);
	     else OP_print = " ";
	     call ioa_$ioa_switch_nnl (iocbp, "^/OU^2o^[ ^12.3b ^12.3b^;^2s^3x^]^7a ^6a^26x", OU_index, lo,
		hr.OU.even (OU_index), hr.OU.odd (OU_index), IC_print, OP_print);
	     if a_ouhra.dir (OU_index) then
		if substr (a_cuhra.tag (OU_index), 1, 1) then call ioa_$ioa_switch_nnl (iocbp, "dl ");
		else call ioa_$ioa_switch_nnl (iocbp, "du ");
	     call ioa_$ioa_switch_nnl (iocbp, "^[rb ^]^[rp ^]^[rs ^]^[in ^]^[os ^]",
		a_ouhra.opbf (OU_index), a_ouhra.frpf (OU_index),
		a_ouhra.srf (OU_index), a_ouhra.gin (OU_index),
		a_ouhra.gos (OU_index));

	     call ioa_$ioa_switch_nnl (iocbp, "^[d1 ^]^[d2 ^]^[oe ^]^[oa ^]^[om ^]^[on ^]",
		a_ouhra.gd1 (OU_index), a_ouhra.gd2 (OU_index),
		a_ouhra.goe (OU_index), a_ouhra.goa (OU_index),
		a_ouhra.gom (OU_index), a_ouhra.gon (OU_index));

	     call ioa_$ioa_switch_nnl (iocbp, "^[of ^]^[sd ^]^[-d ^]^[ar ^]^[qr ^]^[x0 ^]",
		a_ouhra.gof (OU_index), a_ouhra.fstr (OU_index),
		a_ouhra.dn (OU_index), ^a_ouhra.an (OU_index),
		^a_ouhra.qn (OU_index), ^a_ouhra.x0n (OU_index));

	     call ioa_$ioa_switch_nnl (iocbp, "^[x1 ^]^[x2 ^]^[x3 ^]^[x4 ^]^[x5 ^]^[x6 ^]^[x7^]",
		^a_ouhra.x1n (OU_index), ^a_ouhra.x2n (OU_index),
		^a_ouhra.x3n (OU_index), ^a_ouhra.x4n (OU_index),
		^a_ouhra.x5n (OU_index), ^a_ouhra.x6n (OU_index),
		^a_ouhra.x7n (OU_index));
	     return;
	end;

cur:	proc;


/* Determine if IC value is to be displayed */

	     if IC_cur ^= IC_value then goto cur02;	/* if it has changed since last CU line ... */
						/* or if we are repeating _o_r XEC'ing ... */
	     if a_cuhra.rpts (CU_index) | XEC_flag then goto cur03;

cur02:	     if a_cuhra.op_code (CU_index) ^= OP_cur then /* if opcode has changed */
		if IC_next ^= 0 then do;
		     IC_value = IC_next;
		     IC_flag = "1"b;
		     IC_next = 0;
		end;
		else if IC_flag then IC_value = IC_value+1;

	     IC_print = " ";			/* reset IC print value */
	     if XED_flag then do;			/* if  XEDing ... */

		if ^XD1_flag then do;		/* if 1st of XED pair not been done ... */
		     XD1_flag = "1"b;		/* we are about to do it */
		     goto cur03;
		end;

		if ^XD2_flag then do;		/* if 2nd of XED pair has not been done ... */
		     if a_cuhra.op_code (CU_index) ^= OP_cur then
			XD2_flag = "1"b;		/* we are about to do it */
		     goto cur03;
		end;

		if a_cuhra.op_code (CU_index) ^= OP_cur then
		     XED_flag, XD1_flag, XD2_flag = "0"b; /* XED finished, reset all flags */
	     end;

	     if IC_flag then do;
		if a_cuhra.ic (CU_index) then		/* force to odd if ic flag is set */
		     IC_value = 2* divide (IC_value, 2, 18, 0)+1;
		else IC_value = 2* divide (IC_value, 2, 18, 0); /* else force even */
		if IC_cur ^= IC_value then		/* if it changed ... */
		     call ioa_$rsnnl ("^7o", IC_print, 7, IC_value);
		else IC_print = " ";
		IC_cur = IC_value;
	     end;

cur03:	     if a_cuhra.op_code (CU_index) = OP_cur & IC_print = " " then
						/* if neither IC nor opcode have changed ... */
		OP_print = "  """;			/* this must be the same instruction */
	     else do;
		OP_cur = a_cuhra.op_code (CU_index);
		OP_print = OP.code (fixed (OP_cur)+1);
	     end;

cur04:	     if OP.DUOP (fixed (a_cuhra.op_code (CU_index))+1) /* if a decimal op ... */
	     | a_cuhra.op_code (CU_index) = STCA	/* or STCA ... */
	     | a_cuhra.op_code (CU_index) = STCQ	/* or STCQ ... */
	     | a_cuhra.op_code (CU_index) = STBA	/* or STBA ... */
	     | a_cuhra.op_code (CU_index) = STBQ	/* or STBQ ... */
	     | a_cuhra.rpts (CU_index)		/* or its a repeat */
	     then do;				/* print a blank TAG */
		TAG_cur = 0;
		TAG_print = " ";
	     end;
	     else do;
		TAG_cur = fixed (a_cuhra.tag (CU_index))+1;
		TAG_print = TAG.code (TAG_cur);
	     end;

	     if TAG_cur > 0 then			/* if its a true tag ... */
		tag_chain_flag = TAG.chain (TAG_cur);	/* set tag chain flag */

	     if ^a_cuhra.nflt (CU_index) then CY_print = "F";
	     else if ^a_cuhra.nxip (CU_index) then CY_print = "x";
	     else if a_cuhra.ins_fetch (CU_index)
	     & (a_cuhra.pia (CU_index) | a_cuhra.wi (CU_index)) then do;
		CY_print = "i";
		if a_cuhra.op_code (CU_index) ^= XED then
		     IC_next = fixed (a_cuhra.ca_value (CU_index));
		XED_flag, XD1_flag, XD2_flag = "0"b;	/* reset XED flags for transfer */
	     end;
	     else if a_cuhra.riw (CU_index) | a_cuhra.siw (CU_index) then CY_print = "n";
	     else if a_cuhra.cul (CU_index) then
		if a_cuhra.dir (CU_index) then CY_print = "d";
		else CY_print = "o";
	     else if a_cuhra.ous (CU_index) then CY_print = "o";
	     else if OP.DUOP (fixed (OP_cur)+1) then CY_print = "e";
	     else if OP_cur = NOP
	     | (OP.TR (fixed (OP_cur)+1) & ^a_cuhra.trgo (CU_index)) then do;
		CY_print = "*";
		NOP_flag = "1"b;
	     end;
	     else if a_cuhra.oul (CU_index) | a_cuhra.ous (CU_index) then
		if a_cuhra.dir (CU_index) then CY_print = "d";
		else CY_print = "o";
	     else CY_print = "?";
	     if AU_index = 0 & a_cuhra.ca_value (CU_index) = pull_table.pt_addr (1) then AU_index = AU_synch;

	     if 0<AU_index & AU_index<17 then
		call ioa_$rsnnl ("^5o", SEG_print, 5, fixed (a_apuhra.esn (AU_index)));
	     else SEG_print = " ";

	     call ioa_$ioa_switch_nnl (iocbp, "^/CU^2o^[ ^12.3b ^12.3b^;^2s^3x^]^7a ^6a ^4a ^1a ^5a ^8o ^2o ",
		CU_index, lo, hr.CU.even (CU_index), hr.CU.odd (CU_index), IC_print, OP_print, TAG_print,
		CY_print, SEG_print, fixed (a_cuhra.ca_value (CU_index), 18), 2* fixed (a_cuhra.pcmd (CU_index), 3));

	     call ioa_$ioa_switch_nnl (iocbp, "^[pi ^]^[pa ^]^[ri ^]^[si ^]^[pt ^]^[pn ^]",
		a_cuhra.pia (CU_index), a_cuhra.poa (CU_index),
		a_cuhra.riw (CU_index), a_cuhra.siw (CU_index),
		a_cuhra.pot (CU_index), a_cuhra.pon (CU_index));

	     call ioa_$ioa_switch_nnl (iocbp, "^[ra ^]^[sa ^]^[tr ^]^[xe ^]^[xo ^]^[ic ^]",
		a_cuhra.raw (CU_index), a_cuhra.saw (CU_index),
		a_cuhra.trgo (CU_index), a_cuhra.xde (CU_index),
		a_cuhra.xdo (CU_index), a_cuhra.ic (CU_index));

	     call ioa_$ioa_switch_nnl (iocbp, "^[rp ^]^[wi ^]^[-y ^]^[fa ^]^[xa ^]^[br ^]",
		a_cuhra.rpts (CU_index), a_cuhra.wi (CU_index),
		^a_cuhra.ar (CU_index), ^a_cuhra.nflt (CU_index),
		^a_cuhra.nxip (CU_index), ^a_cuhra.np (CU_index));

	     call ioa_$ioa_switch_nnl (iocbp, "^[in ^]^[it ^]^[xi ^]^[cs ^]^[os ^]^[cl ^]^[ol ^]^[dr ^]^[pl ^]^[pb^]",
		a_cuhra.inhib (CU_index),
		^OP.DUOP (fixed (OP_cur)+1) & a_cuhra.its_flag (CU_index),
		a_cuhra.xint (CU_index), a_cuhra.ous (CU_index),
		a_cuhra.ous (CU_index), a_cuhra.cul (CU_index),
		a_cuhra.oul (CU_index), a_cuhra.dir (CU_index),
		a_cuhra.npcb (CU_index), a_cuhra.pib (CU_index));

	     if a_cuhra.op_code (CU_index) = XED then XED_flag = "1"b;

	     if AU_index = 17 then do AU_index = 1 to 16 while /* try to synch the AU */
		     ((mod (fixed (a_apuhra.finadd (AU_index)), 1024) ^= mod (fixed (a_cuhra.ca_value (CU_index)), 1024)) &
		     (^a_ouhra.dir (OU_index)));
	     end;

	     if 0 < AU_index & AU_index < 17		/* & a_cuhra.ar (CU_index) */
	     then do;
cur05:		call aur;
		AU_index = AU_index+1;
		if ^a_cuhra.dir (CU_index) then
		     if ^(a_apuhra.fap (AU_index-1) | a_apuhra.fanp (AU_index-1) | a_apuhra.flt (AU_index-1))
		     then goto cur05;
	     end;

	     if ^OP.DUOP (fixed (OP_cur)+1) & ^a_cuhra.ins_fetch (CU_index) then DU_index = DU_index+1;

	     if OP.DUOP (fixed (OP_cur)+1) & ^a_cuhra.ins_fetch (CU_index) then do;
		call dur;
		DU_index = DU_index+1;
	     end;
	     return;
	end;

aur:	proc;

	     if hr.AU.even (AU_index) = "0"b |
	     ^a_cuhra.nflt (CU_index) then return;	/* no AU entry */

	     if a_apuhra.sdwmf (AU_index) then call ioa_$rsnnl ("^2o", SDW_print, 2, fixed (a_apuhra.sdwamr (AU_index), 4));
	     else SDW_print = " ";
	     if a_apuhra.ptwmf (AU_index) then call ioa_$rsnnl ("^2o", PTW_print, 2, fixed (a_apuhra.ptwamr (AU_index), 4));
	     else PTW_print = " ";

	     call ioa_$ioa_switch_nnl (iocbp, "^/AU^2o^[ ^12.3b ^12.3b^2-  ^;^2s^25x^]^2a ^2a ^8o  ^1o ",
		AU_index, lo, hr.AU.even (AU_index), hr.AU.odd (AU_index), SDW_print, PTW_print,
		fixed (a_apuhra.finadd (AU_index), 25), fixed (a_apuhra.trr (AU_index)));

	     call ioa_$ioa_switch_nnl (iocbp, "^[fd ^]^[md ^]^[fs ^]^[p1 ^]^[p2 ^]^[mp ^]",
		a_apuhra.fdsptw (AU_index), a_apuhra.mdsptw (AU_index),
		a_apuhra.dfsdw (AU_index), a_apuhra.fptw (AU_index),
		a_apuhra.fptw2 (AU_index), a_apuhra.mptw (AU_index));

	     call ioa_$ioa_switch_nnl (iocbp, "^[an ^]^[ap ^]^[sm ^]^[pm ^]^[f ^]^[fh^]",
		a_apuhra.fanp (AU_index), a_apuhra.fap (AU_index),
		a_apuhra.sdwmf (AU_index), a_apuhra.ptwmf (AU_index),
		a_apuhra.flt (AU_index), a_apuhra.flthld (AU_index));
	     return;
	end;

dur:	proc;

	     if hr.DU.even (DU_index) = "0"b then return; /* no DU entry */

	     if ^a_duhra.du_wrd (DU_index) then DU_mode = "w";
	     else if ^a_duhra.nine (DU_index) then DU_mode = "9";
	     else if ^a_duhra.six (DU_index) then DU_mode = "6";
	     else if ^a_duhra.four (DU_index) then DU_mode = "4";
	     else if ^a_duhra.one (DU_index) then DU_mode = "b";
	     else DU_mode = "?";

	     call ioa_$ioa_switch_nnl (iocbp, "^/DU^2o^[ ^12.3b ^12.3b^3-     ^;^2s^38x^]^1o  ^1a ",
		DU_index, lo, hr.DU.even (DU_index), hr.DU.odd (DU_index),
		3-fixed (a_duhra.ptra (DU_index), 3), DU_mode);

	     call ioa_$ioa_switch_nnl (iocbp, "^[pl ^]^[pp ^]^[nd ^]^[sa ^]^[ld ^]^[fp ^]^[xm ^]",
		^a_duhra.pol (DU_index), ^a_duhra.pop (DU_index),
		^a_duhra.ndesc (DU_index), ^a_duhra.seladr (DU_index),
		^a_duhra.dlendr (DU_index), ^a_duhra.dfrst (DU_index),
		^a_duhra.exr (DU_index));

	     call ioa_$ioa_switch_nnl (iocbp, "^[lf ^]^[dl ^]^[ds ^]^[re ^]^[lv ^]^[lx ^]^[es ^]^[en ^]^[rw ^]",
		^a_duhra.ldfrst (DU_index), ^a_duhra.dulea (DU_index),
		^a_duhra.dusea (DU_index), ^a_duhra.redo (DU_index),
		^a_duhra.wcws (DU_index), ^a_duhra.exh (DU_index),
		a_duhra.eseq (DU_index), ^a_duhra.einst (DU_index),
		^a_duhra.durw (DU_index));

	     call ioa_$ioa_switch_nnl (iocbp, "^[d1 ^]^[d2 ^]^[d3 ^]^[ei ^]^[fl ^]^[al ^]^[di ^]^[c0 ^]",
		a_duhra.fai1 (DU_index), a_duhra.fai2 (DU_index),
		a_duhra.fai3 (DU_index), a_duhra.samplint (DU_index),
		^a_duhra.sfcsq (DU_index), ^a_duhra.adjlen (DU_index),
		^a_duhra.mif (DU_index), ^a_duhra.inhibstc1 (DU_index));

	     call ioa_$ioa_switch_nnl (iocbp, "^[dd ^]^[l1 ^]^[l2 ^]^[l3 ^]^[1a ^]^[n1 ^]^[n2 ^]^[a1 ^]",
		a_duhra.duidl (DU_index), ^a_duhra.dcldgta (DU_index),
		^a_duhra.dcldgtb (DU_index), ^a_duhra.dcldgtc (DU_index),
		a_duhra.nopl1 (DU_index), a_duhra.nopgl1 (DU_index),
		a_duhra.nopl2 (DU_index), a_duhra.nopgl2 (DU_index),
		a_duhra.aoplg1 (DU_index));

	     call ioa_$ioa_switch_nnl (iocbp, "^[a2 ^]^[r1 ^]^[r2 ^]^[da ^]^[rl ^]^[ns ^]^[as ^]^[op ^]",
		a_duhra.aoplg2 (DU_index), a_duhra.lrwrg1 (DU_index),
		a_duhra.lrwrg2 (DU_index), ^a_duhra.dataav_du (DU_index),
		a_duhra.rw1rl (DU_index), a_duhra.numstg (DU_index),
		a_duhra.anstg (DU_index), a_duhra.opav (DU_index));

	     call ioa_$ioa_switch_nnl (iocbp, "^[fs ^]^[l< ^]^[cg ^]^[pc ^]^[mp ^]^[bg ^]^[bd ^]",
		^a_duhra.endseq_du (DU_index), ^a_duhra.len128 (DU_index),
		a_duhra.charop (DU_index), a_duhra.anpk (DU_index),
		a_duhra.exmop (DU_index), a_duhra.blnk (DU_index),
		a_duhra.bde (DU_index));

	     call ioa_$ioa_switch_nnl (iocbp, "^[db ^]^[sg ^]^[ff ^]^[rf ^]^[+g ^]^[*g ^]^[xg^]",
		a_duhra.dbe (DU_index), a_duhra.shft (DU_index),
		a_duhra.flt (DU_index), a_duhra.rnd (DU_index),
		a_duhra.addsub (DU_index), a_duhra.multdiv (DU_index),
		a_duhra.expon (DU_index));
	     return;
	end;
%page;
bos_no_thread: entry (hr_data_ptr, a_iocbp, switches);
	from_bos = "1"b;
	go to START_NO_THREAD;

no_thread: entry (hr_data_ptr, a_iocbp, switches);

	from_bos = "0"b;

START_NO_THREAD:

	code = 0;
	call setup;
	if code ^= 0 then return;			/* no regs to play with */

	if expand_sw = "0"b then do;			/* just print octal */
	     if (do_ou | do_cu) then do;
		call ioa_$ioa_switch (iocbp, "^10t^[OU REGISTERS^33t^]^[CU REGISTERS^]",
		     do_ou, do_cu);
		do i = 16 to 1 by -1;
		     call ioa_$ioa_switch (iocbp, "^2d ^[^12.3b ^12.3b^;^2s^]^[  ^12.3b ^12.3b^]",
			i, do_ou, OU_.even (i), OU_.odd (i), do_cu, CU_.even (i), CU_.odd (i));
		end;
	     end;

	     if (do_du | do_au) then do;
		call ioa_$ioa_switch (iocbp, "^/^10t^[DU REGISTERS^33t^]^[AU REGISTERS^]",
		     do_du, do_au);
		do i = 16 to 1 by -1;
		     call ioa_$ioa_switch (iocbp, "^2d ^[^12.3b ^12.3b^;^2s^]^[  ^12.3b ^12.3b^]",
			i, do_du, DU_.even (i), DU_.odd (i), do_cu, AU_.even (i), AU_.odd (i));
		end;
	     end;
	end;

	else if expand_sw = "1"b then do;
	      a_do_cu = do_cu;
	      a_do_du = do_du;
	      if do_cu then a_do_du = "1"b;
	      if do_du then a_do_cu = "1"b;
	     if do_ou then do;
		call ioa_$ioa_switch_nnl (iocbp, "^/EXPANDED OU REGS^/^5tOU-IC^14tRP  RS   FLAGS");
		do i = 16 to 1 by -1;
		     call ioa_$ioa_switch_nnl (iocbp, "^/^2d ^6.3b ^3.3b^.b^.3b ^3.3b   ^[cmod ^]^[direct ^]^[EAC=^.3b ^]",
			i, ouhra.ict (i), ouhra.nopc (i), ouhra.itw (i), ouhra.ntg (i),
			ouhra.rp (i), ouhra.cmod (i), ouhra.dir (i), ouhra.efad (i) ^= "00"b,
			"0"b || ouhra.efad (i));

		     call ioa_$ioa_switch_nnl (iocbp, "^[rb ^]^[rp ^]^[rs ^]^[in ^]^[os ^]",
			a_ouhra.opbf (OU_index), a_ouhra.frpf (OU_index),
			a_ouhra.srf (OU_index), a_ouhra.gin (OU_index),
			a_ouhra.gos (OU_index));

		     call ioa_$ioa_switch_nnl (iocbp, "^[d1 ^]^[d2 ^]^[oe ^]^[oa ^]^[om ^]^[on ^]",
			a_ouhra.gd1 (OU_index), a_ouhra.gd2 (OU_index),
			a_ouhra.goe (OU_index), a_ouhra.goa (OU_index),
			a_ouhra.gom (OU_index), a_ouhra.gon (OU_index));

		     call ioa_$ioa_switch_nnl (iocbp, "^[of ^]^[sd ^]^[-d ^]^[ar ^]^[qr ^]^[x0 ^]",
			a_ouhra.gof (OU_index), a_ouhra.fstr (OU_index),
			a_ouhra.dn (OU_index), ^a_ouhra.an (OU_index),
			^a_ouhra.qn (OU_index), ^a_ouhra.x0n (OU_index));

		     call ioa_$ioa_switch_nnl (iocbp, "^[x1 ^]^[x2 ^]^[x3 ^]^[x4 ^]^[x5 ^]^[x6 ^]^[x7^]",
			^a_ouhra.x1n (OU_index), ^a_ouhra.x2n (OU_index),
			^a_ouhra.x3n (OU_index), ^a_ouhra.x4n (OU_index),
			^a_ouhra.x5n (OU_index), ^a_ouhra.x6n (OU_index),
			^a_ouhra.x7n (OU_index));
		end;
		call ioa_$ioa_switch (iocbp, "^/");
	     end;					/* end do_ou */
	     if a_do_cu then do;
		call ioa_$ioa_switch_nnl (iocbp, "^/EXPANDED CU REGS^/^5tOPCODE-TAG CU-ADDR PTCMD PTSEL  FLAGS");
		do i = 16 to 1 by -1;
		     call ioa_$ioa_switch_nnl (iocbp, "^/^2d   ^10a ^6o    ^2.3b     ^[A^]^[B^]^[C^]^[D^]^[?^]  ",
			i, ltrim (rtrim (OP.code (fixed (cuhra.op_code (i), 10) +1)) ||
			" " || ltrim (rtrim (TAG.code (fixed (cuhra.tag (i), 10) +1)))),
			cuhra.ca_value (i), cuhra.pcmd (i) || "0"b,
			cuhra.psl (i) = "1000"b, cuhra.psl (i) = "0100"b,
			cuhra.psl (i) = "0010"b, cuhra.psl (i) = "0001"b,
			cuhra.psl (i) = "0000"b);
		     call ioa_$ioa_switch_nnl (iocbp, "^[pi ^]^[pa ^]^[ri ^]^[si ^]^[pt ^]^[pn ^]",
			cuhra.pia (i), cuhra.poa (i),
			cuhra.riw (i), cuhra.siw (i),
			cuhra.pot (i), cuhra.pon (i));

		     call ioa_$ioa_switch_nnl (iocbp, "^[ra ^]^[sa ^]^[tr ^]^[xe ^]^[xo ^]^[ic ^]",
			cuhra.raw (i), cuhra.saw (i),
			cuhra.trgo (i), cuhra.xde (i),
			cuhra.xdo (i), cuhra.ic (i));

		     call ioa_$ioa_switch_nnl (iocbp, "^[rp ^]^[wi ^]^[-y ^]^[fa ^]^[xa ^]^[br ^]",
			cuhra.rpts (i), cuhra.wi (i),
			^cuhra.ar (i), ^cuhra.nflt (i),
			^cuhra.nxip (i), ^cuhra.np (i));

		     call ioa_$ioa_switch_nnl (iocbp, "^[in ^]^[it ^]^[xi ^]^[cs ^]^[os ^]^[cl ^]^[ol ^]^[dr ^]^[pl ^]^[pb^]",
			cuhra.inhib (i),
		        (substr (cuhra.op_code (i), 10, 1) = "0"b & cuhra.its_flag (i)),
			cuhra.xint (i), cuhra.ous (i),
			cuhra.ous (i), cuhra.cul (i),
			cuhra.oul (i), cuhra.dir (i),
			cuhra.npcb (i), cuhra.pib (i));


	if substr (cuhra.op_code (i), 10, 1) = "1"b then do;
	     if ^duhra.du_wrd (i) then EXP_DU_mode = "word";
	     else if ^duhra.nine (i) then EXP_DU_mode = "9bit";
	     else if ^duhra.six (i) then EXP_DU_mode = "6bit";
	     else if ^duhra.four (i) then EXP_DU_mode = "4bit";
	     else if ^duhra.one (i) then EXP_DU_mode = "1bit";
	     else EXP_DU_mode = "????";

	     call ioa_$ioa_switch_nnl (iocbp, " ^a ^[pl ^]^[pp ^]^[nd ^]^[sa ^]^[ld ^]^[fp ^]^[xm ^]",
	        i, EXP_DU_mode,
		^duhra.pol (i), ^duhra.pop (i),
		^duhra.ndesc (i), ^duhra.seladr (i),
		^duhra.dlendr (i), ^duhra.dfrst (i),
		^duhra.exr (i));

	     call ioa_$ioa_switch_nnl (iocbp, "^[lf ^]^[dl ^]^[ds ^]^[re ^]^[lv ^]^[lx ^]^[es ^]^[en ^]^[rw ^]",
		^duhra.ldfrst (i), ^duhra.dulea (i),
		^duhra.dusea (i), ^duhra.redo (i),
		^duhra.wcws (i), ^duhra.exh (i),
		duhra.eseq (i), ^duhra.einst (i),
		^duhra.durw (i));

	     call ioa_$ioa_switch_nnl (iocbp, "^[d1 ^]^[d2 ^]^[d3 ^]^[ei ^]^[fl ^]^[al ^]^[di ^]^[c0 ^]",
		duhra.fai1 (i), duhra.fai2 (i),
		duhra.fai3 (i), duhra.samplint (i),
		^duhra.sfcsq (i), ^duhra.adjlen (i),
		^duhra.mif (i), ^duhra.inhibstc1 (i));

	     call ioa_$ioa_switch_nnl (iocbp, "^[dd ^]^[l1 ^]^[l2 ^]^[l3 ^]^[1a ^]^[n1 ^]^[n2 ^]^[a1 ^]",
		duhra.duidl (i), ^duhra.dcldgta (i),
		^duhra.dcldgtb (i), ^duhra.dcldgtc (i),
		duhra.nopl1 (i), duhra.nopgl1 (i),
		duhra.nopl2 (i), duhra.nopgl2 (i),
		duhra.aoplg1 (i));

	     call ioa_$ioa_switch_nnl (iocbp, "^[a2 ^]^[r1 ^]^[r2 ^]^[da ^]^[rl ^]^[ns ^]^[as ^]^[op ^]",
		duhra.aoplg2 (i), duhra.lrwrg1 (i),
		duhra.lrwrg2 (i), ^duhra.dataav_du (i),
		duhra.rw1rl (i), duhra.numstg (i),
		duhra.anstg (i), duhra.opav (i));

	     call ioa_$ioa_switch_nnl (iocbp, "^[fs ^]^[l< ^]^[cg ^]^[pc ^]^[mp ^]^[bg ^]^[bd ^]",
		^duhra.endseq_du (i), ^duhra.len128 (i),
		duhra.charop (i), duhra.anpk (i),
		duhra.exmop (i), duhra.blnk (i),
		duhra.bde (i));

	     call ioa_$ioa_switch_nnl (iocbp, "^[db ^]^[sg ^]^[ff ^]^[rf ^]^[+g ^]^[*g ^]^[xg^]",
		duhra.dbe (i), duhra.shft (i),
		duhra.flt (i), duhra.rnd (i),
		duhra.addsub (i), duhra.multdiv (i),
		duhra.expon (i));
		        end;

		end;
		call ioa_$ioa_switch (iocbp, "^/");
	     end;					/* end a_do_cu */
	     if do_au then do;
		call ioa_$ioa_switch_nnl (iocbp, "^/EXPANDED APU REGS^/^5tSEGNO ESN-SOURCE TRR  FIN-ADDR   FLAGS");
		do i = 16 to 1 by -1;
		     call ioa_$ioa_switch_nnl (iocbp, "^/^2d  ^5o    ^[ppr.psr^]^[prn.snr^]^[tpr.tsr^]^[???.???^]   ^.3b  ^8o   ",
			i, apuhra.esn (i), apuhra.bsy (i) = "00"b, apuhra.bsy (i) = "01"b,
			apuhra.bsy (i) = "10"b, apuhra.bsy (i) = "11"b, apuhra.trr (i), apuhra.finadd (i));


		     if apuhra.sdwmf (i) then call ioa_$rsnnl ("^2o", SDW_print, 2, fixed (apuhra.sdwamr (i), 4));
		     else SDW_print = " ";
		     if apuhra.ptwmf (i) then call ioa_$rsnnl ("^2o", PTW_print, 2, fixed (apuhra.ptwamr (i), 4));
		     else PTW_print = " ";

		     call ioa_$ioa_switch_nnl (iocbp, "^[fd ^]^[md ^]^[fs ^]^[p1 ^]^[p2 ^]^[mp ^]",
			apuhra.fdsptw (i), apuhra.mdsptw (i),
			apuhra.dfsdw (i), apuhra.fptw (i),
			apuhra.fptw2 (i), apuhra.mptw (i));

		     call ioa_$ioa_switch_nnl (iocbp, "^[an ^]^[ap ^]^[sm(^a) ^]^[pm(^a) ^]^[f ^]^[fh^]",
			apuhra.fanp (i), apuhra.fap (i),
			apuhra.sdwmf (i), ltrim (rtrim (SDW_print)),
			apuhra.ptwmf (i), ltrim (rtrim (PTW_print)),
			apuhra.flt (i), apuhra.flthld (i));
		end;
		call ioa_$ioa_switch (iocbp, "^/");
	     end;					/* end do_au */

	end;



%page;
setup:	proc;

/* *****************************************************************
   *   The layout of the hr buffer from bos includes empty blocks	*
   *   between each type of register to accomodate the DPS8's 64	*
   *   deep registers. Set up pointers and offsets to each type	*
   *   of register accordingly.                                       *
   ***************************************************************** */

	     if from_bos then do;
		cu_offset = 128;
		du_offset = 256;
		au_offset = 384;
	     end;

	     else do;
		ouhrp = addrel (hr_data_ptr, ou_offset); /* set pointer to Ops Unit data */
		cuhrp = addrel (hr_data_ptr, cu_offset); /* set pointer to Control Unit data */
		duhrp = addrel (hr_data_ptr, du_offset); /* set pointer to DU data */
		aphrp = addrel (hr_data_ptr, au_offset); /* set pointer to App Unit data */
	     end;


	     OP_ptr = addr (OP_table);		/* set pointer to opcode table */
	     TAG_ptr = addr (TAG_table);		/* set pointer to tag table */


/* ***********************************************************
   *   check iocbp and long switch, set control accordingly   *
   *********************************************************** */


	     if a_iocbp = null then			/* called to use default io switch */
		iocbp = iox_$user_output;
	     else iocbp = a_iocbp;

	     if lo_sw then				/* do we want octal history regs too */
		lo = 1;
	     else lo = 2;


	     if hr_data_ptr = null then do;		/* must be a bad call */
		call ioa_$ioa_switch (iocbp, "^/History Register pointer is Null");
		code = -1;
		return;
	     end;


/* ***********************************************************************
   *   If history registers wre not saved, fim will zero the block out.   *
   *   So we need to see if the block is valid by checking for zero.      *
   *********************************************************************** */

	     if hr_data_ptr -> hr_block = "0"b then do;
		call ioa_$ioa_switch (iocbp, "^/History Register Buffer is Empty");
		code = -1;
		return;
	     end;
	     return;
	end setup;

%page;
%include opcode_tag_table;
%page;
%include history_regs_l68;


     end hran_l68_;




		    namef_.pl1                      10/01/82  1523.5rew 10/01/82  1523.6      110340



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


namef_: proc (segptr, odsp) returns (char (*));

/* Modification History - namef_:
   Initially coded by J. A. Bush - Dec. 1975
   Modified April 6, 1981 by Rich Coppola to fix bug causing OOSBs.
*/

% include ol_dump_struc;

dcl  segptr ptr;					/* ptr to segment and offset in question */
dcl (segno, ling, k, i, j, mblen, dl) fixed bin;
dcl  bitcnt fixed bin (24);
dcl  code fixed bin (35);
dcl  offrel fixed bin (18);
dcl (genp, bmp, ptrtmp, sblkp, astep, nsdwp, nmp, areap) ptr;
dcl  namebuf char (168);
dcl  var_str char (ling) based (ptrtmp);
dcl  dirname char (168);
dcl (bndsw, tmr) bit (1);
dcl  key char (1);
dcl  ename char (32);
dcl  zerodivide condition;


dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24),
     fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$status_ entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl  get_system_free_area_ entry (ptr);
dcl  get_bound_seg_info_ entry (ptr, fixed bin (24), ptr, ptr, ptr, fixed bin (35));
dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  get_ast_name_ entry (ptr, ptr, ptr, char (*));
dcl  ring0_get_$name_given_slt entry (char (*), char (*), ptr, fixed bin (35), ptr, ptr);
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  ioa_$rsnnl entry options (variable);
dcl  ol_dump_util_$fnd_hcseg entry (char (32), ptr, fixed bin (24), ptr);
dcl 1 oi_area aligned like object_info;
dcl (null, length, addr, addrel, baseno, fixed, ptr, rel, substr, baseptr, hbound, rtrim, index, size, reverse) builtin;

dcl 1 branch aligned,				/* output structure from hcs_$status_ */
    2 type bit (2) unal,
    2 nnames fixed bin (15) unal,
    2 nrp bit (18) unal,
    2 dtm bit (36) unal,
    2 dtu bit (36) unal,
    2 mode bit (5) unal,
    2 pad bit (13) unal,
    2 rec fixed bin (17) unal;

dcl 1 dinfo int static,				/* level one directory assosciative memory */
    2 ndir fixed bin init (0),
    2 l1dir (30),
      3 lg_name char (32),
      3 sht_name char (4);

dcl  dnames (branch.nnames) char (32) aligned based (nmp);



/*  */
	bndsw = "0"b;				/* set sw to break out component names and relative offsets */
	go to common;
no_comp:	entry (segptr, odsp) returns (char (*));
	bndsw = "1"b;				/* set switch for no component breakout */
common:
	segno = fixed (baseno (segptr), 18);		/* Get segment number */
	offrel = fixed (rel (segptr), 18);		/* Get offset */
	mblen = 168;				/* preset return char length to 168 */
	if segno <= hcscnt then do;			/* if a hardcore segment */
	     call ring0_get_$name_given_slt (dirname, ename, baseptr (segno), code, sltptr, sltnp); /* get name */
	     if code ^= 0 then return ("not known");
	     if bndsw then return (ename);
	     if substr (ename, 1, 5) ^= "bound" then do;
		call ioa_$rsnnl ("^a|^o", ename, mblen, ename, fixed (rel (segptr)));
		return (ename);
	     end;
	     namebuf = ename;			/* copy for compatability */
	     go to inithc;				/* initiate hardcore seg from ldd */
	end;
	else do;					/* Non hardcore segment */
	     if segptr = null then return ("NULL POINTER"); /* if null ptr stop here */
	     if sstnp = null then return ("NO SSTNT");
	     nsdwp = addrel (dsegp, segno * 2);
	     astep = ptr (sstptr, fixed (nsdwp -> sdw.add, 24) - fixed (sstptr -> sst.ptwbase, 18)
		- sstptr -> sst.astsize);		/* Compute Astep */
	     namebuf = "";

	     on condition (zerodivide)
		namebuf = "CANNOT-COMPLETE-PATH";


	     call get_ast_name_ (astep, sstptr, sstnp, namebuf); /* Figure out the name */
	     revert condition (zerodivide);


	     if length (rtrim (namebuf)) > 1 then do;	/* special case the root */
		if index (namebuf, "CANNOT") ^= 0 | (index (reverse (namebuf), "!>") ^= 0 &
		substr (namebuf, 1, 16) ^= ">process_dir_dir") then
		     if (phcs_ok & kstptr ^= null) then /* if all this is true, go find name from kst */
			call kst_name (segno);	/* find the name from kst */
		if substr (namebuf, 1, 1) = ">" then do; /* convert level 1 directories to short form */
		     ename = "";			/* set ename to all blanks first */
		     i = index (substr (namebuf, 2), ">") - 1;
		     if i = 0 then
			ename = rtrim (substr (namebuf, 2));
		     else ename = substr (namebuf, 2, i);
		     tmr = "0"b;
		     if ndir ^= 0 then do;		/*  if  we have any dirs in ass mem. */
			do i = 1 to ndir while (^tmr);
			     if l1dir.lg_name (i) = ename then
				tmr = "1"b;
			end;
		     end;
		     if ^tmr then do;		/* did not find in assosiative memory */
			ndir = ndir + 1;		/* increment assosiative memory index */
			l1dir.lg_name (ndir) = ename; /* set in long name */
			l1dir.sht_name (ndir) = "";	/* initially set short name to blanks */
			call get_system_free_area_ (areap); /* get a place to store names */
			call hcs_$status_ (">", ename, 0, addr (branch), areap, code);
			if code ^= 0 then go to st_err; /* if we get error, forget it */
			if branch.nnames > 1 | branch.nrp ^= "0"b then do;
			     nmp = ptr (areap, branch.nrp); /*  form ptr to names */
			     if substr (ename, 1, 15) = "system_library_" then
				if substr (ename, 1, 16) ^= "system_library_1" then
				     key = substr (ename, 16, 1); /* get cmp key for system librarys */
				else key = substr (ename, 1, 1); /* use first letter of long name for others */
			     else key = substr (ename, 1, 1); /* use first letter of long name for others */
			     tmr = "0"b;		/* reset terminate condition */
			     do i = 1 to branch.nnames while (^tmr);
				if substr (dnames (i), 1, 1) = key then
				     if length (rtrim (dnames (i))) <= 4 then do; /* found name meetin criteria */
					l1dir.sht_name (ndir) = dnames (i);
					tmr = "1"b; /* set terminate condition */
				     end;
			     end;
			end;
st_err:
			i = ndir + 1;		/* set correct index */
		     end;
		     if l1dir.sht_name (i-1) ^= "" then do; /* if short name is present */
			dl = length (rtrim (l1dir.lg_name (i-1)));
			j = length (rtrim (l1dir.sht_name (i-1)));
			ling = (length (rtrim (namebuf)) - dl) + 1;
			substr (namebuf, 2, j) = substr (l1dir.sht_name (i-1), 1, j);
			substr (namebuf, j + 2) = substr (namebuf, dl + 2);
			substr (namebuf, j + ling + 5) = "";
		     end;
		end;
	     end;
	     if bndsw then return (namebuf);
	     call expand_path_ (addr (namebuf), length (namebuf), addr (dirname), addr (ename), code);
	     if substr (ename, 1, 5) ^= "bound" then do;
		call ioa_$rsnnl ("^a|^o", namebuf, mblen, namebuf, fixed (rel (segptr)));
		return (namebuf);
	     end;
	     if substr (dirname, 1, 4) = ">sl1" then do;	/* initiate hardcore segments from ldd for bind maps */
inithc:
		call ol_dump_util_$fnd_hcseg (ename, genp, bitcnt, odsp); /* search given dirs */
		if genp = null then return (namebuf);	/* cannot find in search dirs */
	     end;
	     else do;
		genp = null;			/* make sure ptr is null */
		call hcs_$initiate_count (dirname, ename, "", bitcnt, 0, genp, code);
		if genp = null then return (namebuf);
	     end;
	     oi_area.version_number = object_info_version_2;
	     call get_bound_seg_info_ (genp, bitcnt, addr (oi_area), bmp, sblkp, code);
	     if code ^= 0 then return (namebuf);
						/* We now have a ptr to the bind map */
	     do i = 1 to n_components;
		j = fixed (bindmap.component (i).text_start, 18);
		k = fixed (bindmap.component (i).text_lng, 18);
		if offrel >= j then
		     if offrel < j + k then do;	/* We found a match */
matchp:
			ptrtmp = addrel (sblkp, bindmap.component (i).name_ptr);
			ling = fixed (bindmap.component (i).name_lng, 18);
			call ioa_$rsnnl ("^a$^a|^o", namebuf, mblen, namebuf, var_str, offrel - j);
			go to trmnme;		/* Go term segment */
		     end;
		j = fixed (bindmap.component (i).stat_start, 18);
		k = fixed (bindmap.component (i).stat_lng, 18);
		if offrel >= j then
		     if offrel < j + k then go to matchp; /* We found a match */
		j = fixed (bindmap.component (i).symb_start, 18);
		k = fixed (bindmap.component (i).symb_lng, 18);
		if offrel >= j then
		     if offrel < j + k then go to matchp; /* We found a match */
	     end;

trmnme:
	     call hcs_$terminate_noname (genp, code);
	     return (namebuf);
	end;
						/*  */

/* kst_name - internal procedure to find name of segment in kst of dump, from live system */

kst_name:	proc (segn);

dcl  segn fixed bin;
dcl  seg_array (15) fixed bin;
dcl (rzdp, rzdsp) ptr;
dcl  ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35));
dcl  phcs_$initiate entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35));
dcl  phcs_$ring_0_peek entry (ptr, ptr, fixed bin);
dcl  phcs_$terminate_noname entry (ptr, fixed bin (35));
dcl (get_temp_segments_, release_temp_segments_) entry (char (*), (*) ptr, fixed bin (35));
dcl  q (1) ptr;
dcl 1 tsdw like sdw aligned;
dcl (dlen, level) fixed bin;

	     kstp = kstptr;				/* copy ptr for neater code */
	     if segn < kst.lowseg | segn > kst.highseg then
		return;				/* no point in using KST */


	     kstep = addr (kst.kst_entry (segn));	/* get requested entry */
	     tmr = "0"b;				/* reset termination flag */

/* find root kste first, working backwards and saving kst entry indices along the way */

	     do i = 1 to 15 while (^tmr);		/* go through 15 levels if neccessary */
		seg_array (i) = kste.segno;
		if kste.entryp = null then		/* we found the root kste */
		     tmr = "1"b;

		else do;
		     j = fixed (baseno (kste.entryp));
		     if j < kst.lowseg | j > kst.highseg then
			tmr = "1"b;		/* don't use KST */

		     else kstep = addr (kst.kst_entry (j));
		     if ^kste.dirsw then
			tmr = "1"b;		/* ANOMALY;
						   superior branches should be dirs */
		end;
	     end;


	     if ^tmr then return;			/* don't waste our time */
	     call ring0_get_$segptr ("", "dseg", rzdsp, code); /* get ptr to our dseg */
	     if code ^= 0 then return;		/* get out at slightest error */
	     call get_temp_segments_ ("namef_", q, code); /* get temp segment to store dir in */
	     if code ^= 0 then return;
	     dp = q (1);

/* no go from the root and form complete pathname of target entry */

	     level = 0;
	     dirname, ename = "";			/* start with null names */
	     do j = i-2 to 1 by -1;			/* now find name */
		level = level + 1;
		if dirname = "" then
		     call phcs_$initiate (">", ename, "", 0, 0, rzdp, code);
		else call phcs_$initiate (dirname, ename, "", 0, 0, rzdp, code);
		if rzdp = null then go to ret1;	/* if some problem, get out of here */
		call phcs_$ring_0_peek (rzdp, dp, 1);	/* cause seg fault */
ftsdw:
		call phcs_$ring_0_peek (addr (rzdsp -> sdwa (fixed (baseno (rzdp)))), addr (tsdw), 2);
		if ^tsdw.df then go to ftsdw;		/* we must be faulted */
		dlen = fixed (tsdw.bound, 15) * 16 + 16;
		call phcs_$ring_0_peek (rzdp, dp, dlen); /* copy dir seg out of ring 0 */
		kstep = addr (kst.kst_entry (seg_array (j)));
		tmr = "0"b;
		do ep = ptr (dp, dp -> dir.entryfrp) repeat ptr (dp, ep -> entry.efrp) while (dp ^= ep & ^tmr);
		     if ep -> entry.uid = kste.uid then do; /* found right one */
			tmr = "1"b;		/* set terminate cond */
			dirname = rtrim (dirname) || ">" || addr (entry.primary_name) -> names.name;
			call phcs_$terminate_noname (rzdp, code); /* terminate this ref */
		     end;
		end;
		if ^tmr then do;			/* didn't find name */
ret1:
		     if level > 1 then		/* if we have part of a path */
			if index (namebuf, "CANNOT") ^= 0 then /* and if ast_pathe  no good */
			     namebuf = rtrim (dirname) || ">" || "CANNOT-COMPLETE-PATH";
		     go to ret;
		end;
	     end;
	     namebuf = dirname;			/* copy pathname */

ret:
	     call release_temp_segments_ ("namef_", q, code);

	end kst_name;

/*  */

% include kst;
% include dir_header;
% include dir_entry;
% include dir_name;
% include bind_map;
% include object_info;
% include sdw;
% include sst;
     end namef_;




		    ol_dump.pl1                     11/10/82  1713.3rew 11/10/82  0916.7      362574



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


ol_dump: proc;

/* Modification history - ol_dump:
   Origially coded by Steve Webber - Date unknown
   Extensive Modification to allow more options by J. A. Bush - Dec. 1975
   Modified May 1976 by J. A. Bush for NSS compatibility
   New ast/pt command extensivly cribed from BSG's new pap command
   Extensively modified in Oct. 1976 by J. A. Bush to split up functions into
   several modules to form bound_ol_dump_.
   Modified June 1977 by J. A. Bush for "mc" function and to use new
   entry ring0_get_$definitions_given_slt to find hardcore definitions
   Modified Oct 1979 by J. A. Bush for new -pathname arg and to
   fix to work with ring_0 stack sharing
   Modified July, 1980 to add dumpdir option
   Modified April 1981 by Rich Coppola to add call to J. Bongiovanni's
   display_dump_events, and add erf? command.
   Modified June 1982 by Rich Coppola to always allow dbr to be set for proc 0
   or inzr.
   Modified August 1982 by E. N. Kittlitz to move core_map out of sst.
   Modified Oct 1982 by Rich Coppola to set boot dbr to first proc dumped
   so that support routines could make use of it.
   Modified Oct 1982 by Rich Coppola to set the proc table (dump_info) after
   'why' is called.
*/

% include ol_dump_struc;


/* External entry declarations */

dcl  gm_path_list$ ext;
dcl  error_table_$segknown fixed bin (35) ext static;
dcl  error_table_$incorrect_access fixed bin (35) ext static;
dcl  error_table_$moderr fixed bin (35) ext static;
dcl  error_table_$no_dir fixed bin (35) ext static;
dcl  error_table_$no_r_permission fixed bin (35) ext static;
dcl  error_table_$noentry fixed bin (35) ext static;
dcl  error_table_$noarg fixed bin (35) ext static;
dcl  error_table_$badopt fixed bin (35) ext static;
dcl  error_table_$inconsistent fixed bin (35) ext static;
dcl  absolute_pathname_ entry (char (*), char (*), fixed bin (35));
dcl  hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35));
dcl (ioa_, ioa_$nnl, ioa_$rsnnl, hcs_$star_, ioa_$ioa_switch_nnl, hcs_$get_max_length, com_err_) entry options (variable);
dcl  ring0_get_$segptr_given_slt entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35), ptr, ptr);
dcl  ring0_get_$definition_given_slt entry (ptr, char (*), char (*), fixed bin (18),
     fixed bin, fixed bin (35), ptr, ptr, ptr);
dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  get_dump_ptrs_$dump_dir entry (char (*), char (*) aligned, (0: 31) ptr, (0: 31) fixed bin,
     fixed bin, char (32) aligned);
dcl  copy_dump_seg_ entry (fixed bin, fixed bin, (0:31) ptr, (0:31) fixed bin, ptr, fixed bin);
dcl  date_time_ entry (fixed bin (71), char (*) aligned);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$cp entry (ptr, fixed bin, fixed bin (35));
dcl  get_system_free_area_ entry (ptr);
dcl  iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl (iox_$user_input, iox_$error_output) ptr ext;
dcl  find_condition_info_ entry (ptr, ptr, fixed bin (35));
dcl  continue_to_signal_ entry (fixed bin (35));
dcl  display_dump_events$display_dump_events_ entry (char (32), char (168), fixed bin, fixed bin (71), bit (1));
dcl (temp_pds_ptr, temp_prds_ptr, temp_kst_ptr) ptr;


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

dcl 1 cond_info aligned,
    2 mc_ptr ptr,
    2 version fixed bin,
    2 condition_name char (32) varying,
    2 info_ptr ptr,
    2 wc_ptr ptr,
    2 loc_ptr ptr,
    2 flags,
      3 crawlout bit (1) unaligned,
      3 mbz1 bit (35) unaligned,
    2 mbz2 bit (36) aligned,
    2 user_loc_ptr ptr,
    2 mbz4 bit (36) aligned;

dcl  condition_interpreter_ entry (ptr, ptr, fixed bin, fixed bin, ptr, char (*), ptr, ptr);
dcl  conversion condition;


/* ol_dump subroutine entry declarations */

dcl  display_dump_ entry (ptr);			/* Subroutine to display console dump */
dcl  display_ast_ entry (ptr);			/* Subroutine to display ast entry */
dcl  display_ast_$absadr entry (ptr);
dcl  display_process_$apt entry (ptr);			/* Subroutine to display APT entry */
dcl  display_process_$tcq entry (ptr, ptr);		/* Subroutine to display the traffic controller queue */
dcl  display_process_$fdi entry (ptr, ptr);
dcl  display_stack_ entry (ptr);			/* Subroutine to display/trace stacks */
dcl  display_segment_$dseg entry (ptr);			/* Subroutine to display descriptor seg */
dcl  display_regs_$hregs entry (ptr);			/* Subroutine to display history regs */
dcl  display_segment_$config entry (ptr);		/* Subroutine to display config deck */
dcl  display_am_$sdw entry (ptr, fixed bin (3));		/* Subroutine to display SDW assoiate memory */
dcl  display_am_$ptw entry (ptr, fixed bin (3));		/* Subroutine to display PTW assoiate memory */
dcl  display_am_$validate_am_btld entry (ptr, fixed bin (35), fixed bin (3), fixed bin (35));
dcl  display_regs_$dump entry (ptr);			/* Subroutine to display regs from dump */
dcl  display_regs_$mcpds entry (ptr);			/* Subroutine to display PDS machine conditions */
dcl  display_regs_$mcprds entry (ptr);			/* Subroutine to display PRDS machine conditions */
dcl  display_regs_$mc entry (ptr);			/* Subroutine to display any machine condition */
dcl  display_syserr_$log entry (ptr);			/* Subroutine to display syserr_log */
dcl  display_syserr_$data entry (ptr);			/* Subroutine to display syserr_data */
dcl  display_segment_$name entry (ptr);			/* Subroutine to display segment name */
dcl  display_segment_$number entry (ptr);		/* Subroutine to display segment number */
dcl  ol_dump_util_$get_ptr entry (fixed bin, ptr, fixed bin (35), ptr); /* :: */
dcl  ol_dump_util_$get_ptr_quiet entry (fixed bin, ptr, fixed bin (35), ptr); /* :: */
dcl  ol_dump_util_$get_ptr_given_dbr entry (fixed bin (24), fixed bin, ptr, fixed bin (35), ptr);
dcl  ol_dump_util_$fnd_dbr entry (fixed bin (24), fixed bin (35), fixed bin, ptr);
dcl  ol_dump_util_$fnd_hcseg entry (char (32) aligned, ptr, fixed bin (24), ptr); /* :: */
dcl  ol_dump_util_$get_segno entry (char (32) varying, ptr) returns (fixed bin); /* :: */
dcl  ol_dump_util_$val_ptr entry (ptr) returns (char (16) aligned); /* :: */
dcl  display_mchist_ entry (ptr);			/* Subroutine to display machine condition history */
dcl  ol_dump_why_ entry (ptr);
dcl  pds_trace_ entry (ptr);

/* Automatic */

dcl (edoc, nsegs, mci, segno, last_segment, type, proc_no, last_segno,
     dump_segno, sstlen, sstntlen, tc, i, j, lin, lp, count, icode) fixed bin;
dcl  offset fixed bin;
dcl  ll fixed bin (21);
dcl  WS char (2) int static options (constant) init (" 	");
dcl (dbr, new_dbr, saved_dbr) fixed bin (24);
dcl (ap, eptr, nptr, p, tp, imcp, cpup, phcsp) ptr;
dcl (code, segln) fixed bin (35);
dcl  def_offset fixed bin (18);
dcl  seg_mode fixed bin (5) int static init (1011b);
dcl  tag (0 : 7) char (1) int static options (constant) init
    ("a", "b", "c", "d", "e", "f", "g", "h");
dcl  sys_ver_id char (8) aligned based (imcp);
dcl  rs_mode fixed bin (5);
dcl  display_dump_dir bit (1) init ("0"b);
dcl  execute bit (5) init ("00100"b);
dcl  stkout char (70);
dcl  cmdarg char (32);
dcl  targ char (32);
dcl  cnum char (1);
dcl  pnum char (4) var;
dcl (tmr, pn_sw, erf_sw, dpn) bit (1) init ("0"b);
dcl  a_name char (tc) based (tp);
dcl (null, length, addr, addrel, baseno, divide, fixed, rel, hbound, substr, index, ltrim, rtrim, size, search) builtin;
dcl (program_interrupt, any_other) condition;
dcl (dump_dir, tdump_dir) char (168) init ("");
dcl  dump_name char (32) aligned;
dcl (ename, tname) char (32);
dcl  name char (32) aligned;
dcl  acl_classp ptr;
dcl  time char (24) aligned;
dcl  inited bit (1) aligned int static init ("0"b);
dcl  have_erf bit (1) init ("0"b);
dcl  based_ptr ptr based;
dcl  com_string char (132) aligned;
dcl  why char (32) varying;
dcl  number_events fixed bin init (0);
dcl  time_interval fixed bin (71) init (0);
dcl (long_flag, short_flag, dde_mode) bit (1) init ("0"b);
dcl  dsegptr ptr;
dcl  path_list_name char (168) aligned init ("");

dcl 1 astruc like ol_dump_struc;			/* make an automatic structure */

dcl 1 entries (1) based (eptr),
    2 pad bit (18) unal,
    2 nindex bit (18) unal;

dcl  names (1) char (32) aligned based (nptr);

dcl  cpu_no fixed bin (3) based (cpup) aligned;
dcl  CPU_NO fixed bin (3) internal static;


dcl 1 mem_data (0 : 7) based (p) aligned,
    2 size fixed bin (17) unal,
    2 base fixed bin (17) unal,
    2 pad1 bit (36),
    2 online bit (1) unal,
    2 pad2 bit (35) unal,
    2 pad3 bit (36);

dcl  msg_ptr ptr;					/* for condition interpreter */
dcl  msg_len fixed bin;
dcl  int_cond_name char (32);
dcl  proc_state (0:6) char (9) varying init
    ("empty", "running", "ready", "waiting", "blocked", "stopped", "ptlocking");

dcl  dump_infop ptr;
dcl 1 dump_info based (dump_infop),
    2 no_procs fixed bin,
    2 proc_data (proc_no refer (no_procs)) aligned,
      3 process_no fixed bin,
      3 proc_dbr fixed bin (24),
      3 apte_offs fixed bin,
      3 apte_flags like apte.flags unal,
      3 apte_state bit (18),
      3 apte_process_id bit (36);



	odsp = addr (astruc);			/* set up ptr to ol_dump structure */
	call set_default_search_dirs;

	astruc.phcs_ok = "0"b;			/* intialially set phcs_ access to no */
	call hcs_$initiate (">system_library_1", "phcs_", "", 0, 0, phcsp, code);
	if phcsp ^= null then do;			/* if can be initiated */
	     call hcs_$fs_get_mode (phcsp, rs_mode, code); /* check caller's access */
	     if code = 0 then
		if bit (rs_mode) & execute then	/* if execute, then priv. process */
		     astruc.phcs_ok = "1"b;		/* user has access to phcs_, set switch */
	end;
	dump_dir = ">dumps";			/* set default dump dir */
	pn_sw, erf_sw = "0"b;			/* reset switches */
	call cu_$arg_count (count);			/* any args */
	if count ^= 0 then				/* if args process same */
	     do i = 1 to count;
	     call cu_$arg_ptr (i, tp, tc, code);	/* get arg */
	     if code ^= 0 then do;			/* some error */
		call com_err_ (code, "ol_dump", "getting  arg # ^d", i);
		return;
	     end;
	     if pn_sw then do;			/* user wants some other pathname for dump */
		call expand_pathname_ (a_name, dump_dir, ename, code); /* expand it */
		if code ^= 0 then do;		/* user goofed */
		     call com_err_ (code, "ol_dump", "expanding pathname ""^a""", a_name);
		     return;
		end;
		dump_dir = rtrim (dump_dir) || ">" || ename; /* put it all together */
		if substr (dump_dir, 1, 2) = ">>" then
		     dump_dir = substr (dump_dir, 2);
		pn_sw = "0"b;
	     end;
	     else if a_name = "-pathname" | a_name = "-pn" then
		pn_sw = "1"b;
	     else do;				/* must be erfno */
		astruc.arg (1) = a_name;		/* copy erf no */
		erf_sw = "1"b;			/* set switch */
	     end;
	end;

	on condition (program_interrupt) go to request;	/* set up program interrupt handler */

	if erf_sw then				/* if erf was specified go do it */
	     go to doerf;
request:


handl_cond:

	on condition (any_other) begin;

	     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 = "quit" |	/* dont bother with these */
	     cond_info.condition_name = "command_error" |
	     cond_info.condition_name = "command_question" |
	     cond_info.condition_name = "finish" then

		call continue_to_signal_ (code);

	     else do;
		if cond_info.condition_name = "out_of_bounds" then
		     call ioa_ ("ol_dump: out_of_bounds condition raised, possible invalid pointer.");
		else call condition_interpreter_ (null (), msg_ptr, msg_len, 3,
		     cond_info.mc_ptr, int_cond_name,
		     cond_info.wc_ptr, cond_infop);
		call ioa_ ("ol_dump: Returning to request loop.");
		go to request;
	     end;


	end;					/* end any_other */


	com_string, cmdarg = "";			/* clear out last command */
	call ioa_$nnl ("^/---   ");			/* print out prompt for user */
get_inp:	call iox_$get_line (iox_$user_input, addr (com_string), length (com_string), ll, code);
	if code ^= 0 then do;			/* error reading from  terminal */
	     call com_err_ (code, "ol_dump", "reading input from user_input");
	     go to request;
	end;
	substr (com_string, ll) = "";			/* strip out new_line */
	if ll = 1 then go to get_inp;			/* ignor white space */

/* separate arguments into arg array */

	lp = 1;					/* start at beginning of line */
	do i = 1 to hbound (ol_dump_struc.arg, 1) while (lp < ll);
	     j = length (ltrim (substr (com_string, lp, ll), WS)); /* strip off leading white space */
	     lp = (ll - j) + lp;			/* lp = starting position of next string */
	     j = search (substr (com_string, lp), WS);	/* find end of string */
	     if i = 1 then				/* if first arg, fill in command arg */
		cmdarg = substr (com_string, lp, j - 1);
	     else astruc.arg (i - 1) = substr (com_string, lp, j - 1);
	     lp = lp + (j - 1);			/* update line position */
	end;
	astruc.argcnt = i - 2;			/* set arg count for user */

%page;


	if cmdarg = "erf" then do;			/* we better have an erf specified */
	     if astruc.argcnt < 1 then do;
erf_label:
		call ioa_ ("erf no/last");
		go to request;
	     end;
doerf:
	     if astruc.arg (1) = "last" then do;	/* user wants latest dump */
		call get_system_free_area_ (ap);	/* get a pointer to an area to use */
		call hcs_$star_ (dump_dir, "*.*.0.*", 2, ap, count, eptr, nptr, code);
		if code ^= 0 then do;
		     call com_err_ (code, "ol_dump", "referencing directory ""^a""", dump_dir);
		     go to request;
		end;
		i = fixed (eptr -> entries (count).nindex);
		dump_name = substr (nptr -> names (i), index (nptr -> names (i), ".0.") + 3, 4);
	     end;
	     else dump_name = astruc.arg (1);		/* must be erf number */
	     call get_dump_ptrs_$dump_dir (dump_dir, dump_name, astruc.dumpp, astruc.dumpln,
		nsegs, name);			/* get ptrs to the segments */
	     if nsegs = 0 then do;			/* couldn't find the erf in >dumps */

		tname = name;
		code = 0;
		call hcs_$initiate (dump_dir, tname, "", 0, 1, acl_classp, code); /* see if its an access problem */
		if code ^= 0 then do;
		     if code = error_table_$incorrect_access then
			call ioa_ ("Incorrect access to directory ""^a""",
			dump_dir);
		     else if code = error_table_$moderr | code = error_table_$no_r_permission then
			call ioa_ ("Incorrect access to dump number ""^a"" in directory ""^a""", dump_name, dump_dir);

		     else if code = error_table_$no_dir then
			call ioa_ ("Some directory in path ""^a"" does not exist", dump_dir);

		     else if code = error_table_$noentry then
			call ioa_ ("Can't find dump number ""^a"" in directory ""^a""", dump_name, dump_dir);


		     else call ioa_ ("Can't find dump number ""^a"" in directory ""^a""", dump_name, dump_dir);
		end;

		name = "";
		go to request;
	     end;

	     call hcs_$get_max_length (dump_dir, name, astruc.max_length, code);
	     if code ^= 0 then go to fatal;
	     astruc.dbr_offset = 1;			/* default process is first */
	     astruc.proc_offset = size (dump);		/* .... */

	     call date_time_ (astruc.dumpp (0) -> dump.time, time); /* get the time of the dump */
	     call ol_dump_util_$get_ptr (7, sltp, segln, odsp); /* get pointer to the slt */
	     if sltp = null then go to request;
	     astruc.sltptr = sltp;			/* set up our structure */
	     stkout = ol_dump_util_$val_ptr (addr (sltp -> based_ptr));
	     if index (stkout, "Invalid") ^= 0 then go to fatal;
	     astruc.hcscnt = sltp -> slt.last_sup_seg;	/* Last hardcore seg number */
	     call ol_dump_util_$get_ptr (fixed (baseno (sltp -> based_ptr)), astruc.sltnp, segln, odsp);
	     if astruc.sltnp = null then go to request;
	     call ring0_get_$segptr_given_slt ("", "pds", temp_pds_ptr, code, sltp, astruc.sltnp); /* get a ptr to a pds */
	     if temp_pds_ptr ^= null then
		astruc.pdsseg = fixed (baseno (temp_pds_ptr), 18);
	     else do;
		call ioa_ ("Cannot find PDS in SLT");
		go to fatal;
	     end;
	     call ring0_get_$segptr_given_slt ("", "prds", temp_prds_ptr, code, sltp, astruc.sltnp); /* get a ptr to a prds */
	     if temp_prds_ptr ^= null then
		astruc.prdsseg = fixed (baseno (temp_prds_ptr), 18);
	     else do;
		call ioa_ ("Cannot find PRDS in SLT");
		go to fatal;
	     end;
	     call ring0_get_$segptr_given_slt ("", "kst_seg", temp_kst_ptr, code, sltp, astruc.sltnp); /* get a ptr to a kst */
	     if temp_kst_ptr ^= null then
		astruc.kstseg = fixed (baseno (temp_kst_ptr), 18);
	     else do;
		call ioa_ ("Cannot find KST in SLT");
		go to fatal;
	     end;

	     call ring0_get_$segptr_given_slt ("", "dseg", astruc.dsegp, code, sltp, astruc.sltnp); /* get dseg ptr */
	     if astruc.dsegp = null then do;
fatal:		call com_err_ (0, "ol_dump", "Insufficient or incomplete dump: ^a", dump_name);
		go to request;
	     end;
	     astruc.dsegno = fixed (baseno (astruc.dsegp)); /* get segment number of dseg */
	     call ol_dump_util_$get_ptr (astruc.dsegno, astruc.dsegp, segln, odsp); /* get ptr to dseg within the dump */
	     if astruc.dsegp = null then go to request;
	     astruc.defptr = null;			/*  get ptr to definitions seg */
	     call ring0_get_$segptr_given_slt ("", "definitions_", p, code, sltp, astruc.sltnp);
	     if code = 0 then
		call ol_dump_util_$get_ptr (fixed (baseno (p)), astruc.defptr, segln, odsp);
	     astruc.dbrsv = fixed (astruc.dsegp -> sdwa (astruc.dsegno).add, 24); /* get address field from dbr */
	     call ioa_ ("Using ERF ^d, dumped ^a", astruc.dumpp (0) -> dump.erfno, time);
	     have_erf, inited = "1"b;
	     call ring0_get_$segptr_given_slt ("", "sst", sstp, code, sltp, astruc.sltnp); /* try to get pointer to sst */
	     astruc.coremapptr = null;
	     call ring0_get_$segptr_given_slt ("", "tc_data", astruc.tcdp, code, sltp, astruc.sltnp); /* get tc_data ptr */
	     call ring0_get_$segptr_given_slt ("", "sst_names_", astruc.sstnp, code, sltp, astruc.sltnp);
	     call ring0_get_$segptr_given_slt ("", "active_all_rings_data", p, code, sltp, astruc.sltnp);
	     if code ^= 0 then go to ck_tcdp;
	     segno = fixed (baseno (p), 18);
	     call ol_dump_util_$get_ptr (segno, p, segln, odsp);
	     if p = null then go to ck_tcdp;
	     call ring0_get_$definition_given_slt (null, "active_all_rings_data", "system_id",
		def_offset, type, code, sltp, astruc.sltnp, astruc.defptr);
	     if code ^= 0 then go to ck_tcdp;
	     imcp = addrel (p, def_offset);

	     call ioa_$rsnnl ("System - ^a ", stkout, mci, sys_ver_id);
	     call ring0_get_$definition_given_slt (null, "active_all_rings_data", "version_id",
		def_offset, type, code, sltp, astruc.sltnp, astruc.defptr);
	     if code ^= 0 then go to prtsys;
	     imcp = addrel (p, def_offset);
	     call ioa_$rsnnl ("^a Version - ^a", stkout, mci, stkout, sys_ver_id);
prtsys:
	     call ioa_ ("^a", stkout);
ck_tcdp:
	     if astruc.tcdp = null then
		call ioa_ ("dbr = ^o^/NO TC_DATA", astruc.dbrsv);
	     else do;
		astruc.tcdseg = fixed (baseno (astruc.tcdp));
		call ol_dump_util_$get_ptr (fixed (baseno (astruc.tcdp)), astruc.tcdp, segln, odsp);
		if astruc.tcdp = null then go to request;
		call ring0_get_$segptr_given_slt ("", "prds", p, code, sltp, astruc.sltnp);
		astruc.prdsseg = fixed (baseno (p), 18);

		astruc.aptap = addrel (astruc.tcdp, fixed (astruc.tcdp -> tcm.apt_offset)); /* get ptr to the apt array */
		astruc.apt_entry_size = astruc.tcdp -> tcm.apt_entry_size; /* get the size of an entry */
		astruc.no_apt = astruc.tcdp -> tcm.apt_size; /* get the number of apt entries */

		call ring0_get_$segptr_given_slt ("", "scs", p, code, sltp, astruc.sltnp);
		call ol_dump_util_$get_ptr (fixed (baseno (p)), p, segln, odsp);
		call ring0_get_$definition_given_slt (null, "scs", "bos_processor_tag",
		     def_offset, type, code, sltp, astruc.sltnp, astruc.defptr);
		cpup = addrel (p, def_offset);	/* Get ptr to bos procssor tag */
		call ring0_get_$definition_given_slt (null, "scs", "controller_data",
		     def_offset, type, code, sltp, astruc.sltnp, astruc.defptr);
		p = addrel (p, def_offset);		/* Get ptr to controller data structure */
		do i = 0 to hbound (mem_data, 1);
		     if mem_data.online (i) then
			if mem_data.base (i) = 0 then
			     go to found_blscu;
		end;
found_blscu:
		CPU_NO = cpu_no;
		call ioa_ ("Bootload cpu - ^a (#^o), Bootload Memory  - ^a",
		     tag (CPU_NO), CPU_NO, tag (i));

		if sstp = null then do;
		     call ioa_ ("NO SST");
		     astruc.coremapptr = null;
		end;
		else do;
		     i = fixed (baseno (sstp));
		     call hcs_$make_seg ("", "ol_dump.sst--", "", seg_mode, sstp, code);
		     call copy_dump_seg_ (i, astruc.dbr_offset, astruc.dumpp, astruc.dumpln, sstp, sstlen);
		     astruc.sstptr = sstp;		/* set up pointer in structure */
		     if i = fixed (baseno (sst.cmp)) then /* core_map is in same segment as sst */
			astruc.coremapptr = ptr (sstp, rel (sst.cmp));
		     else do;
			call hcs_$make_seg ("", "ol_dump.core-map", "", seg_mode, astruc.coremapptr, code);
			call copy_dump_seg_ (fixed (baseno (sst.cmp)), astruc.dbr_offset, astruc.dumpp, astruc.dumpln, astruc.coremapptr, (0));
		     end;
		end;


		if astruc.sstnp = null then call ioa_ ("NO SSTNT");
		else do;
		     i = fixed (baseno (astruc.sstnp));
		     call hcs_$make_seg ("", "ol_dump.sstnt", "", seg_mode, astruc.sstnp, code);
		     call copy_dump_seg_ (i, astruc.dbr_offset, astruc.dumpp, astruc.dumpln, astruc.sstnp, sstntlen);
		end;
		call ring0_get_$segptr_given_slt ("", "kst_seg", p, code, sltp, astruc.sltnp);
		if p = null then
		     call ioa_ ("NO KST");
		else do;
		     astruc.kstseg = fixed (baseno (p));
		     call ol_dump_util_$get_ptr (astruc.kstseg, astruc.kstptr, segln, odsp);
		end;
		call hcs_$make_seg ("", "ol_dump_info", "", seg_mode, dump_infop, code);

		call display_process_$fdi (dump_infop, odsp);

		call display_am_$validate_am_btld (odsp, segln, CPU_NO, code); /* now check the validity of AMs */

		tmr, dpn = "0"b;
						/* attempt to settle in on a running process */

		dumpptr = ol_dump_struc.dumpp (0);
		ol_dump_struc.boot_dbr = fixed (substr (dump.dbr, 1, 24), 24);
		astruc.boot_dbr = ol_dump_struc.boot_dbr;
		do i = 1 to dump_info.no_procs while (tmr = "0"b);

		     if dump_info.apte_state (i) = "000001"b3 then do;
			call ol_dump_util_$get_ptr_given_dbr (dump_info.proc_dbr (i),
			     astruc.prdsseg, cpup, segln, odsp);

			if cpup = null then
			     go to runapt_lp;
			call ring0_get_$definition_given_slt (null, "prds", "processor_tag",
			     def_offset, type, code, sltp, astruc.sltnp, astruc.defptr);
			cpup = addrel (cpup, def_offset); /* Get ptr to cpu # in prds. */
			astruc.dbrsv, dbr = dump_info.proc_dbr (i);
			call ol_dump_util_$fnd_dbr (dbr, segln, icode, odsp);
			if icode = -1 then
			     go to runapt_lp;

			else do;
			     call ol_dump_util_$get_ptr (astruc.kstseg, astruc.kstptr, segln, odsp);
			     proc_no = dump_info.process_no (i);
			     dpn = "1"b;
			     tmr = "1"b;
			end;
		     end;
runapt_lp:
		end;


		call ioa_ ("^/Process^[ ^d^;^s^]: dbr = ^o, on cpu ^a (#^o)",
		     dpn, proc_no, astruc.dbrsv, tag (cpu_no), cpu_no);

		CPU_NO = cpu_no;
	     end;

	     call ring0_get_$segptr_given_slt ("", "pds", p, code, sltp, astruc.sltnp);
	     astruc.pdsseg = fixed (baseno (p), 18);

	end;

%page;
	else if cmdarg = "quit" | cmdarg = "q" then do;
	     inited = "0"b;
	     return;
	end;
%page;
	else if cmdarg = "debug" | cmdarg = "db" then do;
	     if astruc.argcnt < 1 then do;
bd_db_arg:	call ioa_ ("Improper command syntax; proper syntax is: ""debug on/off""");
		go to request;
	     end;


	     if astruc.arg (1) = "on" then
		on condition (any_other) go to handl_cond;
	     else if astruc.arg (1) = "off" then
		revert condition (any_other);
	     else go to bd_db_arg;

	     go to request;
	end;


%page;
	else if cmdarg = "command" |cmdarg = "c" then do;
	     j = length (rtrim (cmdarg)) + 1;
	     i = ll - j;
	     com_string = substr (com_string, j, i);
com:	     call cu_$cp (addr (com_string), i, code);
	end;

	else if substr (cmdarg, 1, 2) = ".." then do;
	     j = length (rtrim (com_string)) -2;
	     com_string = substr (com_string, 3, j);
	     call cu_$cp (addr (com_string), j, code);
	end;

%page;
	else if cmdarg = "list" | cmdarg = "l" then do;
	     call get_system_free_area_ (ap);		/* get a pointer to an area to use */
	     call hcs_$star_ (dump_dir, "*.*.0.*", 2, ap, count, eptr, nptr, code);
	     if code ^= 0 then do;
		call com_err_ (code, "ol_dump", "referencing directory ""^a""", dump_dir);
		go to request;
	     end;
	     call ioa_ ("ERFs contained in directory - ""^a"":^/", dump_dir);
	     do i = count to 1 by - 1;
		call ioa_ ("^a", nptr -> names (fixed (eptr -> entries (i).nindex)));
	     end;
	     free eptr -> entries;
	     free nptr -> names;
	end;

%page;
	else if cmdarg = "?" | cmdarg = "help" then do;	/* tell user what he can do */
ol_help:	     call ioa_ ("erf^/erf?^/quit (q)^/command (c)(..)^/list (l)^/dump (d)^/dbr");
	     call ioa_ ("ast (pt)^/name (n)^/proc (p)^/queue (tcq)^/stack (s)^/segno (segn)");
	     call ioa_ ("syserdta (sdta)^/syserlog (slog)^/mcpds (mcp)");
	     call ioa_ ("mcprds (mcpr)^/mc^/dumpregs (dregs)^/lrn^/ssd^/hisregs (hregs)");
	     call ioa_ ("pcd^/amsdw (ams)^/amptw (amp)^/mchist (mch)");
	     call ioa_ ("dumpdir (dmpd)^/debug (db)");
	     call ioa_ ("dump_events (de)^/absadr^/dbr?^/proc?");
	     call ioa_ ("why {lg}^/pds_trace {N}");
	end;

%page;
	else if cmdarg = "ssd" then do;
	     if astruc.argcnt < 1 | astruc.argcnt > 3 then do;
ssd_label:
		call ioa_ ("Usage is: ssd paths | def | pr^/^10xMaximum of 3 paths.");
		go to request;
	     end;
	     if astruc.argcnt = 1 & astruc.arg (1) = "pr" then go to egnor_ssd;
	     if astruc.argcnt = 1 & astruc.arg (1) = "def" then do;
		call set_default_search_dirs;
		go to egnor_ssd;
	     end;


	     do i = 1 to astruc.argcnt;
		call absolute_pathname_ ((astruc.arg (i)), tdump_dir, code);
		if code ^= 0 then do;
		     call com_err_ (code, "ol_dump", astruc.arg (i));
		     go to ssd_label;
		end;
	     end;
	     astruc.search_dirs = "";
	     do i = 1 to astruc.argcnt;
		call absolute_pathname_ ((astruc.arg (i)), tdump_dir, code);

		astruc.search_dirs (i) = tdump_dir;
	     end;
egnor_ssd:
	     call ioa_ ("Directories Searched:");
	     do i = 1 to hbound (astruc.search_dirs, 1);
		call ioa_ ("^a", astruc.search_dirs (i));
		if i + 1 <= hbound (astruc.search_dirs, 1) then
		     if astruc.search_dirs (i) = astruc.search_dirs (i+1) then go to request;
	     end;
	end;

%page;
	else if cmdarg = "dumpdir" | cmdarg = "dmpd" then do; /* user wants to look in another dump dir */
	     if astruc.argcnt < 1 then do;
		call ioa_ ("dumpdir PATH");
		go to request;
	     end;

	     tname = astruc.arg (1);
	     call expand_pathname_ (tname, dump_dir, ename, code);
	     if code ^= 0 then do;			/* user goofed */
		call com_err_ (code, "ol_dump", "expanding pathname ""^a""", a_name);
		go to request;
	     end;

	     if substr (dump_dir, 1, 3) = ">  " then
		dump_dir = "";

	     dump_dir = rtrim (dump_dir) || ">" || ename; /* put it all together */
	     inited = "0"b;
	     go to request;
	end;


%page;
	else if cmdarg = "dump_events" | cmdarg = "de" then do;

	     if astruc.argcnt < 1 then		/* ensure ERF selected */
		if ^have_erf then
		     go to NOT_INITED;

	     tname = dump_name;
	     tdump_dir = dump_dir;
	     long_flag, short_flag = "0"b;


	     if astruc.argcnt < 1 then do;		/* use defaults */
		call display_dump_events$display_dump_events_ (tname, tdump_dir, 0, 0, "1"b);
		go to request;
	     end;


	     else do i = 1 to astruc.argcnt;		/* get and validate args */
		if astruc.arg (i) = "-dump_dir" | astruc.arg (i) = "-dmpd" then do;
		     i = i + 1;
		     if i > astruc.argcnt then do;
			why = "dump_dir";
MISSING:			call com_err_ (error_table_$noarg, "display_events", why);
			go to USE;
		     end;

		     targ = astruc.arg (i);
		     call absolute_pathname_ (targ, tdump_dir, code);
		     if code ^= 0 then do;
			call com_err_ (code, "dump_events", astruc.arg (i));
			go to USE;
		     end;
		end;

		else if astruc.arg (i) = "-erf" then do;
		     i = i + 1;
		     why = "erf";
		     if i > astruc.argcnt then goto MISSING;
		     tname = astruc.arg (i);
		     have_erf = "1"b;
		end;

		else if astruc.arg (i) = "-last" | astruc.arg (i) = "-lt" then do;
		     why = "Number events";
		     i = i + 1;
		     if i > astruc.argcnt then goto MISSING;
		     on conversion goto BAD_ARGUMENT;
		     number_events = fixed (astruc.arg (i));
		     revert conversion;
		end;

		else if astruc.arg (i) = "-time" | astruc.arg (i) = "-tm" then do;
		     why = "Time interval";
		     i = i + 1;
		     if i > astruc.argcnt then goto MISSING;
		     on conversion goto BAD_ARGUMENT;
		     time_interval = fixed (astruc.arg (i)) * 1000000;
		     revert conversion;
		end;
		else if astruc.arg (i) = "-brief" | astruc.arg (i) = "-bf"
		then short_flag = "1"b;
		else if astruc.arg (i) = "-long" | astruc.arg (i) = "-lg"
		then long_flag = "1"b;

		else do;
		     call com_err_ (error_table_$badopt, "dump_events", astruc.arg (i));
USE:		     call ioa_ ("Usage is: display_events {control_args}^/^10xControl Arguments: -time, -tm {interval in sec.}     -brief, -bf     -long, -lg");
		     go to request;
		end;
	     end;

	     if short_flag & long_flag then do;
		call com_err_ (error_table_$inconsistent, "-brief and -long");
		go to request;
	     end;

	     if ^have_erf then
		go to NOT_INITED;


	     if short_flag then
		dde_mode = "0"b;
	     else dde_mode = "1"b;

	     call display_dump_events$display_dump_events_ (tname, tdump_dir, number_events,
		time_interval, dde_mode);

	     if ^inited then			/* reset ERF ind */
		have_erf = "0"b;

	     go to request;


BAD_ARGUMENT:
	     call com_err_ (error_table_$badopt, "dump_events", why);
	     go to USE;
	end;


%page;
	else if ^inited then do;			/* we haven't been given an erf yet */
NOT_INITED:    call ioa_ ("Please specify an ERF number.");
	     go to request;
	end;


%page;
	else if cmdarg = "erf?" then do;

	     call ioa_ ("Using ERF ^d, dumped ^a", astruc.dumpp (0) -> dump.erfno, time);

	     call ioa_ ("^[Proc ^d, ^;^s^]dbr = ^o on cpu ^a (#^d).", dpn, proc_no, astruc.dbrsv, tag (CPU_NO), CPU_NO);
	     go to request;
	end;


%page;
	else if cmdarg = "dbr" then do;
	     if astruc.argcnt < 1 then do;
dbr_label:	call ioa_ ("dbr value|cpun|cpu n|cpu tag|proc n |inzr");
		go to request;
	     end;

	     saved_dbr = astruc.dbrsv;

	     if astruc.arg (1) = "inzr" then do;	/* he/she wants the initializer's dbr */
set_up_inzr:	aptep = astruc.aptap;		/* get inzrs dbr */
		sdwp = addr (apte.dbr);
		new_dbr = fixed (sdw.add, 24);
		go to get_new_dbr;
	     end;


	     if astruc.arg (1) ^= "proc" & substr (astruc.arg (1), 1, 3) ^= "cpu" then do;
		new_dbr = cv_oct_check_ ((astruc.arg (1)), code);
		if code ^= 0 then go to dbr_label;
get_new_dbr:	call ol_dump_util_$get_ptr_given_dbr (new_dbr, astruc.prdsseg, cpup, segln, odsp);
		if cpup = null then do;
		     call ioa_ ("Cannot find a CPU for this dbr (^8o)", new_dbr);
		     go to request;
		end;

		astruc.dbrsv, dbr = new_dbr;

		call ring0_get_$definition_given_slt (null, "prds", "processor_tag",
		     def_offset, type, code, sltp, astruc.sltnp, astruc.defptr);
		cpup = addrel (cpup, def_offset);	/* Get ptr to cpu # in prds. */
		dpn = "0"b;
		do j = 1 to dump_info.no_procs;
		     if astruc.dbrsv = dump_info.proc_dbr (j) then do;
			proc_no = dump_info.process_no (j);
			dpn = "1"b;
			go to dbr_com;
		     end;
		end;

		go to dbr_com;
	     end;


	     if astruc.arg (1) = "proc" then do;
		if astruc.argcnt < 2 then go to dbr_label;
		pnum = astruc.arg (2);
		edoc = cv_dec_check_ (ltrim (rtrim (pnum)), code);
		if code ^= 0 then
		     go to dbr_label;
		dpn, tmr = "0"b;
		do i = 1 to dump_info.no_procs while (^tmr);
		     if edoc = dump_info.process_no (i) then do;
			call ol_dump_util_$get_ptr_given_dbr (dump_info.proc_dbr (i),
			     astruc.prdsseg, cpup, segln, odsp);

			if cpup = null then do;
			     call ioa_ ("Cannot find a CPU for this process.");
			     if edoc = 0 then go to set_up_inzr;
			     go to request;
			end;
			call ring0_get_$definition_given_slt (null, "prds", "processor_tag",
			     def_offset, type, code, sltp, astruc.sltnp, astruc.defptr);
			cpup = addrel (cpup, def_offset);
			dpn = "1"b;
			proc_no = edoc;
			tmr = "1"b;
			astruc.dbrsv, dbr = dump_info.proc_dbr (i);
			go to dbr_com;
		     end;
		end;
		if ^tmr then do;			/* couldn't find it */
		     if edoc = 0 then go to set_up_inzr;
		     call ioa_ ("Could not find ^a in process table.", astruc.arg (2));
		     go to request;
		end;
	     end;


	     else if substr (astruc.arg (1), 1, 3) = "cpu" then do;
		if length (astruc.arg (1)) > 3 then
		     cnum = substr (astruc.arg (1), 4, 1);
		else if astruc.argcnt > 1 then
		     cnum = substr (astruc.arg (2), 1, 1);
		else go to dbr_label;
		edoc = cv_oct_check_ (cnum, code);
		if code ^= 0 then do;
		     tmr = "0"b;
		     do i = 0 to hbound (tag, 1) while (^tmr);
			if cnum = tag (i) then
			     tmr = "1"b;
		     end;
		     if ^tmr then go to dbr_label;
		     edoc = i - 1;
		end;
		do i = 0 to astruc.no_apt;
		     aptep = addrel (astruc.aptap, i*astruc.apt_entry_size);
		     if apte.state = "000001"b3 then do;
			sdwp = addr (aptep -> apte.dbr); /* running */
			call ol_dump_util_$get_ptr_given_dbr (fixed (sdw.add, 24), astruc.prdsseg, cpup, segln, odsp);
			if cpup = null then go to fdbrlp;
			call ring0_get_$definition_given_slt (null, "prds", "processor_tag",
			     def_offset, type, code, sltp, astruc.sltnp, astruc.defptr);
			cpup = addrel (cpup, def_offset); /* Get ptr to cpu # in prds. */
			dpn = "0"b;
			if cpu_no = edoc then do;
			     do j = 1 to dump_info.no_procs;
				if fixed (sdw.add, 24) = dump_info.proc_dbr (j) then do;
				     proc_no = dump_info.process_no (j);
				     dpn = "1"b;
				     go to got_cpu;
				end;
			     end;
			end;
		     end;
fdbrlp:
		end;
		call ioa_ ("No running process for cpu ^a (#^o) found", tag (edoc), edoc);
		go to request;
got_cpu:
		astruc.dbrsv, dbr = fixed (sdw.add, 24);
		go to dbr_com;
	     end;

dbr_com:
	     call ol_dump_util_$fnd_dbr (dbr, segln, i, odsp);

	     if i = -1 then do;
		call ioa_ ("dbr ^o not found in erf ^a", dbr, dump_name);
						/* ensure dbr is what it was */
		astruc.dbrsv, dbr = saved_dbr;
		call ol_dump_util_$fnd_dbr (dbr, segln, i, odsp);
	     end;

	     else do;
		call ol_dump_util_$get_ptr (astruc.kstseg, astruc.kstptr, segln, odsp);
		call ioa_ ("^[Proc ^d, ^;^s^]dbr = ^o on cpu ^a (#^o)",
		     dpn, proc_no, astruc.dbrsv, tag (cpu_no), cpu_no);
		CPU_NO = cpu_no;
		astruc.dbrsv = dbr;
		go to request;
	     end;
	end;


%page;
	else if cmdarg = "tcq" | cmdarg = "queue" then
	     call display_process_$tcq (dump_infop, odsp); /* print traffic controller queue */
	else if cmdarg = "dump" | cmdarg = "d" then
	     call display_dump_ (odsp);		/* display requested dump */
	else if cmdarg = "ast" | cmdarg = "pt" then
	     call display_ast_ (odsp);		/* print the requested AST entry */
	else if cmdarg = "name" | cmdarg = "n" then
	     call display_segment_$name (odsp);		/* display the requested segment name */
	else if cmdarg = "segno" | cmdarg = "segn" then
	     call display_segment_$number (odsp);	/* display the requested segment number */
	else if cmdarg = "p" | cmdarg = "proc" then
	     call display_process_$apt (odsp);		/* display the requested APT entries */
	else if cmdarg = "stack" | cmdarg = "s" then
	     call display_stack_ (odsp);		/* trace the requested stack segment */
	else if cmdarg = "syserdta" | cmdarg = "sdta" then
	     call display_syserr_$data (odsp);		/* display the message entries in syserr_data */
	else if cmdarg = "syserlog" | cmdarg = "slog" then
	     call display_syserr_$log (odsp);		/* display the requested message entries in syserr_log */
	else if cmdarg = "mcp" | cmdarg = "mcpds" then
	     call display_regs_$mcpds (odsp);		/* display the requested pds machine conditions */
	else if cmdarg = "mcpr" |cmdarg = "mcprds" then
	     call display_regs_$mcprds (odsp);		/* display the requested prds machine machine conditions */
	else if cmdarg = "mc" then
	     call display_regs_$mc (odsp);		/* display requested machine condition */
	else if cmdarg = "dumpregs" | cmdarg = "dregs" then
	     call display_regs_$dump (odsp);		/* display the processor regs at the time of the dump */
	else if cmdarg = "lrn" then
	     call display_segment_$dseg (odsp);		/* display the descriptor segment */
	else if cmdarg = "hisregs" | cmdarg = "hregs" then
	     call display_regs_$hregs (odsp);		/* display the requested history registers */
	else if cmdarg = "pcd" then
	     call display_segment_$config (odsp);	/* display the config deck */
	else if cmdarg = "amsdw" | cmdarg = "ams" then
	     call display_am_$sdw (odsp, CPU_NO);	/* display the SDW assos. memory */
	else if cmdarg = "amptw" | cmdarg = "amp" then
	     call display_am_$ptw (odsp, CPU_NO);	/* display the PTW assos. memory */
	else if cmdarg = "mchist" | cmdarg = "mch" then
	     call display_mchist_ (odsp);		/* display sorted machine conditions */
	else if cmdarg = "absadr" then
	     call display_ast_$absadr (odsp);
	else if cmdarg = "proc?" | cmdarg = "dbr?" then

	     call ioa_ ("ERF ^d, dumped ^a^/^[Proc ^d, ^;^s^]dbr = ^o on cpu ^a (#^d).",
	     astruc.dumpp (0) -> dump.erfno, time, dpn, proc_no, astruc.dbrsv, tag (CPU_NO), CPU_NO);
	else if cmdarg = "." then do;
	     if dump_dir ^= ">dumps" then
		display_dump_dir = "1"b;
	     call ioa_ ("^/ol_dump version 10.1:^/ERF ^d, dumped ^a ^[ Dump Dir = ^a^]",
		astruc.dumpp (0) -> dump.erfno, time, display_dump_dir, ltrim (rtrim (dump_dir)));
	     call ioa_ ("^[Proc ^d, ^;^s^]dbr = ^o on cpu ^a (#^d).",
		dpn, proc_no, astruc.dbrsv, tag (CPU_NO), CPU_NO);
	end;


	else if cmdarg = "pds_trace" then call pds_trace_ (odsp);

	else if cmdarg = "why" then do;
	     call ol_dump_why_ (odsp);
	     new_dbr = astruc.dbrsv;
	     go to get_new_dbr;
	end;


	else					/*  must be invalid command, let user know and go to request */
	call ioa_ ("Invalid command argument ""^a""; type ""help"" for a list of valid commands", cmdarg);


	go to request;				/* return to get next command */
%page;
set_default_search_dirs: proc;

dcl  default_path_list_name char (1024) var;
dcl (i, j) fixed bin;
dcl  ec fixed bin (35);
dcl  cu_$evaluate_active_string entry (ptr, char (*), fixed bin, char (*) var, fixed bin (35));

%include cp_active_string_types;

	     call cu_$evaluate_active_string (null (), "library_descriptor pathname h.e", ATOMIC_ACTIVE_STRING, default_path_list_name, ec);
	     if ec ^= 0 then do;
		call com_err_ (ec, "ol_dump", "From call to library_descriptor active function.  Cannot set default search directories.");
		astruc.search_dirs (*) = "";
	     end;
	     j = 1;
	     do while (j <= hbound (astruc.search_dirs, 1) & default_path_list_name ^= "");
		astruc.search_dirs (j) = before (default_path_list_name, " ");
		default_path_list_name = ltrim (after (default_path_list_name, " "));
		j = j + 1;
	     end;
	     do i = j to hbound (astruc.search_dirs, 1);	/* The rest get filled with dummies. */
		astruc.search_dirs (i) = astruc.search_dirs (j - 1);
	     end;
	end set_default_search_dirs;


%page;
% include slt;
%page;
% include sst;
%page;
% include aste;
%page;
% include sdw;
%page;
% include bos_dump;
%page;
% include apte;
%page;
% include tcm;
%page;


     end ol_dump;




		    ol_dump_util_.pl1               11/10/82  1713.3rew 11/10/82  0916.7      164898



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


ol_dump_util_: proc;


/* Modified 7/80 by R.L. Coppola to fix bug in stk_validate_fwd and rev
   where p_valid went oosb due to addr of ptr being larger than max_length */
/* Modified 7/80 by R. L. Coppola to fix bug in p_valid. */
/* Modified Oct 1982 by Rich Coppola to change value used to increment
   offset to 2048 from 1024. */


	return;					/* should never enter here */
% include ol_dump_struc;

/* subroutine entry declarations */

dcl (ioa_, ioa_$rsnnl) entry options (variable);
dcl  ring0_get_$segptr_given_slt entry (char (*) aligned, char (*) aligned, ptr, fixed bin, ptr, ptr);
dcl  ring0_get_$name_given_slt entry (char (*) aligned, char (*) aligned, ptr, fixed bin, ptr, ptr);
dcl  cv_oct_check_ entry (char (*), fixed bin) returns (fixed bin);
dcl  object_info_$display entry (ptr, fixed bin (24), ptr, fixed bin (35));
dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (24),
     fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin (35));
dcl  copy_dump_seg_ entry (fixed bin, fixed bin, (0:31) ptr, (0:31) fixed bin, ptr, fixed bin);
dcl  namef_$no_comp entry (ptr, ptr) returns (char (*));
dcl  namef_ entry (ptr, ptr) returns (char (*));
dcl  get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin);

dcl  dbr fixed bin (24);				/* :: */
dcl  segno fixed bin;				/* seg number  to find ptr for */
dcl  seglen fixed bin (35);				/* length of requested segment in words (output) */
dcl  a_code fixed bin;				/* return a_code for fnd_dbr */
dcl (i, j, offset, nmelng, code) fixed bin;
dcl  mx_len fixed bin (19) int static;			/* to remember max_length in ol_dump_struc */
dcl  ring fixed bin (3) unsigned;
dcl  bcode fixed bin (35);
dcl  bitcnt fixed bin (24);
dcl  name2 char (32) aligned init ("");
dcl  dir_name char (168);
dcl  out char (70);
dcl (new_proc, fsttmsw, q_sw) bit (1) unaligned;
dcl (fixed, ptr, null, divide, mod, reverse, verify, length, size, baseptr, baseno, addr, hbound, addrel, substr) builtin;
dcl (dsegptr, genp, dptr, sptr, nxt_sp) ptr;
dcl  sdw_add bit (24) aligned based;
dcl 1 sig_stack like signaller_stack based (sigstp);
dcl  sigstp ptr;
dcl  mc_frame_owner char (32) var;



get_ptr_given_dbr: entry (dbr, segno, sptr, seglen, odsp);

	fsttmsw = "1"b;				/* set entry idicator sw */
	q_sw = "0"b;
	go to com1;

fnd_dbr:	entry (dbr, seglen, a_code, odsp);

	q_sw, fsttmsw = "0"b;			/* reset entry indicator sw */
	a_code = 0;				/* preset good return a_code */

com1:
	offset = size (dump);			/* start at first process */

/* find DBR value requested */

	do j = 1 to dumpp (0) -> dump.num_segs;		/* search entire array for dseg */
	     if fixed (dumpp (0) -> dump.segs (j).segno, 18) = dsegno then do; /* we found a new process */
		dsegptr = ptr (dumpp (divide (offset, max_length, 17, 0)), mod (offset, max_length));
		if fixed (dsegptr -> sdw_add, 24) = dbr then /* we found dbr */
		     if ^fsttmsw then do;		/*  if fnd_dbr entry */
			seglen = fixed (dumpp (0) -> dump.segs (j).length, 18) * 64;
			dbr_offset = j;
			proc_offset = offset;
			dbrsv = dbr;
			dsegp = dsegptr;
			return;
		     end;
		     else go to get_ptr_com;		/* go find seg in this process */
	     end;
	     offset = offset + fixed (dumpp (0) -> dump.segs (j).length, 18)*64;
	end;
	if fsttmsw then				/* if get_ptr_given_dbr entry */
	     sptr = null;				/* could not find dbr, return null ptr */
	else a_code = -1;				/* if  fnd_dbr entry */
	return;


get_ptr_quiet: entry (segno, sptr, seglen, odsp);
	q_sw = "1"b;
	go to gp_com;

get_ptr:	entry (segno, sptr, seglen, odsp);

	q_sw = "0"b;
	mx_len = max_length;			/* remember for future use */
gp_com:
	offset = proc_offset;
	j = dbr_offset;
get_ptr_com:
	fsttmsw = "0"b;
dmp_ptr_scr:
	new_proc = "0"b;
	do i = j to dumpp (0) -> dump.num_segs while (^new_proc);
	     if fixed (dumpp (0) -> dump.segs (i).segno, 18) = segno then do; /* we found the desired segment */
		seglen = fixed (dumpp (0) -> dump.segs (i).length, 18) * 64;
		sptr = ptr (dumpp (divide (offset, max_length, 17, 0)), mod (offset, max_length)); /* .. */
		if fixed (rel (sptr)) + seglen > max_length then do; /* must be going over dump seg boundary */
		     call ioa_$rsnnl ("^d.^o.copy", name2, nmelng, dumpp (0) -> dump.erfno, segno);
		     call hcs_$make_seg ("", name2, "", 1011b, sptr, bcode);
		     call copy_dump_seg_ (segno, dbr_offset, dumpp, dumpln, sptr, nmelng);
		end;
		return;
	     end;
	     if dumpp (0) -> dump.segs (i).segno = "0"b then /* if first seg on new process */
		if i ^= j then			/* first seg of this process */
		     new_proc = "1"b;		/* nxt time  new process */
	     offset = offset + fixed (dumpp (0) -> dump.segs (i).length, 18)*64;
	end;
	if segno <= hcscnt then			/* if s hard core seg */
	     if ^per_process (segno) then		/* and not  a per process seg */
		if ^fsttmsw then do;		/* and if we haven't already been here once */
		     fsttmsw = "1"b;		/* take a lap thru first dumped */
		     offset = size (dump);
		     j = 1;
		     go to dmp_ptr_scr;
		end;
	if ^q_sw then
	     call ioa_ ("Segment ^o not found in process", segno);
	sptr = null;
	return;

/*  */
fnd_hcseg: entry (ename, gp, bitcount, odsp);
dcl  ename char (32) aligned;
dcl  gp ptr;
dcl  bitcount fixed bin (24);
	do libx = 1 to hbound (search_dirs, 1);		/* search all given directorys */
	     call hcs_$initiate_count (search_dirs (libx), ename, "", bitcount, 0, gp, bcode);
	     if gp ^= null then return;
	end;
	return;					/* Cannot find in any given directory */
is_hardcore_seg: entry (a_segno, odsp) returns (bit (1));
dcl  a_segno fixed bin;

	if (a_segno <= hcscnt & ^per_process (a_segno)) then
	     return ("1"b);
	else return ("0"b);

per_process: proc (segno) returns (bit (1));
dcl  segno fixed bin;
	     if segno ^= dsegno then
		if segno ^= pdsseg then
		     if segno ^= prdsseg then
			if segno ^= kstseg then
			     return ("0"b);
	     return ("1"b);
	end per_process;


/*  */


/* stk_validate_fwd - entry to trace threads for a stack_segment and find the last valid in formward direction */

stk_validate_fwd: entry (stkb, stkp, stkbp);
dcl (stkp, stkb, p_sp, stkv, stkbp) ptr;
dcl  iv bit (1);

	sb = stkb;				/* copy stack base pointer */
	stkp, p_sp = null;
	if p_valid (addr (stack_header.stack_begin_ptr)) then /* check validity of begin ptr */
	     sp = addrel (sb, rel (stack_header.stack_begin_ptr)); /* start at begin ptr */
	else return;				/* begin ptr invalid, return null ptr */
	stkbp = sp;				/* set stack begin ptr */
	iv = "0"b;				/* set loop control */
	do while (^iv);				/* iterate through stack frames */
	     if p_valid (addr (next_sp)) & p_valid (addr (prev_sp)) then /* if all this is true */
		if fixed (rel (next_sp)) > fixed (rel (sp)) -fixed (rel (sb)) then
		     if p_sp = null | fixed (rel (prev_sp)) = fixed (rel (p_sp)) - fixed (rel (sb)) then do;
			p_sp = sp;		/* save previous stack pointer */
			sp = addrel (sb, rel (next_sp));

			if p_valid (addr (next_sp)) then do;
			     if fixed (rel (next_sp)) > mx_len then
				iv = "1"b;
			end;

		     end;
		     else iv = "1"b;
		else iv = "1"b;
	     else iv = "1"b;			/* set terminate condition */
	end;
	stkp = p_sp;				/* set stk pointer to last valid stack frame */
	return;


/* is_cond_frame - internal procedure to determine if a stack frame has a condition */

is_cond_frame: proc (stkp) returns (bit (1));

dcl  stkp ptr;
	     if p_valid (addr (stkp -> stack_frame.return_ptr)) then do;
		out = namef_ (stkp -> stack_frame.return_ptr, odsp);
		if index (out, "return_to_ring_") ^= 0 then do;
		     mc_frame_owner = "return_to_ring_0";
		     return ("1"b);
		end;
		if index (out, "$fim|") ^= 0 then do;
		     mc_frame_owner = "fim";
		     return ("1"b);
		end;
		if index (out, "signaller") ^= 0 then do;
		     mc_frame_owner = "signaller";
		     return ("1"b);
		end;
	     end;
	     return ("0"b);
	end is_cond_frame;
						/*  */

/* stk_validate_rev - entry to trace stack frame threads in rev direction */

stk_validate_rev: entry (stkb, stkp, stkv);

	sb = stkb;				/* copy stack base pointer */
	stkp, stkv = null;
	if p_valid (addr (stack_end_ptr)) then do;	/* check validity of stack end pointer */
	     i = fixed (rel (stack_end_ptr));
	     if fixed (rel (stack_end_ptr)) ^> mx_len then
		sp = addrel (sb, rel (stack_end_ptr));	/* start at end pointer */
	     else return;
	end;
	else return;				/* end pointer invalid, return null ptrs */
	if ^p_valid (addr (sp -> stack_frame.prev_sp)) then /* no thrad back */
	     return;
	if fixed (baseno (prev_sp)) ^= fixed (baseno (stack_end_ptr)) then
	     return;
	if p_valid (addr (stack_begin_ptr)) then
	     if fixed (rel (prev_sp)) < fixed (rel (stack_begin_ptr)) then
		return;
	     else;
	else return;
	p_sp = null;
	iv = "0"b;				/* start at stack_end ptr and go fwd to find last valid frame */
	do while (^iv);
	     if p_valid (addr (next_sp)) & p_valid (addr (prev_sp)) then /* if all this is true */
		if fixed (rel (next_sp)) > fixed (rel (sp)) - fixed (rel (sb)) then
		     if p_sp = null | fixed (rel (prev_sp)) = fixed (rel (p_sp)) - fixed (rel (sb)) then do;
			p_sp = sp;		/* save previous stack pointer */
			sp = addrel (sb, rel (next_sp));
		     end;
		     else iv = "1"b;
		else iv = "1"b;
	     else iv = "1"b;			/* set terminate condition */
	end;
	stkp, sp = p_sp;				/* set stk pointer to last valid stack frame */
	p_sp = null;
	iv = "0"b;				/* now go backward until we get to begin ptr  */
	do while (^iv & (fixed (rel (sp)) - fixed (rel (sb)) ^= fixed (rel (stack_begin_ptr))));
	     if p_valid (addr (next_sp)) & p_valid (addr (prev_sp)) then /* if all this is true */
		if fixed (rel (prev_sp)) < fixed (rel (sp)) - fixed (rel (sb)) then
		     if p_sp = null | (fixed (rel (next_sp)) = fixed (rel (p_sp)) - fixed (rel (sb))) then do;
			p_sp = sp;		/* save previous stack pointer */
			sp = addrel (sb, rel (prev_sp));
		     end;
		     else iv = "1"b;
		else iv = "1"b;
	     else iv = "1"b;			/* set terminate condition */
	end;
	stkv = sp;				/* we now have last valid sp */
	return;

/*  */

/* find_cond - entry to find condition frame and return things */

find_cond: entry (stkba, stkpa, cname, a_mcptr, hrptr);
dcl (stkba, stkpa, a_mcptr, hrptr, stkpb, stkva, stkep) ptr;
dcl  cname char (32) varying;
dcl (found_cond, l_cnt) bit (1);
dcl  ptra (0:10) ptr based aligned;
dcl 1 acc based (stkva),
    2 l fixed bin (8) unal,
    2 str char (32) unal;

	cname = "";				/* initialize return parameters */
	a_mcptr, hrptr = null;
	if stkpa = null then do;			/* if sp not given, search entire stack */
	     call stk_validate_rev (stkba, stkpb, stkva); /* validate threads from end ptr */
	     if stkpb = null then return;		/* no luck, basd stack seg */
	     l_cnt = "0"b;
try_fwd:
	     sb = stkba;
	     sp = stkpb;
	     iv, found_cond = "0"b;			/* initialize terminate condition */
	     do while (^found_cond & ^iv);
		if sp = stkva then
		     iv = "1"b;
		if is_cond_frame (sp) then		/* if we found condition frame */
		     found_cond = "1"b;		/* set terminte condition */
		else sp = addrel (sb, rel (prev_sp));	/* go to next frame */
	     end;
	     if ^found_cond then			/* didn't find condition */
		if ^l_cnt then do;			/* if this is first time through */
		     call stk_validate_fwd (stkba, stkpb, stkep); /* search stack from begin ptr */
		     if stkpb = null then return;	/* no luck, bad stack seg */
		     stkva = addrel (stkba, rel (stkba -> stack_begin_ptr));
		     l_cnt = "1"b;
		     go to try_fwd;
		end;
		else return;			/* could not find condition frame either fwd or rev */
	     stkpa = sp;				/* found condition frame, set sp */
	end;
	if ^is_cond_frame (stkpa) then		/* if not a condition frame return */
	     return;
	sb = stkba;
	sp = stkpa;
	if mc_frame_owner = "return_to_ring_0" | mc_frame_owner = "signaller" then do;
	     sigstp = addrel (addr (stack_frame.timer), +1);
	     a_mcptr = addr (sig_stack.mach_cond);	/* set machine cond pointer */
	     hrptr = addr (sig_stack.history_registers);	/* set history register pointer */
	end;

	else do;					/* must belong to fim */
	     a_mcptr = addrel (sp, 48);
	     hrptr = addrel (sp, 96);
	end;

	nxt_sp = addrel (sb, rel (next_sp));
	out = namef_ (nxt_sp -> return_ptr, odsp);
	if index (out, "signal_") ^= 0 then do;		/* if signal_ frame */
	     ap = addrel (sb, rel (addrel (sb, rel (next_sp)) -> arg_ptr)); /*  get arg list ptr */
	     stkva = addrel (sb, rel (ap -> ptra (1)));
	     cname = substr (acc.str, 1, acc.l);
	end;
	return;


/*  */

get_segno: entry (vname, odsp) returns (fixed bin);
dcl  vname char (32) varying;
dcl  enname char (32) aligned;

	enname = vname;
	name2 = "";

	if substr (enname, 1, 4) = "ring" then
	     if index (enname, "_") = 0 then
		go to bad_stk_rng;


	if substr (enname, 1, 5) = "stack" then
	     if index (enname, "_") = 0 then do;

bad_stk_rng:
		call ioa_ ("stack_<n>/ring_<n> must be of the form ""stack_<n> or ring_<n>"" not ^a",
		     rtrim (enname));
		return (-1);
	     end;

	if index (enname, "stack_") ^= 0 | index (enname, "ring_") ^= 0
	then do;					/* find stack_<n> */
	     j = index (enname, "_") +1;
	     i = cv_oct_check_ (substr (enname, j, 1), code);
	     if code ^= 0 then go to bad_stk_rng;

	     if code = 0 then do;			/* must be 0 - 7 only */
		ring = i;				/* copy ring number */
		if dsegp -> sdw.entry_bound ^= "0"b then /* if we have a stack */
		     return (bin (dsegp -> sdw.entry_bound || bit (ring))); /* cancat. ring to stack in dbr */

		else do;				/* ??? */
		     call ioa_ ("^/No stack base for ^a in this particular process.", rtrim (enname));
		     return (-1);
		end;

	     end;
	end;

	call ring0_get_$segptr_given_slt ("", enname, genp, code, sltptr, sltnp);
	if code = 0 then return (fixed (baseno (genp), 17));
	if sstnp = null then do;
	     call ioa_ ("NO SSTNT");
	     return (-1);
	end;


	if (baseno (genp) = "0"b) & (enname ^= "dseg") then
	     go to bad_name;


	call get_ptr (dsegno, dsegp, bcode, odsp);

	if dsegp = null then return (-1);
	i = divide (bcode, 2, 17, 0) - 1;
	do j = hcscnt + 1 to i while (i >= j);
	     out = namef_$no_comp (baseptr (j), odsp);
	     call expand_path_ (addr (out), length (out), addr (dir_name), addr (name2), bcode);
	     if name2 = enname then return (j);
	end;
bad_name:	call ioa_ ("^a not found", rtrim (enname));
	return (-1);

p_valid:	entry (p_ptr) returns (bit (1));
	b_ret = "1"b;
	if baseno (p_ptr) = "077777"b3 then		/* if null ptr */
	     return ("0"b);				/* return */
	if p_ptr -> its.mod then
	     return ("0"b);
	go to val_com;
val_ptr:	entry (p_ptr) returns (char (16) aligned);
dcl  p_ptr ptr;
dcl  va_ptr ptr;
dcl  b_ret bit (1);
dcl  ppasbit bit (72) based (p_ptr);
dcl  pasbit bit (72) based (addr (va_ptr));
dcl  illbitof bit (72) int static options (constant) init ("777777777777777777077000"b3);
dcl  valdt char (16) aligned;
	valdt = "";
	b_ret = "0"b;
val_com:
	if p_ptr -> its.its_mod ^= "100011"b then
	     if b_ret then
		return ("0"b);
	     else return ("Invalid");
	else if b_ret then
	     return ("1"b);
	pasbit = ppasbit & illbitof;			/* copy  and and out illegal bits in ptr */
	call ioa_$rsnnl ("^p", valdt, j, va_ptr);
	return (valdt);

/* output_mode - entry to determine  long/short output mode based on terminal or file line length */

output_mode: entry returns (bit (1));

dcl  oml fixed bin;
	oml = get_line_length_$switch (null, bcode);	/* find terminal line length */
	if oml < 118 & bcode = 0 then			/* if ll < 118 and not a file */
	     return ("0"b);				/* 4 words / line */
	else return ("1"b);				/* 8 words / line */

/*  */

/* dump_oct - entry to display words in octal depending on line length */

dump_oct:	entry (dmp, doffset, nwds);

dcl (dmp, pp, tp) ptr;
dcl (doffset, poffset) fixed bin (18);
dcl (ln, opl, mod8, div8, nwds) fixed bin;
dcl (lo, nprt, pequal) bit (1);
dcl  w (0 : 7) fixed bin based (pp);
dcl  wab bit (8 * 36) based;
dcl  vfmt char (184) int static options (constant) init
    ("^6o ^6o^[ ^w^;^2( ^w^)^;^3( ^w^)^;^4( ^w^)^;^4( ^w^)^[^2s^;^/^6o ^6o^] ^w^;^4( ^w^)^[^2s^;^/^6o ^6o^]^2( ^w^)^;^4( ^w^)^[^2s^;^/^6o ^6o^]^3( ^w^)^;^4( ^w^)^[^2s^;^/^6o ^6o^]^4( ^w^)^]");

	lo = output_mode ();			/* find terminal line length */
	div8 = divide (nwds - 1, 8, 17, 0);		/* find out how many full lines to dump */
	mod8 = 8;
	pp = dmp;
	tp = null;
	poffset = doffset;
	opl = doffset + nwds;
	nprt, pequal = "0"b;

	do i = 0 by 8 while (poffset < opl);
	     if nprt then				/* if last line was not printed */
		pequal = "1"b;
	     if tp ^= null then			/* if not first line */
		if tp -> wab = pp -> wab then		/* and if last line iss equal to this line */
		     nprt = "1"b;			/* then don't print it */
		else nprt = "0"b;			/* else print the line */
	     if pequal & (^nprt | div8 = 0) then do;	/* if we have skipped n lines print a string of "=" */
		pequal = "0"b;
		call ioa_ ("^7x========");
	     end;
	     if ^nprt | div8 = 0 then do;		/* if we wandt to print line or if last line */
		if div8 = 0 then
		     mod8 = mod (nwds, 8);
		if mod8 = 0 then
		     mod8 = 8;
		call ioa_ (vfmt, poffset, i, mod8, w (0), w (1), w (2), w (3), lo,
		     poffset + 4, i + 4, w (4), w (5), w (6), w (7));
	     end;
	     tp = pp;				/* copy current line pointer for equal line compare */
	     pp = addrel (pp, 8);			/* increment to nxt line */
	     poffset = poffset + 8;
	     div8 = div8 - 1;
	end;
	return;

/*  */

% include bos_dump;
% include its;
% include sdw;
% include stack_header;
% include stack_frame;
% include db_arg_list;
% include signaller_stack;
     end ol_dump_util_;




		    ol_dump_why_.pl1                11/10/82  1713.3rew 11/10/82  0916.7      108468



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */

ol_dump_why_: proc (odsp);

/* Completed for installation May 1982 by Rich Coppola from source provided
   by Dave Kitson */
/* Modified Oct 1982 by Rich Coppola to have it set ol_dump_struc.dbrsv before
   returning to ol_dump.
*/

%include ol_dump_struc;
%page;


dcl  ioa_ entry options (variable);
dcl  display_stack_ entry (ptr);
dcl  display_process_$apt entry (ptr);
dcl  display_regs_$mcprds entry (ptr);
dcl  display_regs_$mcpds entry (ptr);

dcl  ol_dump_util_$get_ptr entry (fixed bin, ptr, fixed bin (35), ptr);
dcl  ol_dump_util_$fnd_dbr entry (fixed bin (24), fixed bin (35), fixed bin, ptr);
dcl  ol_dump_util_$get_ptr_given_dbr entry (fixed bin (24), fixed bin, ptr, fixed bin (35), ptr);
dcl  ring0_get_$segptr_given_slt entry (char (*) aligned, char (*) aligned,
     ptr, fixed bin (35), ptr, ptr);
dcl  ring0_get_$definition_given_slt entry (ptr, char (*), char (*), fixed bin (18),
     fixed bin, fixed bin (35), ptr, ptr, ptr);

dcl (tagp, prdsp, scsp, sdatap, fdatap, pdsp, stpp) ptr;
dcl  missed_one bit (1) init ("0"b);
dcl  lg_sw bit (1);
dcl  fnd bit (1);
dcl  ltags (0:7) char (1) init ("A", "B", "C", "D", "E", "F", "G", "H");
dcl (new_dbr, dbr) fixed bin (24);
dcl  cur fixed bin;
dcl  bgn fixed bin;
dcl  ok bit (1);
dcl  tag fixed bin (3) based (tagp);
dcl  segn fixed bin ;
dcl  def_offset fixed bin (18);
dcl (segln, code) fixed bin (35);
dcl  type fixed bin;
dcl  stpw bit (36);
dcl 1 stpw2 based (addr (stpw)),
    2 ho bit (33),
    2 lo bit (3);
dcl  stp bit (36) based (stpp);
dcl  saved_dbr fixed bin (24);
dcl  i fixed bin;
dcl  cioc bit (9) init ("000001101"b);
dcl  dis bit (9) init ("110001110"b);
dcl  tra bit (9) init ("111001000"b);
dcl 1 ev_inst based (addr (scu.even_inst)),
    2 pad1 bit (18) unal,
    2 opcode bit (9) unal,
    2 pad2 bit (9) unal;
dcl 1 od_inst based (addr (scu.odd_inst)),
    2 pad1 bit (18) unal,
    2 opcode bit (9) unal,
    2 pad2 bit (9) unal;

dcl  null builtin;

%page;

	if argcnt >1 | (argcnt = 1 & arg (1) ^= "lg") then do;
	     call ioa_ ("^a", " why {lg}");
	     return;
	end;

	new_dbr = -1;

	if argcnt = 1 & arg (1) = "lg" then lg_sw = "1"b;
	else lg_sw = "0"b;
	call ol_dump_util_$fnd_dbr (fixed (addr (aptap -> apte.dbr) -> sdw.add, 24), segln, i, odsp);

	new_dbr = fixed (addr (aptap -> apte.dbr) -> sdw.add, 24);
	call ring0_get_$segptr_given_slt ("", "flagbox", fgbxp, code,
	     ol_dump_struc.sltptr, ol_dump_struc.sltnp);

	segn = fixed (baseno (fgbxp));

	call ol_dump_util_$get_ptr (segn, fgbxp, segln, odsp);

	if fgbxp = null then call ioa_ ("Unable to get message");
	else do;
	     if fgbx.rtb.mess then call ioa_ ("^a ^a  ",
	        ":::::::::::: CRASH MESSAGE   ", fgbx.message);
	     else call ioa_ (":::::::::::: NO CRASH MESSAGE ::::::::::::");
	end;

	call ring0_get_$segptr_given_slt ("", "scs", scsp, code,
	     ol_dump_struc.sltptr, ol_dump_struc.sltnp);

	call ring0_get_$definition_given_slt (null, "scs", "sys_trouble_pending",
	     def_offset, type, code, ol_dump_struc.sltptr, ol_dump_struc.sltnp, ol_dump_struc.defptr);
	segn = fixed (baseno (scsp));
	call ol_dump_util_$get_ptr (segn, scsp, segln, odsp);

	if scsp = null then do;
	     call ioa_ ("Can't get SCS segment");
	     go to CLEANUP;
	end;
	stpp = addrel (scsp, def_offset);
	stpw = stp;
	if stpw2.ho = "77777777777"b3 then call fimfault;
	else call notfimfault;

CLEANUP:

	ol_dump_struc.dbrsv = new_dbr;
	return;
%page;
fimfault:	proc;

	     cur = 0;
	     fnd = "0"b;
	     saved_dbr = ol_dump_struc.dbrsv;
	     bgn = 0;
	     do while (cur < ol_dump_struc.no_apt & fnd ^= "1"b);
		call get_running (bgn, cur, ok);
		if ok then do;
		     call ring0_get_$definition_given_slt (null, "prds", "processor_tag",
		        def_offset, type, code, ol_dump_struc.sltptr,
		        ol_dump_struc.sltnp, ol_dump_struc.defptr);
		     tagp = addrel (prdsp, def_offset);
		     call ring0_get_$definition_given_slt (null, "prds",
			"sys_trouble_data", def_offset, type, code, sltptr,
		        ol_dump_struc.sltnp, ol_dump_struc.defptr);
		     mcp = addrel (prdsp, def_offset);
		     scup = addr (mc.scu (0));

		     if lo = "1"b3 then do;
			call ioa_ ("^/^a ^a", ":::::::::::: RUNNING ON CPU ", ltags (tag));
			arg (1) = "systroub";
			argcnt = 1;
			call display_regs_$mcprds (odsp);
		     end;

		     else if lo = "2"b3 then do;
			if ev_inst.opcode = (cioc & od_inst.opcode = dis)
			| ev_inst.opcode = (cioc & od_inst.opcode = tra)
			then do;
			     call ioa_ ("^/^a ^a", ":::::::::::: ON CPU ", ltags (tag));
			     arg (1) = "systroub";
			     arg (2) = "lg";
			     if lg_sw then argcnt = 2;
			     else argcnt = 1;
			     call display_regs_$mcprds (odsp);
			     fnd = "1"b;
			end;
		     end;

		     else if lo = "3"b3 then do;
			if ev_inst.opcode = (cioc & od_inst.opcode = dis)
			| ev_inst.opcode = (cioc & od_inst.opcode = tra)
			then do;
			     call ioa_ ("^/^a ^a", ":::::::::::: ON CPU ", ltags (tag));
			     arg (1) = "fim";
			     arg (2) = "lg";
			     if lg_sw then argcnt = 2;
			     else argcnt = 1;
			     call display_regs_$mcpds (odsp);
			     fnd = "1"b;
			end;
		     end;

		     else if (lo >"3"b3) & (lo <"7"b3) | lo = "0"b3 then do;
			if ev_inst.opcode = (cioc & od_inst.opcode = dis)
			| ev_inst.opcode = (cioc & od_inst.opcode = tra)
			then do;
			     call ioa_ ("^/^a ^a", ":::::::::::: ON  CPU ", ltags (tag));
			     call ol_dump_util_$get_ptr (pdsseg, pdsp, segln, odsp);
			     call ring0_get_$definition_given_slt (null, "pds",
			        "fim_data", def_offset, type,
				code, sltptr, sltnp, defptr);
			     fdatap = addrel (pdsp, def_offset);
			     call ring0_get_$definition_given_slt (null, "pds",
			        "signal_data", def_offset, type, code, sltptr, sltnp, defptr);
			     sdatap = addrel (pdsp, def_offset);
			     if fdatap -> fault_time >sdatap -> fault_time then arg (1) = "fim";
			     else arg (1) = "sig";
			     arg (2) = "lg";
			     if lg_sw then argcnt = 2;
			     else argcnt = 1;
			     call display_regs_$mcpds (odsp);
			     fnd = "1"b;
			end;
		     end;

		     else if lo = "7"b3 then do;
			if ev_inst.opcode = (cioc & od_inst.opcode = dis)
			| ev_inst.opcode = (cioc & od_inst.opcode = tra)
			then do;
			     call ioa_ ("^/^a ^a", ":::::::::::: ON CPU ", ltags (tag));
			     arg (1) = "pgflt";
			     arg (2) = "lg";
			     if lg_sw then argcnt = 2;
			     else argcnt = 1;
			     call display_regs_$mcpds (odsp);
			     fnd = "1"b;
			end;
		     end;
		     bgn = cur;
		end;
	     end;

	     if ^fnd then
		if missed_one then
	        call ioa_ ("^a", ":::::::::::: COULD NOT GET ALL RUNNING PROCESSES");
	end;
%page;

get_running: proc (first, nxt, got_one);
dcl (first, nxt, i, j) fixed bin;
dcl  got_one bit (1);

	     got_one = "0"b;
	     do i = first to ol_dump_struc.no_apt-1;
		aptep = addrel (aptap, i*ol_dump_struc.apt_entry_size);
		if (apte.state = "000001"b3) | (apte.flags.dbr_loaded) then do;
		     sdwp = addr (aptep -> apte.dbr);
		     call ol_dump_util_$get_ptr_given_dbr (fixed (sdw.add, 24), ol_dump_struc.prdsseg,
			prdsp, segln, odsp);

		     if prdsp = null then do;
			missed_one = "1"b;
			goto next;
		     end;

		     nxt = i+1;
		     dbr = fixed (sdw.add, 24);
		     call ol_dump_util_$fnd_dbr (dbr, segln, i, odsp);
		     new_dbr = fixed (addr (aptap -> apte.dbr) -> sdw.add, 24);
		     if i = -1 then goto next ;
		     else got_one = "1"b;
		     call ol_dump_util_$get_ptr (ol_dump_struc.kstseg, ol_dump_struc.kstptr,
			segln, odsp);
		     return;
		end;
next:
	     end;
	     nxt = i+1;
	end;

%page;
notfimfault: proc;

dcl  nprocs fixed bin;
dcl  j fixed bin;
dcl  nprocessors fixed bin based (np);
dcl 1 proc_info (0:7),
    2 stptr ptr,
    2 dbrp fixed bin (24);

dcl  np ptr;
dcl  ptag fixed bin;
dcl  ftime bit (54);
dcl  clckfnd bit (1) init ("0"b);
dcl  i fixed bin;
dcl  conlock bit (36) based (conlockp);
dcl  conlockp ptr;

	     do i = 0 to 7;
		proc_info (i).stptr = null;
	     end;

	     call ring0_get_$definition_given_slt (null, "scs", "connect_lock", def_offset,
		type, code, ol_dump_struc.sltptr, ol_dump_struc.sltnp, ol_dump_struc.defptr);

	     conlockp = addrel (scsp, def_offset);
	     do j = 0 to ol_dump_struc.no_apt-1;
		aptep = addrel (aptap, j*ol_dump_struc.apt_entry_size);
		if apte.processid = "000000000000"b3 then goto next1;
		if (apte.processid = conlock)| (apte.state = "000001"b3) |
		   (apte.flags.dbr_loaded) then do;
		     sdwp = addr (aptep -> apte.dbr);
		     call ol_dump_util_$get_ptr_given_dbr (fixed (sdw.add, 24),
		        ol_dump_struc.prdsseg, prdsp, segln, odsp);

		     if prdsp = null then do;
			if conlock = apte.processid then do;
			     call ioa_ ("Can't find proc that did it.");
			     return;
			end;
			else goto next1;
		     end;

		     call ring0_get_$definition_given_slt (null, "prds", "processor_tag", def_offset,
			type, code, ol_dump_struc.sltptr, ol_dump_struc.sltnp, ol_dump_struc.defptr);
		     tagp = addrel (prdsp, def_offset);
		     dbr = fixed (sdw.add, 24);
		     call ol_dump_util_$fnd_dbr (dbr, segln, i, odsp);
		     new_dbr = fixed (addr (aptap -> apte.dbr) -> sdw.add, 24);
		     if i = -1 then do;
			if conlock = apte.processid then do;
			     call ioa_ ("Can't get process that did it.");
			     return;
			end;
			else goto next1;
		     end;

		     dbr = fixed (sdw.add, 24);
		     call ol_dump_util_$get_ptr (ol_dump_struc.kstseg, ol_dump_struc.kstptr, segln, odsp);
		     if conlock = apte.processid then do;
			clckfnd = "1"b;
			call ioa_ ("^/::::::::::::  CALL TO BOS BY  ::::::::::::^/");
			odsp -> argcnt = 1;
			odsp -> arg (1) = "cur";
			call display_process_$apt (odsp);
			odsp -> arg (1) = "ring";
			odsp -> arg (2) = "0";
			odsp -> arg (3) = "args";
			if lg_sw then argcnt = 3;
			else argcnt = 2;
			call ioa_ ("^/::::::::::::::: RING 0 STACK TRACE :::::::::::::::^/");
			call display_stack_ (odsp);
			return;
		     end;

		     if conlock = "000000000000"b3 then do;
			call ring0_get_$definition_given_slt (null, "prds",
			   "sys_trouble_data", def_offset, type, code,
			   ol_dump_struc.sltptr, ol_dump_struc.sltnp,
			   ol_dump_struc.defptr);
			proc_info (tag).stptr = addrel (prdsp, def_offset);
			proc_info (tag).dbrp = dbr;
		     end;
		end;
next1:
	     end;

	     if conlock then do;
		if ^clckfnd then call ioa_ ("^a ^w",
		   ":::::::::::: CANNOT FIND THE CALLING PROCESS ", (conlock));
	     end;

	     if conlock = "000000000000"b3 then do;
		ftime = "777777777777777777"b3;
		call ring0_get_$definition_given_slt (null, "scs", "nprocessors", def_offset,
		     type, code, ol_dump_struc.sltptr, ol_dump_struc.sltnp, ol_dump_struc.defptr);

		np = addrel (scsp, def_offset);
		nprocs = 0;

		do i = 0 to 7;
		     if proc_info (i).stptr ^= null then do;
			nprocs = nprocs + 1;
			if proc_info (i).stptr -> fault_time < ftime then ptag = i;
			ftime = proc_info (i).stptr -> fault_time;
		     end;
		end;

		dbr = proc_info (ptag).dbrp;
		call ol_dump_util_$fnd_dbr (dbr, segln, i, odsp);
		new_dbr = fixed (addr (aptap -> apte.dbr) -> sdw.add, 24);
		call ol_dump_util_$get_ptr (ol_dump_struc.kstseg, ol_dump_struc.kstptr, segln, odsp);
		if nprocs ^= nprocessors then call ioa_ ("^/^a^/",
		   "COULD NOT GET ALL RUNNING PROCESSES, BEST GUESS IS");
		call ioa_ ("^a",
		   ":::::::::::: PROCESS THAT CRASHED ::::::::::::");
		arg (1) = "cur";
		argcnt = 1;
		call display_process_$apt (odsp);
		arg (1) = "ring";
		arg (2) = "0";
		arg (3) = "args";
		if lg_sw then argcnt = 3;
		else argcnt = 2;
		call ioa_ ("^/:::::::::::: RING _ STACK TRACE ::::::::::::");
		call display_stack_ (odsp);
	     end;
	end;

%page;
%include sdw;
%page;
%include apte;
%page;
%include fgbx;
%page;
%include mc;

  end ol_dump_why_;




		    pds_trace_.pl1                  11/10/82  1713.3rew 11/10/82  0917.0       59085



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */

/* Completed for installation May 1982 by Rich Coppola from source provided
   by Dave Kitson */
/* Modified October 1982 by Jim Homan to handle trace wraparound, give correct
   offsets for pages faulted on, remove unnecessary rtrims and ltrims */

pds_trace_: proc (odsp);


%include ol_dump_struc;
%page;

/* external entries */

	dcl     ioa_		 entry options (variable);
	dcl     ol_dump_util_$get_ptr	 entry (fixed bin, ptr, fixed bin (35), ptr);
	dcl     ring0_get_$definition_given_slt entry (ptr, char (*), char (*), fixed bin (18),
				 fixed bin, fixed bin (35), ptr, ptr, ptr);
	dcl     namef_$no_comp	 entry (ptr, ptr) returns (char (*));
	dcl     namef_		 entry (ptr, ptr) returns (char (*));
	dcl     decode_clock_value_$date_time entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin,
				 fixed bin, fixed bin, fixed bin (71), fixed bin, char (3),
				 fixed bin (35));


/* Based */

	dcl     1 trace_entry	 based (tr_ptr) like page_trace_entry;
	dcl     1 ext_trace_entry	 based (tr_ptr) like extended_page_trace_entry;
	dcl     cond		 char (4) based (addr (trace_entry.pad));
	dcl     pp		 ptr unal based (addr (trace_entry));
	dcl     1 ptr		 based (addr (trace_entry)),
		2 pseg		 bit (18),
		2 poff		 bit (18);

/* Constant */

	dcl     DAY		 (7) char (3) int static options (constant) init
				 ("Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun");

/* Automatic */

	dcl     (code, segln)	 fixed bin (35);
	dcl     (type, Seg, i, len)	 fixed bin;
	dcl     (psegn, poffn, segn)	 char (12) aligned;
	dcl     (entryp, tr_ptr, pdsp) ptr;
	dcl     def_offset		 fixed bin (18);
	dcl     tsr_segno		 fixed bin (12);
	dcl     (trace_time, usec)	 fixed bin (71);
	dcl     (month, dom, year, hour, minute, second, dow) fixed bin;
	dcl     zone		 char (3) init ("");
	dcl     null		 builtin;
	dcl     count		 fixed bin;
	dcl     total		 fixed bin;
	dcl     start_index		 fixed bin;
	dcl     next		 fixed bin;
%page;
	count = 0;

	if argcnt > 1 | (argcnt = 1 & verify (arg (1), "0123456789") ^= 0) then do;
		call ioa_ ("Usage is: pds_trace {N}");
		return;
	     end;
	if argcnt = 1 then
	     count = fixed (arg (1), 18);

	call ol_dump_util_$get_ptr (pdsseg, pdsp, segln, odsp);
	if pdsp = null then do;
		call ioa_ ("^a", "Unable to get PDS for this process.");
		return;
	     end;

	call ring0_get_$definition_given_slt (null, "pds", "trace", def_offset,
	     type, code, sltptr, sltnp, defptr);

	trace_ptr = addrel (pdsp, def_offset);

	trace_time = trace.ttime;
	call decode_clock_value_$date_time (trace.ttime, month, dom, year, hour, minute,
	     second, usec, dow, zone, code);



	call ioa_ ("^3xTIME^14tmost recent first (AT ^2d/^2d/^4d ^d.^d.^d.^d ^a ^a)^/",
	     month, dom, year, hour, minute, second, usec, zone, DAY (dow));



	total = fixed (trace.last_available, 17);
	next = fixed (trace.next_free, 17);
	if count = 0 then /* do all valid entries */
	     count = hbound (trace.data, 1);

	if count > next
	then start_index = total + next - count + 1;
	else start_index = next - count + 1;


	do i = next to 1 by -1 while (count > 0), total to start_index by -1 while (count > 0);

	     count = count - 1;
	     tr_ptr = addr (trace.data (i));

	     trace_time = trace_time - fixed (trace_entry.time, 17);

	     zone = "";
	     call decode_clock_value_$date_time (trace_time, month, dom, year, hour, minute,
		second, usec, dow, zone, code);

	     if trace_entry.type = 0 then
		call ioa_ ("^d.^d.^d^14tring ^1d: page fault on segment ^5o page #^o^/^17t ^a",
		     minute, second, usec, trace_entry.ring, trace_entry.segment_number,
		     trace_entry.page_number,
		     namef_ (pointer (baseptr (trace_entry.segment_number), 1024 * trace_entry.page_number), odsp));

	     else if trace_entry.type = 2 then
		call ioa_ ("^d.^d.^d^14tsegfault start on seg ^5o^/^17t^a",
		     minute, second, usec, trace_entry.segment_number,
		     namef_$no_comp (baseptr (trace_entry.segment_number), odsp));

	     else if trace_entry.type = 3 then
		call ioa_ ("^d.^d.^d^14tsegfault end on seg ^5o",
		     minute, second, usec, trace_entry.segment_number,
		     namef_$no_comp (baseptr (trace_entry.segment_number), odsp));

	     else if trace_entry.type = 4 then do;
		     if trace_entry.pad = "0"b then
			call ioa_ ("^d.^d.^d^14tlinkage fault make-entry", minute, second, usec);
		     else
			call ioa_ ("^d.^d.^d^14tlinkage fault by ^6o|^o^/^17t^a", minute, second, usec,
			     pseg, poff, namef_ ((pp), odsp));
		end;

	     else if trace_entry.type = 5 then do;
		     call ioa_ ("^d.^d.^d^14tlink resolved to ^6o|^o^/^17t^a", minute, second, usec,
			pseg, poff, namef_ ((pp), odsp));
		end;

	     else if trace_entry.type = 6 then
		call ioa_ ("^d.^d.^d^14tboundsfault start on ^5o^/^17t^a", minute, second, usec,
		     trace_entry.segment_number,
		     namef_$no_comp (baseptr (trace_entry.segment_number), odsp));

	     else if trace_entry.type = 7 then
		call ioa_ ("^d.^d.^d^14tboundsfault end", minute, second, usec);

	     else if trace_entry.type = 8 then
		call ioa_ ("^d.^d.^d^14tsignaller for condition '^a'", minute, second, usec, cond);

	     else if trace_entry.type = 9 then
		call ioa_ ("^d.^d.^d^14trestart fault", minute, second, usec);

	     else if trace_entry.type = 10 then
		call ioa_ ("^d.^d.^d^14treschedule", minute, second, usec);

	     else if trace_entry.type = 11 then
		call ioa_ ("^d.^d.^d^14tmarker", minute, second, usec);

	     else if trace_entry.type = 12 then
		call ioa_ ("^d.^d.^d^14tinterrupt", minute, second, usec);

	     else if trace_entry.type = 15 then do;
		     tsr_segno = bin (ext_trace_entry.tsr_segno_1 ||
			ext_trace_entry.tsr_segno_2, 12);
		     
		     call ioa_ ("^d.^d.^d^14tpage fault by ^4o|^o referencing ^4o page #^o^/^17t^a^/^17treferencing ^a",
			minute, second, usec, ext_trace_entry.psr_segno,
			ext_trace_entry.psr_offset, tsr_segno,
			ext_trace_entry.tsr_pageno,
			namef_ (addrel (baseptr (ext_trace_entry.psr_segno),
		        ext_trace_entry.psr_offset), odsp),
			namef_ (addrel (baseptr (tsr_segno),
		        1024 * ext_trace_entry.tsr_pageno), odsp));
		end;

	     else call ioa_ ("unknown trace type");

	end;
	return;


%page;
%include sys_trace;
%page;
%include trace_types;
     end pds_trace_;




		    process_dump_segments.pl1       09/24/84  0855.7rew 09/21/84  1505.1      446940



/* ***********************************************************
   *                                                         *
   * 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 */
process_dump_segments:
     proc (dump_ptrs, slt_ptr, definitions_ptr, nametbl_ptr, num_events, delta_time, long_report);



/* Routine to scan an FDUMP for interesting time-stamped events,
   sort these events by time (reverse order), and print them.

   The following events are considered as interesting:

   Machine Conditions (from BOS, prds, pds, mc_trace_buf)

   Traffic Control State Change Time

   Syserr Messages (from both syserr_data and syserr_log)

   Fim Frames in any stack

   Connects by device

   Disk queues (long report only)

   An array of pointers to FDUMP is passed as a parameter--this array
   is in order by FDUMP component (0, 1, 2, ...).  Also passed
   are pointers to copies of certain segments from the FDUMP (these
   are not within the FDUMP itself, but copied from it.

   Written March 1981 by J. Bongiovanni
   Modified April 1981 by Rich Coppola to add expanded path name/rel offset
   Modified July 1981 by J. Bongiovanni to add connects by device
   Modified January 1982 by J. Bongiovanni to add disk queues, mc_trace_buf
   Modified May 1982 by Rich Coppola for new ASTE
   Modified July 1982 by J. Bongiovanni for new time format in disk Q
   Modified May 1984 by T. Oke for new free disk queue.
   Modified May 1984 by T. Oke for adaptive optimization mods to disk queue.
*/


/* Parameter */

dcl  dump_ptrs (*) ptr;				/* pointers to FDUMP components		*/
dcl  slt_ptr ptr;					/*  copy of SLT from FDUMP			*/
dcl  definitions_ptr ptr;				/* copy of definitions from FDUMP		*/
dcl  nametbl_ptr ptr;				/* copy of Name Table from FDUMP		*/
dcl  num_events fixed bin;				/* number of events to print			*/
dcl  delta_time fixed bin (71);			/* interval of interest in microseconds		*/
dcl  long_report bit (1);				/* ON=>long report format, OFF=>1 line/event	*/





/* Automatic */

dcl  apt_array_p ptr;
dcl  apt_inx fixed bin;
dcl  apt_proc_found bit (1);
dcl  bmp ptr init (null);
dcl  bound_interceptors_ptr ptr;
dcl  code fixed bin (35);
dcl  cur_date_time char (17);
dcl  diskq_datap ptr;
dcl  dom fixed bin;
dcl  DOM pic "99";
dcl  dow fixed bin;
dcl  dump_seginx fixed bin;
dcl  dump_segno fixed bin;
dcl  earliest_recorded_time fixed bin (71);
dcl  earliest_time fixed bin (71);
dcl  event_inx fixed bin;
dcl  eventsp ptr;
dcl  first_print bit (1);
dcl  hr fixed bin;
dcl  HR pic "z9";
dcl  1 interesting_segs (N_INTERESTING_SEGS) aligned,
       2 segname char (32) unal
	  init ("prds", "pds", "tc_data", "syserr_data", "scs", "inzr_stk0", "iom_data", "disk_seg", "pvt", ""),
       2 segno fixed bin (18) init ((N_INTERESTING_SEGS) - 1),
       2 handler entry (ptr, bit (1) aligned) variable
	  init (process_prds, process_pds, process_tc_data, process_syserr_data, setup_from_scs, process_inzr_stk0,
	  process_iom_data, process_disk_queue, copy_pvt, process_mc_trace_buf),
       2 process_this_seg bit (1) init ((N_INTERESTING_SEGS) (1)"1"b);
dcl  last_date_time char (17);
dcl  last_sec fixed bin;
dcl  last_segno fixed bin;
dcl  micsec fixed bin (71);
dcl  MICSEC pic "999999";
dcl  minute fixed bin;
dcl  MIN pic "99";
dcl  mon fixed bin;
dcl  MON pic "99";
dcl  max_events fixed bin;
dcl  prds_processor bit (8) unal;
dcl  proc_no fixed bin;
dcl  process_number fixed bin;
dcl  sec fixed bin;
dcl  SEC pic "99";
dcl  seg_found bit (1);
dcl  seginx fixed bin;
dcl  segp ptr;
dcl  sortp ptr;
dcl  sortinx fixed bin;
dcl  sortinx1 fixed bin;
dcl  sortinxt fixed bin;
dcl  stack_found bit (1);
dcl  stack_inx fixed bin;
dcl  stack_segs (0:7) fixed bin;
dcl  temp_alloc_p ptr;
dcl  temp_seg_data_p ptr init (null ());
dcl  tsegp ptr;
dcl  words_copied fixed bin (18);
dcl  yr fixed bin;
dcl  YR pic "99";


/* Static */

dcl  CPU_TAG char (8) init ("abcdefgh") int static options (constant);
dcl  IOM_TAG char (4) init ("ABCD") int static options (constant);
dcl  MYNAME char (21) init ("process_dump_segments") int static options (constant);
dcl  N_INTERESTING_SEGS fixed bin init (10) int static options (constant);
dcl  MC_TRACE_BUF fixed bin init (10) int static options (constant);
						/* Index of mc_trace_buf */
dcl  Q_TIME_MOD fixed bin (71) init (1000000000000000000000000000000000000b) int static options (constant);


/* Based */

dcl  1 temp_seg_data aligned based (temp_seg_data_p),	/* info on temp segs allocated 		*/
       2 n_temp_segs fixed bin,			/* number temp segs allocated this way		*/
       2 temp_segp (0 refer (n_temp_segs)) ptr;		/* array of pointers to allocated temp segs	*/

dcl  1 time_stamped_events aligned based (eventsp),	/* events of interest from FDUMP		*/
       2 n_events fixed bin,				/* number of events found			*/
       2 events (0 refer (n_events)),
         3 time_stamp fixed bin (71),			/* time of event				*/
         3 delete_on_duplicate_time bit (1),		/* ON => delete this event if time the same as another */
         3 deleted bit (1),				/* ON => this event deleted */
         3 event_struct_ptr ptr,			/* structure of interest to event		*/
         3 event_display entry (char (*), ptr, fixed bin) variable,
						/* routine to print event	*/
         3 process_number fixed bin,			/* process number in FDUMP			*/
         3 apte_offset bit (18),			/* APTE offset or "0"b */
         3 added_info char (40) unal;			/* other data to be printed			*/

dcl  1 apt_array aligned based (apt_array_p),		/* used to translate apte offset to proc number */
       2 n_aptes fixed bin,
       2 apt_desc (0 refer (n_aptes)) aligned,
         3 offset bit (18) unal,			/* offset of apte in tc_data			*/
         3 procn fixed bin (17) unal;			/* process number in FDUMP			*/



dcl  1 diskq_data aligned based (diskq_datap),		/* extract of disk queue/devtab info */
       2 pvtx fixed bin,
       2 sect_sw bit (1),
       2 write_sw bit (1),
       2 coreadd fixed bin (25),
       2 sector fixed bin,
       2 cylinder fixed bin;

dcl  1 indirect_sort_array aligned based (sortp),		/* used for sorting time_stamped_events		*/
       2 sort_index (262144) fixed bin (18);





/* Entry */

dcl  com_err_ entry () options (variable);
dcl  copy_from_dump entry ((*) ptr, fixed bin, fixed bin (18), fixed bin (18), ptr, fixed bin (18), fixed bin (35));
dcl  decode_clock_value_$date_time
	entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (71),
	fixed bin, char (3), fixed bin (35));
dcl  get_bound_seg_info_ entry (ptr, fixed bin (24), ptr, ptr, ptr, fixed bin (35));
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  ioa_ entry () options (variable);
dcl  ioa_$nnl entry () options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  release_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
dcl  ring0_get_$definition_given_slt
	entry (ptr, char (*), char (*), fixed bin (18), fixed bin, fixed bin (35), ptr, ptr, ptr);
dcl  ring0_get_$name_given_slt entry (char (*), char (*), ptr, fixed bin (35), ptr, ptr);
dcl  ring0_get_$segptr_given_slt entry (char (*), char (*), ptr, fixed bin (35), ptr, ptr);


/* External */

dcl  sys_info$max_seg_size fixed bin (18) external;

/* Condition */

dcl  cleanup condition;

/* Builtin */

dcl  addr builtin;
dcl  addrel builtin;
dcl  baseno builtin;
dcl  baseptr builtin;
dcl  bin builtin;
dcl  clock builtin;
dcl  currentisze builtin;
dcl  divide builtin;
dcl  hbound builtin;
dcl  index builtin;
dcl  length builtin;
dcl  mod builtin;
dcl  null builtin;
dcl  ptr builtin;
dcl  rel builtin;
dcl  rtrim builtin;
dcl  size builtin;
dcl  substr builtin;
dcl  unspec builtin;

%page;

/* Initialize temporary segment allocation 							*/

	call get_temp_segment_ (MYNAME, temp_seg_data_p, code);
	if code ^= 0 then do;
	     call com_err_ (code, MYNAME, "Getting temp segment.");
	     return;
	     end;

/* Setup pointers and cleanup handler */

	on cleanup call cleanit;

	dumpptr = dump_ptrs (1);
	sltp = slt_ptr;
	eventsp = allocate_temp_seg ();
	tsegp = allocate_temp_seg ();
	temp_alloc_p = null ();
	pvtp = null ();


/* Find segment numbers of all interesting segments 						*/

	do seginx = 1 to N_INTERESTING_SEGS;
	     if segname (seginx) ^= "" then do;
		call ring0_get_$segptr_given_slt ("", segname (seginx), segp, code, slt_ptr, nametbl_ptr);
		if code = 0
		then interesting_segs.segno (seginx) = bin (baseno (segp), 18);
		else call com_err_ (code, MYNAME, "^a not found in dump", segname (seginx));
		end;
	end;

%page;
	prds_processor = "11111111"b;
	call ring0_get_$segptr_given_slt ("", "bound_interceptors", bound_interceptors_ptr, code, slt_ptr, nametbl_ptr);
	if code ^= 0 then bound_interceptors_ptr = null ();

	do stack_inx = 0 to hbound (stack_segs, 1);
	     stack_segs (stack_inx) = -1;
	end;
	proc_no = 0;
	last_segno = -1;
	earliest_recorded_time = clock ();		/* dump must be earlier than this		*/


	apt_array_p = allocate_temp_seg ();
	apt_array.n_aptes = 0;


/* First event is return to BOS								*/

	if delta_time = 0
	then earliest_time = 0;
	else earliest_time = dump.mctime - delta_time;
	n_events = 0;
	call add_an_event (bin (dump.mctime, 71), addr (dump.scu (0)), print_dump_mc, "RTB Machine Conditions", "0"b,
	     "0"b);

/* Go through segments dumped, building events in event array					*/

	do dump_seginx = 1 to dump.num_segs;
	     dump_segno = bin (dump.segs (dump_seginx).segno, 18);
	     if dump_segno < last_segno		/* new process dumped			*/
	     then do;
		proc_no = proc_no + 1;
		do stack_inx = 0 to hbound (stack_segs, 1);
		     stack_segs (stack_inx) = -1;
		end;
		interesting_segs (MC_TRACE_BUF).process_this_seg = "0"b;
						/* mc tracing is per-process */
		end;
	     last_segno = dump_segno;
	     if dump_segno <= slt.last_sup_seg		/* only hardcore segs are interesting		*/
		| interesting_segs (MC_TRACE_BUF).process_this_seg
						/* unless tracing machine conditions */
	     then do;
		seg_found = "0"b;
		seginx = 1;
		do while (^seg_found & seginx <= N_INTERESTING_SEGS);
		     if dump_segno = interesting_segs.segno (seginx)
		     then seg_found = "1"b;
		     else seginx = seginx + 1;
		end;
		if seg_found & interesting_segs (seginx).process_this_seg then do;
		     call copy_from_dump (dump_ptrs, dump_seginx, 0, sys_info$max_seg_size, tsegp, words_copied, code)
			;			/* copy entire seg to temporary area		*/
		     if code ^= 0 then do;
COPY_ERR:
			call com_err_ (code, MYNAME, "seg index ^d", dump_seginx);
			call cleanit;
			return;
			end;
		     call interesting_segs (seginx).handler (tsegp, interesting_segs (seginx).process_this_seg);
		     end;
		end;
	     stack_found = "0"b;
	     do stack_inx = 0 repeat stack_inx + 1 while (^stack_found & stack_inx <= hbound (stack_segs, 1));
		if stack_segs (stack_inx) = dump_segno then do;
		     call copy_from_dump (dump_ptrs, dump_seginx, 0, sys_info$max_seg_size, tsegp, words_copied, code)
			;
		     if code ^= 0 then goto COPY_ERR;
		     call process_user_stack (stack_inx, tsegp, dump_segno);
		     stack_found = "1"b;
		     end;
	     end;
	end;

/* Now extract messages from the syserr log which are within the interval of
   interest										*/

	call process_syserr_log (earliest_recorded_time, tsegp);


%page;

/* Sort event array by time stamp (tag sort)							*/

	sortp = allocate_temp_seg ();
	do sortinx = 1 to n_events;
	     sort_index (sortinx) = sortinx;
	end;

	do sortinx = 1 to n_events - 1;
	     do sortinx1 = sortinx + 1 to n_events;
		if events (sort_index (sortinx1)).time_stamp > events (sort_index (sortinx)).time_stamp then do;
		     sortinxt = sort_index (sortinx1);	/* swap pointers 				*/
		     sort_index (sortinx1) = sort_index (sortinx);
		     sort_index (sortinx) = sortinxt;
		     end;
		else if events (sort_index (sortinx1)).time_stamp = events (sort_index (sortinx)).time_stamp then do;
		     if events (sort_index (sortinx1)).delete_on_duplicate_time
		     then events (sort_index (sortinx1)).deleted = "1"b;
		     if events (sort_index (sortinx)).delete_on_duplicate_time
		     then events (sort_index (sortinx)).deleted = "1"b;
		     end;
	     end;
	end;

%page;

/* Print the sorted events by calling the print routine for each,
   passing the decoded time value								*/

	first_print = "1"b;
	last_date_time = " ";
	last_sec = -1;
	if num_events = 0
	then max_events = n_events;
	else max_events = min (n_events, num_events);
	do event_inx = 1 to max_events;
	     if ^events (sort_index (event_inx)).deleted then do;
		call decode_clock_value_$date_time (events (sort_index (event_inx)).time_stamp, mon, dom, yr, hr,
		     minute, sec, micsec, dow, "", code);
		if code = 0 then do;
		     MON = mon;
		     DOM = dom;
		     YR = mod (yr, 100);
		     HR = hr;
		     MIN = minute;
		     SEC = sec;
		     MICSEC = micsec;
		     cur_date_time = MON || "/" || DOM || "/" || YR || " " || HR || ":" || MIN;
		     if cur_date_time ^= last_date_time
		     then call ioa_ ("Events from ^a:^a.^a", cur_date_time, SEC, MICSEC);
		     if first_print then do;
			call ioa_ ("^4xTime^2xCPU Proc Event^27xCircumstances^/");
			first_print = "0"b;
			end;
		     last_date_time = cur_date_time;
		     if last_sec = sec
		     then call ioa_$nnl ("  .^6a  ", MICSEC);
		     else call ioa_$nnl ("^2a.^6a  ", SEC, MICSEC);
		     last_sec = sec;


/* Find FDUMP Process Number if necessary */

		     process_number = events (sort_index (event_inx)).process_number;

		     if events (sort_index (event_inx)).apte_offset ^= "0"b then do;
			apt_proc_found = "0"b;
			apt_inx = 1;
			do while (^apt_proc_found & apt_inx <= apt_array.n_aptes);
			     if events (sort_index (event_inx)).apte_offset = apt_array.apt_desc (apt_inx).offset
			     then do;
				apt_proc_found = "1"b;
				process_number = apt_array.apt_desc (apt_inx).procn;
				end;
			     else apt_inx = apt_inx + 1;
			end;
			end;


		     call events (sort_index (event_inx))
			.
			event_display (events (sort_index (event_inx)).added_info,
			events (sort_index (event_inx)).event_struct_ptr, process_number);
		     end;
		end;
	end;


GLOBAL_RETURN:
	call cleanit;
	return;


%page;
/* Internal procedure to add an event to the structure if its time
   is within the range of interest								*/


add_an_event:
     proc (etime, eptr, eroutine, eadded_info, delete_duplicate, apte_offset);


dcl  etime fixed bin (71);				/* time of event				*/
dcl  eptr ptr;					/* pointer to event structure			*/
dcl  eroutine entry (char (*), ptr, fixed bin) variable;	/* routine to print event			*/
dcl  eadded_info char (*);				/* clear-text info of interest		*/
dcl  delete_duplicate bit (1) aligned;			/* ON => delete this event if duplicate times */
dcl  apte_offset bit (18);				/* APTE offset or "0"b */


	if etime < earliest_time then return;
	n_events = n_events + 1;
	events (n_events).time_stamp = etime;
	events (n_events).event_struct_ptr = eptr;
	events (n_events).event_display = eroutine;
	events (n_events).added_info = eadded_info;
	events (n_events).process_number = proc_no;
	events (n_events).apte_offset = apte_offset;
	events (n_events).deleted = "0"b;
	events (n_events).delete_on_duplicate_time = delete_duplicate;

	if etime < earliest_recorded_time & etime ^= 0 then earliest_recorded_time = etime;

     end add_an_event;






%page;


/* Internal Procedure to allocate an additional temporary segment,
   and return a pointer to same								*/


allocate_temp_seg:
     proc returns (ptr);

	call get_temp_segment_ (MYNAME, temp_segp (n_temp_segs + 1), code);
	if code ^= 0 then do;
	     call com_err_ (code, MYNAME, "Getting temp seg.");
	     goto GLOBAL_RETURN;
	     end;

	n_temp_segs = n_temp_segs + 1;

	return (temp_segp (n_temp_segs));


     end allocate_temp_seg;


%page;

/* Internal Procedure for Cleanup								*/


cleanit:
     proc;

dcl  rcode fixed bin (35);

	if temp_seg_data_p ^= null () then do;
	     if n_temp_segs > 0 then call release_temp_segments_ (MYNAME, temp_segp, rcode);
	     call release_temp_segment_ (MYNAME, temp_seg_data_p, rcode);
	     temp_seg_data_p = null ();
	     end;


     end cleanit;

%page;
/* Internal Procedure to copy the PVT to a temporary segment. This
   is necessary to print some of the interesting stuff about disk
   queues
*/

copy_pvt:
     proc (temp_pvt_ptr, process_it);

dcl  temp_pvt_ptr ptr;
dcl  process_it bit (1) aligned;


	process_it = "1"b;				/* Only copy PVT once */
	pvtp = temp_pvt_ptr;			/* That wasn't too hard */
	temp_pvt_ptr = allocate_temp_seg ();

     end copy_pvt;

%page;

/* Internal Procedure to copy a part of a segment to a temporary segment.
   Additional temporary segments are allocated as necessary, and a pointer
   to the copy is returned									*/


copy_to_temporary:
     proc (dptr, dlength) returns (ptr);


dcl  dptr ptr;					/* pointer to part of segment to copy	*/
dcl  dlength fixed bin (18);				/* number of words to copy			*/



dcl  tlength fixed bin (18);
dcl  tptr ptr;
dcl  based_move (tlength) fixed bin (35) aligned based;


	tlength = divide (dlength + 63, 64, 18) * 64;	/* Make modulo 64				*/
	if temp_alloc_p = null ()			/* first time here				*/
	then temp_alloc_p = allocate_temp_seg ();
	else if bin (rel (temp_alloc_p), 18) + tlength > sys_info$max_seg_size then temp_alloc_p = allocate_temp_seg ();

	tptr = temp_alloc_p;
	temp_alloc_p = addrel (temp_alloc_p, tlength);
	tptr -> based_move = dptr -> based_move;
	return (tptr);


     end copy_to_temporary;

%page;

/*   This procedure is used to expand the seg name  */

expand_seg_name:
     proc (seg_name, seg_ptr, offrel, exp_seg_name);

dcl  seg_name char (*);
dcl  seg_ptr ptr;
dcl  offrel fixed bin (18);
dcl  exp_seg_name char (256) var;
dcl  dirname char (168);
dcl  bitcnt fixed bin (24) init (0);
dcl  genp ptr init (null);
dcl  ptrtmp ptr init (null);
dcl  sblkp ptr init (null);
dcl  xcode fixed bin (35) init (0);
dcl  (i, j, k) fixed bin init (0);
dcl  mblen fixed bin init (168);
dcl  ling fixed bin init (0);
dcl  var_str char (ling) based (ptrtmp);


dcl  1 oi_area aligned like object_info;

dcl  1 branch aligned,
       2 type bit (2) unal,
       2 nnames fixed bin (15) unal,
       2 nrp bit (18) unal,
       2 dtm bit (36) unal,
       2 dtu bit (36) unal,
       2 mode bit (5) unal,
       2 pad bit (13) unal,
       2 rec fixed bin (17) unal;





	dirname = ">library_dir_dir>hardcore>execution";

	genp = null;				/* make sure ptr is null */
	call hcs_$initiate_count (dirname, seg_name, "", bitcnt, 0, genp, xcode);
	if genp = null then do;
	     exp_seg_name = seg_name;
	     go to trmnme;
	     end;


	oi_area.version_number = object_info_version_2;
	call get_bound_seg_info_ (genp, bitcnt, addr (oi_area), bmp, sblkp, xcode);
	if xcode ^= 0 then do;
	     exp_seg_name = seg_name;
	     go to trmnme;
	     end;


/* We now have a ptr to the bind map */
	do i = 1 to n_components;
	     j = fixed (bindmap.component (i).text_start, 18);
	     k = fixed (bindmap.component (i).text_lng, 18);
	     if offrel >= j
	     then if offrel < j + k then do;		/* We found a match */
matchp:
		     ptrtmp = addrel (sblkp, bindmap.component (i).name_ptr);
		     ling = fixed (bindmap.component (i).name_lng, 18);
		     call ioa_$rsnnl ("^a$^a|^o", exp_seg_name, mblen, seg_name, var_str, offrel - j);
		     go to trmnme;			/* Go term segment */
		     end;
	     j = fixed (bindmap.component (i).stat_start, 18);
	     k = fixed (bindmap.component (i).stat_lng, 18);
	     if offrel >= j
	     then if offrel < j + k then go to matchp;	/* We found a match */
	     j = fixed (bindmap.component (i).symb_start, 18);
	     k = fixed (bindmap.component (i).symb_lng, 18);
	     if offrel >= j
	     then if offrel < j + k then go to matchp;	/* We found a match */
	end;
	exp_seg_name = seg_name;
trmnme:
	call hcs_$terminate_noname (genp, xcode);
	return;


     end expand_seg_name;


%page;


/* Internal Procedure to build a pointer to a segment name and entry name,
   given a pointer to the base of the segment and the names						*/


get_definition_ptr:
     proc (segname, entryname, base_ptr) returns (ptr);


dcl  segname char (*);				/* name of segment 				*/
dcl  entryname char (*);				/* name of entry into segment			*/
dcl  base_ptr ptr;					/* pointer to base of segment			*/


dcl  basep ptr;
dcl  code fixed bin (35);
dcl  offset fixed bin (18);
dcl  type fixed bin;

	basep = null ();
	call ring0_get_$definition_given_slt (basep, segname, entryname, offset, type, code, slt_ptr, nametbl_ptr,
	     definitions_ptr);
	if code ^= 0 then do;
	     call com_err_ (code, MYNAME, "Cannot find ^a$^a in dump.", segname, entryname);
	     return (null ());
	     end;

	return (ptr (base_ptr, offset));


     end get_definition_ptr;
%page;
/* Internal procedure to return the hardcore segment name given a pointer				*/


get_segment_name:
     proc (seg_ptr, seg_name) returns (bit (1));


dcl  seg_ptr ptr;					/* pointer to segment			*/
dcl  seg_name char (*);

dcl  dname char (168);
dcl  rcode fixed bin (35);

	call ring0_get_$name_given_slt (dname, seg_name, seg_ptr, rcode, slt_ptr, nametbl_ptr);
	if rcode = 0
	then return ("1"b);
	else return ("0"b);

     end get_segment_name;




%page;
/* Internal Procedure to print apte								*/


print_apte:
     proc (added_info, structp, process_n);


dcl  added_info char (*);
dcl  structp ptr;
dcl  process_n fixed bin;


dcl  state_name char (10);
dcl  process_na pic "zz9";




dcl  STATE_NAMES (0:6) char (10) int static options (constant)
	init ("Empty", "Running", "Ready", "Waiting", "Blocked", "Stopped", "ptlocking");
dcl  WAITING fixed bin init (3) int static options (constant);


	aptep = structp;
	if bin (apte.state, 18) > hbound (STATE_NAMES, 1)
	then state_name = "Invalid";
	else state_name = STATE_NAMES (bin (apte.state, 18));

	process_na = process_n;


/* Print the interesting information from the apte						*/


	call ioa_ ("^1a^2x^3a  APTE at ^6o changed to ^a^[ for ^w^;^s^]", substr (CPU_TAG, bin (apte.pr_tag, 3) + 1, 1),
	     process_na, bin (rel (structp), 18), state_name, (bin (apte.state, 18) = WAITING), apte.wait_event);


     end print_apte;
%page;
/* Internal Procedure to print Connect to Device information					*/


print_device_data:
     proc (added_info, structp, process_n);

dcl  added_info char (*);
dcl  structp ptr;
dcl  process_n fixed bin;				/* not meaningful for this data		*/

dcl  1 iom_dev_data aligned like per_device based (structp);

	call ioa_ ("^8xConnect to ^1a ^2d", substr (IOM_TAG, iom_dev_data.iom, 1), iom_dev_data.channel);


     end print_device_data;

%page;
/* Internam Procedure to print Disk Queue information */

print_disk_queue:
     proc (info, dq_data_ptr, process_char);

dcl  info char (*);
dcl  dq_data_ptr ptr;
dcl  process_char char (*);

dcl  dev_num char (2);
dcl  diskadd fixed bin;
dcl  fsx fixed bin;
dcl  p99 pic "99";
dcl  sect_sw bit (1);
dcl  subsys_name char (4);

	diskq_datap = dq_data_ptr;
	if pvtp = null () then do;			/* PVT not in dump - not to worry */
	     subsys_name = "dskX";
	     dev_num = "NN";
	     sect_sw = "1"b;			/* Can't translate to record */
	     diskadd = diskq_data.sector;
	     end;
	else do;
	     pvt_arrayp = addr (pvt.array);
	     pvtep = addr (pvt_array (diskq_data.pvtx));
	     subsys_name = pvte.devname;
	     dev_num = convert (p99, pvte.logical_area_number);
	     sect_sw = diskq_data.sect_sw;
	     if sect_sw
	     then diskadd = diskq_data.sector;
	     else do;
		fsx = pvte.device_type;
		diskadd =
		     diskq_data.cylinder * rec_per_cyl (fsx)
		     + divide (diskq_data.sector - diskq_data.cylinder * sect_per_cyl (fsx), sect_per_rec (fsx), 17);
		end;
	     end;


	call ioa_ ("^8xDisk Queue: ^a_^a: ^[W^;R^] ^[Sec^;Rec^] ^8o Mem ^8o", subsys_name, dev_num, diskq_data.write_sw,
	     sect_sw, diskadd, diskq_data.coreadd);

     end print_disk_queue;


%page;
/* Internal Procedure to print BOS machine conditions						*/


print_dump_mc:
     proc (added_info, structp, process_n);


dcl  added_info char (*);
dcl  structp ptr;
dcl  process_n fixed bin;				/* process number meaningless here		*/


	call print_scu_data (structp, added_info, "   ");


     end print_dump_mc;
%page;


/* Internal Procedure to print machine conditions 						*/

print_mc:
     proc (added_info, structp, process_n);


dcl  added_info char (*);
dcl  structp ptr;
dcl  process_n fixed bin;

dcl  process_na pic "zz9";
dcl  process_num char (3);

	process_na = process_n;
	process_num = process_na;
	call print_scu_data (addr (structp -> mc.scu (0)), added_info, process_num);


     end print_mc;
%page;
/* Internal procedure to extract parameters from syserr_log event for printing				*/

print_syserr_log:
     proc (added_info, structp, process_n);

dcl  added_info char (*);
dcl  structp ptr;
dcl  process_n fixed bin;


dcl  sequence fixed bin (35);
dcl  severity fixed bin;
dcl  textl fixed bin (21);
dcl  textp ptr;


	smess_ptr = structp;
	sequence = smess.seq_num;
	severity = smess.code;
	textl = smess.text_len;
	textp = addr (smess.text);
	call print_syserr_message (sequence, severity, "syserr_log", textl, textp);


     end print_syserr_log;

%page;
/* Internal procedure to print a syserr message							*/

print_syserr_message:
     proc (sequence, severity, log_name, textl, textp);


dcl  sequence fixed bin (35);				/* syserr sequence number			*/
dcl  severity fixed bin;				/* syserr severity code			*/
dcl  log_name char (*);				/* name of log where the message came from	*/
dcl  textl fixed bin (21);				/* length of message is chars			*/
dcl  textp ptr;					/* pointer to text of message			*/


dcl  linel fixed bin (21);
dcl  textl_done fixed bin (21);
dcl  textl_total fixed bin (21);
dcl  trim_eol fixed bin (21);


dcl  1 message based (textp),
       2 pad char (textl_done),
       2 this_line char (linel),
       2 rest char (textl_total - linel - textl_done);


dcl  LINE_MAX_LENGTH fixed bin init (79) int static options (constant);
dcl  TEXT_MAX_LENGTH fixed bin init (200) int static options (constant);


	call ioa_ ("^8xSyserr #^o (^a), severity ^o", sequence, log_name, severity);

	textl_total = min (TEXT_MAX_LENGTH, textl);
	textl_done = 0;
	linel = textl_total;
	if linel <= 0 then return;
	do while (linel > 0);
	     if linel > LINE_MAX_LENGTH then do;
		linel = LINE_MAX_LENGTH;
		trim_eol = index (substr (reverse (this_line), 1, 20), " ");
		linel = linel - trim_eol;
		end;
	     call ioa_ ("^21x^a", this_line);
	     textl_done = textl_done + linel;
	     linel = textl_total - textl_done;
	end;


     end print_syserr_message;
%page;
/* Internal procedure to prepare a syserr message from the wired log for printing			*/

print_wired_syserr:
     proc (added_info, structp, process_n);

dcl  added_info char (*);
dcl  structp ptr;
dcl  process_n fixed bin;

dcl  sequence fixed bin (35);
dcl  severity fixed bin;
dcl  textl fixed bin (21);
dcl  textp ptr;


	wmess_ptr = structp;
	sequence = wmess.seq_num;
	severity = wmess.code;
	textl = wmess.text_len;
	textp = addr (wmess.text);
	call print_syserr_message (sequence, severity, "syserr_data", textl, textp);

     end print_wired_syserr;


%page;
/* Internal procedure to print SCU data from machine conditions					*/

print_scu_data:
     proc (scu_data_ptr, info, process_char);

dcl  scu_data_ptr ptr;				/* pointer to scu data in machine conditions	*/
dcl  info char (*);					/* additional information to print		*/
dcl  process_char char (*);				/* process number printably			*/



dcl  cpu_alph char (1);
dcl  fault_no fixed bin;
dcl  fault_sub_type bit (36);
dcl  hardware_interrupt_level fixed bin;
dcl  hardware_interrupt_no pic "99";
dcl  interrupt_level pic "9";
dcl  interrupt_no fixed bin;
dcl  iom_number char (1);
dcl  line1 char (80) varying;
dcl  line2 char (80) varying;
dcl  ptsr bit (1);
dcl  p_ring pic "9";
dcl  seg_name char (32);
dcl  exp_seg_name char (256) varying;
dcl  seg_valid bit (1);
dcl  sub_type_inx fixed bin;

dcl  SR_IOA_STRING char (50) int static options (constant) init ("^21x^3a ^o|^o^[, ring ^1o^;^s^[ (^a)^;^s^]^]");
dcl  FAULT_TYPES (0:31) char (4) int static options (constant)
	init ("SDF", "STR", "MME", "FT1", "TRO", "CMD", "DRL", "LUF", "CON", "PAR", "IPR", "ONC", "SUF", "OFL", "DIV",
	"EXF", "DF0", "DF1", "DF2", "DF3", "ACV", "MME2", "MME3", "MME4", "FT2", "FT3", "INV", "INV", "INV", "INV",
	"INV", "TRB");
dcl  FAULT_TSR_VALID bit (32) init ("01110111011101101111111111000001"b) int static options (constant);

dcl  FAULT_MASK_INDEX (0:31) fixed bin int static options (constant) init (0, 1, (7) 0, 2, 3, 4, (8) 0, 5, (11) 0);
dcl  FAULT_MASKS (5) bit (21) aligned int static options (constant) init ("4140000"b3,
						/* Store					*/
	"0000030"b3,				/* Parity					*/
	"3600000"b3,				/* Illegal Procedure			*/
	"0000006"b3,				/* Operation Not Complete			*/
	"7777740"b3);				/* Access Violation				*/
dcl  FAULT_SUB_TYPES (5, 21) char (5) int static options (constant) init ("ISN", (4) (3)" ", "NEA", "OOB", (14) (3)" ",
						/* Store					*/
	(16) (3)" ", "PARU", "PARL", (3) (3)" ",	/* Parity					*/
	"   ", "IOC", "IA+IM", "ISP", "IPR", (16) (3)" ", /* Illegal Procedure			*/
	(18) (3)" ", "ONC1", "ONC2", "   ",		/* Operation Not Complete			*/
	"IRO", "OEB", "E-OFF", "ORB", "R-OFF", "OWB",	/* Access Violation				*/
	"W-OFF", "NO GA", "OCB", "OCALL", "BOC", "INRET", /* Access Violation				*/
	"CRT", "RALR", "AM-ER", "OOSB", (5) (1)" ");	/* Access Violation				*/

dcl  SC_IA_TYPES (1:15) char (43) var int static options (constant)
	init ("Unassigned (01). ", "Non-existent Address (02). ", "Stop on Condition (03). ", "Unassigned (04). ",
	"Data Parity, Store to SC (05). ", "Data Parity in Store (06). ", "Data Parity in Store AND Store to SC (07). ",
	"Not Control (10). ", "Port Not Enabled (11). ", "Illegal Command (12). ", "Store Not Ready ( 13). ",
	"ZAC Parity, Active Module to SC (14). ", "Data Parity, Active Module to SC (15). ",
	"ZAC Parity, SC to Store (16). ", "Data Parity, SC to Store (17). ");


	line2 = "";

	scup = scu_data_ptr;
	cpu_alph = substr (CPU_TAG, bin (scu.cpu_no, 3) + 1, 1);
	if scu.fi_flag then do;			/* Fault					*/
	     fault_no = bin (scu.fi_num, 17);
	     line1 = "Fault:  " || FAULT_TYPES (fault_no);
	     ptsr = substr (FAULT_TSR_VALID, fault_no + 1, 1);
	     if FAULT_MASK_INDEX (fault_no) ^= 0 then do; /* subtype of fault				*/
		fault_sub_type = unspec (scu.fd) & FAULT_MASKS (FAULT_MASK_INDEX (fault_no));
		sub_type_inx = index (fault_sub_type, "1"b);
		if sub_type_inx ^= 0
		then line1 = line1 || " (" || rtrim (FAULT_SUB_TYPES (FAULT_MASK_INDEX (fault_no), sub_type_inx))
			|| ")";
		end;
	     end;
	else do;					/* Interrupt				*/
	     ptsr = "0"b;
	     interrupt_no = bin (scu.fi_num, 5);
	     hardware_interrupt_level = divide (interrupt_no, 4, 17);
	     if hardware_interrupt_level = 0 | hardware_interrupt_level = 6 then do;
		hardware_interrupt_no = interrupt_no;
		line1 = "Interrupt: Number " || hardware_interrupt_no;
		end;
	     else do;
		interrupt_level = hardware_interrupt_level + mod (hardware_interrupt_level + 1, 2);
		iom_number = substr (IOM_TAG, mod (interrupt_no, 4) + 1, 1);
		line1 = "Interrupt: IOM " || iom_number || ", Level " || interrupt_level;
		end;
	     end;

	call ioa_ ("^1a^2x^3a^2x^32a^a", cpu_alph, process_char, line1, info);

	if line2 ^= "" then call ioa_ ("^28t^a", line2);

	if long_report then do;
	     if scu.ppr.prr = "0"b then seg_valid = get_segment_name (baseptr (bin (scu.ppr.psr, 15)), seg_name);
	     if (seg_valid) & (substr (seg_name, 1, 5) = "bound")
	     then call expand_seg_name (seg_name, baseptr (bin (scu.ppr.psr, 15)), bin (scu.ilc, 18), exp_seg_name);

	     else exp_seg_name = seg_name;

	     call ioa_ (SR_IOA_STRING, "by ", bin (scu.ppr.psr, 15), bin (scu.ilc, 18), scu.ppr.prr, scu.ppr.prr,
		seg_valid, exp_seg_name);
	     if ptsr then do;			/* print TSR/CA if valid			*/
		if scu.tpr.trr = "0"b then seg_valid = get_segment_name (baseptr (bin (scu.tpr.tsr, 15)), seg_name);
		if (seg_valid) & (substr (seg_name, 1, 5) = "bound")
		then call expand_seg_name (seg_name, baseptr (bin (scu.tpr.tsr, 15)), bin (scu.ca, 18), exp_seg_name);

		else exp_seg_name = seg_name;

		call ioa_ (SR_IOA_STRING, "ref", bin (scu.tpr.tsr, 15), bin (scu.ca, 18), scu.tpr.trr, scu.tpr.trr,
		     seg_valid, exp_seg_name);
		end;
	     end;



     end print_scu_data;
%page;
/* Internal Procedure to scan disk_seg and extract all queue entries */

process_disk_queue:
     proc (disk_seg_ptr, process_it);

dcl  disk_seg_ptr ptr;
dcl  process_it bit (1) aligned;

dcl  qx fixed bin;
dcl  sx fixed bin;
dcl  queue_time fixed bin (71);
dcl  queue_time_base fixed bin (71);
dcl  1 diskq_temp aligned like diskq_data;

	disksp = disk_seg_ptr;
	process_it = "0"b;
	if ^long_report then return;

	do qx = 1 to disk_data.free_q_size;
	     if disk_data.free_q_entries (qx).time ^= 0 then do;
		qp = addr (disk_data.free_q_entries (qx));
		diskq_temp.pvtx = quentry.pvtx;
		diskq_temp.write_sw = write_map (quentry.type);
		diskq_temp.sect_sw = sector_map (quentry.type);
		diskq_temp.coreadd = bin (quentry.coreadd, 25);
		diskq_temp.sector = bin (quentry.sector, 21);
		diskq_temp.cylinder = quentry.cylinder;
		queue_time = quentry.time;

		call add_an_event (queue_time, copy_to_temporary (addr (diskq_temp), size (diskq_temp)),
		     print_disk_queue, "Disk Queue", "0"b, "0"b);
	     end;
	end;

     end process_disk_queue;


%page;

/* Internal Procedure to scan a per-process machine condition trace buffer
   for machine conditions */

process_mc_trace_buf:
     proc (mctbp, process_it);

dcl  mctbp ptr;
dcl  process_it bit (1) aligned;

dcl  len fixed bin (21);
dcl  mcptr ptr;
dcl  mcx fixed bin;
dcl  mc_seg_offset char (30);

	process_it = "0"b;
	bp = mctbp;

	do mcx = 1 to mc_trace_buf.mc_cnt;
	     mcptr = addr (mc_trace_buf.mach_cond (mcx));
	     if addr (mcptr -> mc.scu (0)) -> scu.ppr.psr ^= "0"b then do;
		call ioa_$rsnnl ("mc_trace_buf (^o|^o)", mc_seg_offset, len, dump_segno, bin (rel (mcptr)));
		call add_an_event (bin (mcptr -> mc.fault_time, 54), copy_to_temporary (mcptr, size (mc)), print_mc,
		     mc_seg_offset, "1"b, "0"b);
		end;
	end;

     end process_mc_trace_buf;


%page;
/* Internal procedure to setup call to scan inzr_stk0						*/
process_inzr_stk0:
     proc (inzr_stk0_ptr, process_it);

dcl  inzr_stk0_ptr ptr;				/* pointer to copy of inzr_stk0		*/
dcl  process_it bit (1) aligned;			/* flag to process segment again		*/

dcl  code fixed bin (35);
dcl  segp ptr;

	process_it = "0"b;				/* only come here once			*/
	call ring0_get_$segptr_given_slt ("", "inzr_stk0", segp, code, slt_ptr, nametbl_ptr);
	if code ^= 0 then return;
	call walk_stack (inzr_stk0_ptr, bin (baseno (segp)), "inzr_stk0");

     end process_inzr_stk0;


%page;
/* Internal Procedure to scan iom_data for events of interest					*/

process_iom_data:
     proc (iom_data_p, process_it);

dcl  iom_data_p ptr;
dcl  process_it bit (1) aligned;

dcl  dev_no fixed bin;
dcl  per_device_p ptr;


	process_it = "0"b;				/* only come here once			*/
	iom_data_ptr = iom_data_p;
	if iom_data.n_devices > 0
	then do dev_no = 1 to iom_data.n_devices;
	     per_device_p = copy_to_temporary (addr (iom_data.per_device (dev_no)), size (per_device));
	     call add_an_event (iom_data.per_device (dev_no).connect_time, per_device_p, print_device_data,
		"per_device", "0"b, "0"b);
	end;


     end process_iom_data;


%page;

/* Internal Procedure to scan the PDS for events of interest					*/

process_pds:
     proc (pdsp, process_it);


dcl  pdsp ptr;					/* pointer to copied-out pds			*/
dcl  process_it bit (1) aligned;			/* flag to process this seg again		*/



dcl  aptp ptr;
dcl  bpp ptr;
dcl  mcptr ptr;
dcl  names_inx fixed bin;
dcl  pds_stacks_inx fixed bin;
dcl  pds_stacks_ptr ptr;


dcl  pds_names (3) char (32) int static options (constant) init ("page_fault_data", "fim_data", "signal_data");

dcl  based_flag fixed bin (35) based;
dcl  based_ptr ptr aligned based;
dcl  based_ptr_packed ptr unaligned based;
dcl  pds_stacks (0:7) ptr aligned based (pds_stacks_ptr);


	aptp = get_definition_ptr ("pds", "apt_ptr", pdsp);
	if aptp = null () then return;
	if rel (aptp -> based_ptr) = "0"b then return;

	apt_array.n_aptes = apt_array.n_aptes + 1;
	apt_array.apt_desc (n_aptes).offset = rel (aptp -> based_ptr);
	apt_array.apt_desc (n_aptes).procn = proc_no;


	do names_inx = 1 to hbound (pds_names, 1);
	     mcptr = validate_mc (pdsp, "pds", pds_names (names_inx));
	     if mcptr ^= null ()
	     then					/* machine condtions exist			*/
		call add_an_event (bin (mcptr -> mc.fault_time, 54), mcptr, print_mc,
		     "pds$" || rtrim (pds_names (names_inx)), "0"b, "0"b);
	end;

/* Extract stack segment numbers from the pds							*/

	pds_stacks_ptr = get_definition_ptr ("pds", "stacks", pdsp);
	if pds_stacks_ptr = null () then return;
	do pds_stacks_inx = 0 to hbound (pds_stacks, 1);
	     if pds_stacks (pds_stacks_inx) ^= null ()
	     then stack_segs (pds_stacks_inx) = bin (baseno (pds_stacks (pds_stacks_inx)), 17);
	     else stack_segs (pds_stacks_inx) = -1;
	end;

/* Check whether this process is tracing machine conditions */

	bpp = get_definition_ptr ("pds", "mc_trace_sw", pdsp);
	if bpp = null () then return;
	if bpp -> based_flag = 0 then return;
	bpp = get_definition_ptr ("pds", "mc_trace_buf", pdsp);
	if bpp = null () then return;
	interesting_segs (MC_TRACE_BUF).process_this_seg = "1"b;
	interesting_segs (MC_TRACE_BUF).segno = bin (baseno (bpp -> based_ptr_packed), 18);


     end process_pds;

%page;
/* Internal procedure to scan prds for interesting events						*/

process_prds:
     proc (prdsp, process_it);

dcl  prdsp ptr;					/* pointer to copied-out prds			*/
dcl  process_it bit (1) aligned;			/* flag to process prds again			*/



dcl  mcptr ptr;
dcl  names_inx fixed bin;
dcl  processor_tag fixed bin;
dcl  prtag_based fixed bin aligned based;
dcl  prtagp ptr;


dcl  apte_offset bit (18);
dcl  bpp ptr;
dcl  based_ptr ptr based;
dcl  prds_names (3) char (32) int static options (constant) init ("sys_trouble_data", "interrupt_data", "fim_data");

	prtagp = get_definition_ptr ("prds", "processor_tag", prdsp);
	if prtagp = null () then return;
	processor_tag = prtagp -> prtag_based;


	if ^substr (prds_processor, processor_tag + 1, 1) /* seen this prds before			*/
	then return;
	substr (prds_processor, processor_tag + 1, 1) = "0"b;
	if prds_processor = "0"b then process_it = "0"b;	/* last prds on system			*/

	bpp = get_definition_ptr ("prds", "apt_ptr", prdsp);
	if bpp = null ()
	then apte_offset = "0"b;
	else apte_offset = rel (bpp -> based_ptr);


	do names_inx = 1 to hbound (prds_names, 1);
	     mcptr = validate_mc (prdsp, "prds", prds_names (names_inx));
	     if mcptr ^= null () then do;
		call add_an_event (bin (mcptr -> mc.fault_time, 54), mcptr, print_mc,
		     "prds$" || rtrim (prds_names (names_inx)), (prds_names (names_inx) ^= "sys_trouble_data"),
		     apte_offset);
		end;
	end;


     end process_prds;
%page;
/* Internal procedure to extract messages from the wired syserr buffer				*/

process_syserr_data:
     proc (syserr_data_ptr, process_it);

dcl  syserr_data_ptr ptr;				/* pointer to copy of syserr_data		*/
dcl  process_it bit (1) aligned;			/* flag to process this seg again		*/

dcl  wlog_inx fixed bin;
dcl  wp ptr;
dcl  wtime fixed bin (71);


	process_it = "0"b;				/* only come here once			*/



	wlog_ptr = get_definition_ptr ("syserr_data", "wired_log_area", syserr_data_ptr);
	if wlog_ptr = null () then return;
	wmess_ptr = addr (wlog.buffer);

	if wlog.head.count < 1 then return;		/* no messages in buffer			*/

	do wlog_inx = 1 to wlog.head.count;
	     wp = copy_to_temporary (wmess_ptr, divide (length (unspec (wmess)), 36, 18));
	     wtime = wmess.time;
	     call add_an_event (wtime, wp, print_wired_syserr, "syserr_data", "0"b, "0"b);
	     wmess_ptr = addrel (wmess_ptr, divide (length (unspec (wmess)), 36, 18));
	end;


     end process_syserr_data;
%page;
/* Internal procedure to scan syserr log for messages within interval of interest			*/

process_syserr_log:
     proc (low_time, temp_ptr);


dcl  low_time fixed bin (71);				/* earliest time of interest			*/
dcl  temp_ptr ptr;					/* temporary segment we can use		*/


dcl  code fixed bin (35);
dcl  first_msg bit (18);
dcl  slog_done bit (1);
dcl  slog_found bit (1);
dcl  slog_inx fixed bin;
dcl  slog_no fixed bin;
dcl  slog_offset bit (18);
dcl  slog_p ptr;
dcl  slog_time fixed bin (71);
dcl  slog_tp ptr;
dcl  slog_words fixed bin (18);


dcl  MESS_MAX_SIZE fixed bin (18) init (1024) int static options (constant);

/* Find syserr_log in the dump								*/

	call ring0_get_$segptr_given_slt ("", "syserr_log", slog_p, code, slt_ptr, nametbl_ptr);
	if code ^= 0 then do;
SLOG_ERROR:
	     call com_err_ (code, MYNAME, "Error encountered processing syserr_log");
	     return;
	     end;

	slog_no = bin (baseno (slog_p), 18);
	slog_found = "0"b;
	slog_inx = 1;
	do while (^slog_found & slog_inx <= dump.num_segs);
	     if bin (dump.segs (slog_inx).segno, 18) = slog_no
	     then slog_found = "1"b;
	     else slog_inx = slog_inx + 1;
	end;
	if ^slog_found then goto SLOG_ERROR;

/* copy syserr_log header									*/

	call copy_from_dump (dump_ptrs, slog_inx, 0, size (slog_header), temp_ptr, slog_words, code);
	if code ^= 0 then goto SLOG_ERROR;

/* Romp through syserr_log, picking out events within the interval of
   interest--i.e., times less than earliest one found elsewhere					*/

	slog_ptr = temp_ptr;
	first_msg = slog.head.first;
	slog_offset = slog.head.last;
	slog_done = "0"b;

	do while (^slog_done);
	     if slog_offset = "0"b | slog_offset = first_msg
	     then slog_done = "1"b;
	     else do;
		call copy_from_dump (dump_ptrs, slog_inx, bin (slog_offset, 18), MESS_MAX_SIZE, temp_ptr, slog_words,
		     code);
		if code ^= 0 then goto SLOG_ERROR;
		smess_ptr = temp_ptr;
		slog_time = smess.time;
		if slog_time < low_time | slog_time > dump.mctime
		then slog_done = "1"b;
		else do;
		     slog_tp = copy_to_temporary (smess_ptr, min (currentsize (smess), MESS_MAX_SIZE));
		     call add_an_event (slog_time, slog_tp, print_syserr_log, "syserr_log", "0"b, "0"b);
		     slog_offset = smess.prev;
		     end;
		end;
	end;


     end process_syserr_log;


%page;
/* Internal procedure to scan tc_data for interesting events					*/


process_tc_data:
     proc (tc_data_ptr, process_it);


dcl  tc_data_ptr ptr;				/* pointer to copied-out tc_data		*/
dcl  process_it bit (1) aligned;


dcl  aptx fixed bin;
dcl  bp ptr;
dcl  num_aptes fixed bin;
dcl  size_of_apte fixed bin;
dcl  tp ptr;

dcl  EMPTY fixed bin init (0) int static options (constant);

dcl  based_fixed fixed bin (35) aligned based;


	process_it = "0"b;				/* only process tc_data once			*/



	bp = get_definition_ptr ("tc_data", "apt_size", tc_data_ptr);
	if bp = null () then return;
	num_aptes = bp -> based_fixed;
	if num_aptes <= 0 then return;
	bp = get_definition_ptr ("tc_data", "apt_entry_size", tc_data_ptr);
	if bp = null () then return;
	size_of_apte = bp -> based_fixed;
	if size_of_apte <= 0 then return;

	tp = copy_to_temporary (tc_data_ptr, sys_info$max_seg_size);
	aptep = get_definition_ptr ("tc_data", "apt", tp);
	if aptep = null () then return;

	do aptx = 1 to num_aptes;
	     if bin (apte.state, 18) ^= EMPTY & apte.state_change_time ^= 0
	     then call add_an_event (apte.state_change_time, aptep, print_apte, "apte", "0"b, rel (aptep));
	     aptep = addrel (aptep, size_of_apte);
	end;


     end process_tc_data;
%page;
/* Internal procedure to set up a stack for scanning						*/

process_user_stack:
     proc (ring_no, stack_ptr, stack_seg_no);

dcl  ring_no fixed bin;				/* ring number of stack in process		*/
dcl  stack_ptr ptr;					/* pointer to copy of stack			*/
dcl  stack_seg_no fixed bin;				/* segment number of stack in process		*/

dcl  ring_num pic "9";

	ring_num = ring_no;
	call walk_stack (stack_ptr, stack_seg_no, "stack_" || ring_num);

     end process_user_stack;
%page;
/* Internal procedure to get interesting data from scs 						*/

setup_from_scs:
     proc (scs_ptr, process_it);

dcl  scs_ptr ptr;					/* pointer to copy of scs			*/
dcl  process_it bit (1) aligned;			/* flag to process segment again		*/

dcl  proc_number fixed bin;
dcl  proc_exists_mask bit (36);
dcl  scs_proc_data_ptr ptr;

dcl  1 pdata (0:7) aligned like scs$processor_data based (scs_proc_data_ptr);

	process_it = "0"b;				/* process scs but once			*/
	proc_exists_mask = "0"b;
	scs_proc_data_ptr = get_definition_ptr ("scs", "processor_data", scs_ptr);
	if scs_proc_data_ptr = null () then return;

	do proc_number = 0 to hbound (pdata, 1);	/* find all cpus which might have been active	*/
	     if pdata (proc_number).online | pdata (proc_number).offline
	     then substr (proc_exists_mask, proc_number + 1, 1) = "1"b;
	end;
	prds_processor = prds_processor & proc_exists_mask;


     end setup_from_scs;


%page;
/* Internal procedure to check a named location for valid machine conditions.
   If machine conditions are stored, they are copied to temporary storage,
   and a pointer to the temporary storage area is returned						*/

validate_mc:
     proc (segptr, segname, mc_name) returns (ptr);


dcl  segptr ptr;					/* pointer to base of copy of segment		*/
dcl  segname char (*);				/* segment name				*/
dcl  mc_name char (*);				/* entry name where machine conditions are stored */

dcl  mcptr ptr;


	mcptr = get_definition_ptr (segname, mc_name, segptr);
	if mcptr = null () then return (mcptr);
	if addr (mcptr -> mc.scu (0)) -> scu.ppr.psr = "0"b then return (null ());
	return (copy_to_temporary (mcptr, size (mc)));


     end validate_mc;
%page;
/* Internal procedure to validate a stack pointer and construct a pointer
   to it.  The pointer is checked to contain the segment number of the stack,
   to point to a mod-16 location, and to be within the bounds defined by
   the stack_end_ptr.  A pointer to the frame in the copy of the stack is constructed 			*/

validate_stack_ptr:
     proc (stack_ptr, seg_num, stack_base_ptr) returns (ptr);

dcl  stack_ptr ptr;					/* stack pointer from FDUMP			*/
dcl  seg_num fixed bin;				/* segment number of stack in FDUMP		*/
dcl  stack_base_ptr ptr;				/* pointer to copy of stack			*/

	if baseno (stack_ptr) = "077777"b3
	then					/* if null ptr */
	     return (null ());			/* return */


	if addr (stack_ptr) -> its.mod then return (null ());
						/* return */
	if addr (stack_ptr) -> its.bit_offset then return (null ());
						/* return */
	if addr (stack_ptr) -> its.its_mod ^= ITS_MODIFIER then return (null ());

	if bin (baseno (stack_ptr)) ^= seg_num
	     | bin (rel (stack_ptr)) >= bin (rel (stack_base_ptr -> stack_header.stack_end_ptr))
	     | mod (bin (rel (stack_ptr)), 16) ^= 0
	     | bin (rel (stack_ptr)) < bin (rel (stack_base_ptr -> stack_header.stack_begin_ptr))
	     | rel (stack_ptr) = "0"b
	then return (null ());
	return (ptr (stack_base_ptr, rel (stack_ptr)));


     end validate_stack_ptr;

%page;
/* Internal procedure to walk a stack looking for fim-frames
   the walk is done forward, and only frames within the current segment
   are considered (there really shouldn't be any outside of it)					*/

walk_stack:
     proc (stack_ptr, stack_seg, stack_name);

dcl  stack_ptr ptr;					/* pointer to copy of stack			*/
dcl  stack_seg fixed bin;				/* segment number of stack			*/
dcl  stack_name char (*);				/* name of stack				*/


dcl  fim_cond_ptr ptr;
dcl  len fixed bin (21);
dcl  loop_count fixed bin;
dcl  next_frame_mc bit (1);
dcl  seg_offset char (13);


	sb = stack_ptr;
	loop_count = 1000;
	sp = validate_stack_ptr (stack_header.stack_begin_ptr, stack_seg, sb);
	if sp = null () then return;


	next_frame_mc = "0"b;
	do sp = sp repeat validate_stack_ptr (stack_frame.next_sp, stack_seg, sb)
	     while (sp ^= null () & loop_count > 0);
	     mcp = null ();
	     if next_frame_mc
		| (bound_interceptors_ptr ^= null ()
		& baseno (bound_interceptors_ptr) = baseno (stack_frame.return_ptr)) then do;
		mcp = addrel (sp, stack_frame_min_length);
		if addr (mc.scu (0)) -> scu.ppr.psr ^= "0"b then do;
		     call ioa_$rsnnl ("^a|^o", seg_offset, len, stack_name, bin (rel (sp)));
		     fim_cond_ptr = copy_to_temporary (mcp, size (mc));
		     call add_an_event (bin (mc.fault_time, 71), fim_cond_ptr, print_mc, seg_offset, "0"b, "0"b);
		     end;
		end;
	     next_frame_mc = "0"b;
	     if stack_frame_flags.signaller then next_frame_mc = "1"b;
	     loop_count = loop_count - 1;
	end;

     end walk_stack;
%page;
%include apte;
%page;
%include bind_map;
%page;
%include bos_dump;
%page;
%include dskdcl;
%page;
%include fs_dev_types;
%page;
%include iom_data;
%page;
%include its;
%page;
%include mc;
%page;
%include mc_trace_buf;
%page;
%include object_info;
%page;
%include pvt;
%page;
%include pvte;
%page;
%include scs;
%page;
%include slt;
%page;
%include stack_frame;
%page;
%include stack_header;
%page;
%include syserr_data;
%page;
%include syserr_log;



     end process_dump_segments;




		    setup_dump_segments.pl1         10/01/82  1523.5rew 10/01/82  1523.6       47862



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


setup_dump_segments:
     proc (dump_ptrs, slt_ptr, definitions_ptr, nametbl_ptr,
	     flagbox_seg, error_msg, code);


/* Procedure to setup critical segments from an FDUMP
   An array of pointers to dump segment components is passed as a parameter
   --this array is in order by component (0, 1, 2, ...).  This procedure
   copies the following segments from the FDUMP into supplied segments:
   SLT, definitions_, and the Name Table.  It finds the SLT from the flagbox,
   the Name Table from the SLT, and definitions_ from the SLT and Name Table.
   It uses the segment number of flagbox in the running system, unless over-ridden
   by a non-zero segment number passed as a parameter.  If this procedure
   fails, it returns a descriptive error message along with a standard error
   code.

   Written March 1981 by J. Bongiovanni								*/


/* Parameter */

dcl  dump_ptrs (*) ptr;				/* array of ordered pointers to dump components	*/
dcl  slt_ptr ptr;					/* where to copy SLT			*/
dcl  definitions_ptr ptr;				/* where to copy definitions			*/
dcl  nametbl_ptr ptr;				/* where to copy name table			*/
dcl  flagbox_seg fixed bin;				/* if non-zero, segment number of flagbox	*/
dcl  error_msg char (*);				/* ascii error message			*/
dcl  code fixed bin (35);				/* standard error code			*/


/* Automatic */

dcl  defp ptr;
dcl  flagbox_no fixed bin;
dcl  flagbox_ptr ptr;

/* Static */

dcl  MYNAME char (19) init ("setup_dump_segments") int static options (constant);


/* Entry */

dcl  copy_from_dump entry ((*) ptr, fixed bin, fixed bin (18), fixed bin (18), ptr, fixed bin (18), fixed bin (35));
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  release_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35));
dcl  ring0_get_$segptr_given_slt entry (char (*), char (*), ptr, fixed bin (35), ptr, ptr);

/* External */

dcl  error_table_$action_not_performed fixed bin (35) external;
dcl  sys_info$max_seg_size fixed bin (18) external;

/* Condition */

dcl  cleanup condition;

/* Builtin */

dcl  baseno builtin;
dcl  bin builtin;




%page;

/* Pick up flagbox segment number from running system, unless supplied in call				*/


	code = 0;
	error_msg = "Using SSTNT filled by BOS.";
	if flagbox_seg ^= 0
	then flagbox_no = flagbox_seg;
	else do;
	     call ring0_get_$segptr ("", "flagbox", flagbox_ptr, code);
	     if code ^= 0 then do;
		error_msg = "Cannot find flagbox on system";
		return;
	     end;
	     flagbox_no = bin (baseno (flagbox_ptr), 18);
	end;

/* Copy the flagbox from the FDUMP								*/

	call get_temp_segment_ (MYNAME, fgbxp, code);
	if code ^= 0 then do;
	     error_msg = "Error getting temp segment.";
	     return;
	end;

	on cleanup call cleanit;

	call copy_seg (flagbox_no, fgbxp, "flagbox");

	if slt_segno = "0"b then do;
	     code = error_table_$action_not_performed;
	     error_msg = "slt seg number not filled";
	     return;
	end;

/* Copy remaining segments of interest								*/

	call copy_seg (bin (slt_segno, 18), slt_ptr, "slt");
	sltp = slt_ptr;
	call copy_seg (bin (baseno (slt.name_seg_ptr), 18), nametbl_ptr, "Name Table");
	call ring0_get_$segptr_given_slt ("", "definitions_", defp, code, sltp, nametbl_ptr);
	if code ^= 0 then do;
	     call cleanit;
	     error_msg = "Cannot find definitions_";
	     return;
	end;
	call copy_seg (bin (baseno (defp), 18), definitions_ptr, "definitions_");

ERROR_RETURN:
	call cleanit;
	return;

%page;
/* Internal procedure to copy a segment from the FDUMP and return with an error
   if this cannot be done for any reason							*/


copy_seg:	proc (segno, seg_ptr, seg_name);

dcl  segno fixed bin;				/* segment number to copy			*/
dcl  seg_ptr ptr;					/* where to copy to				*/
dcl  seg_name char (*);				/* name of segment for error message		*/

dcl  found bit (1);
dcl  seginx fixed bin;
dcl  words_copied fixed bin (18);



	     dumpptr = dump_ptrs (1);
	     found = "0"b;
	     seginx = 1;
	     do while (seginx <= dump.num_segs & ^found);
		if bin (dump.segs.segno (seginx), 18) = segno
		then found = "1"b;
		else seginx = seginx + 1;
	     end;
	     if ^found then do;
		code = error_table_$action_not_performed;
		goto build_error_message;
	     end;


	     call copy_from_dump (dump_ptrs, seginx, 0, sys_info$max_seg_size, seg_ptr, words_copied, code);
	     if code ^= 0 | words_copied <= 0 then do;
build_error_message:

		error_msg = "Cannot find " || seg_name || " in dump";
		goto ERROR_RETURN;
	     end;

	end copy_seg;


/* Internal procedure for cleanup								*/


cleanit:
	proc;

dcl  rcode fixed bin (35);



	     call release_temp_segment_ (MYNAME, fgbxp, rcode);

	end cleanit;

%page;
%include bos_dump;
%page;
%include fgbx;
%page;
%include slt;


     end setup_dump_segments;





		    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
