



		    analyze_ioi_istat_.pl1          11/15/82  1825.9rew 11/15/82  1505.3       18693



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


/* ANALYZE_IOI_ISTAT_ - Procedures to decode ioi status structures */
/* Written March 1980 by Larry Johnson */

analyze_ioi_istat_: proc (arg_isp, arg_tablep, arg_message);

/* Parameters */

dcl  arg_isp ptr;
dcl  arg_imp ptr;
dcl  arg_tablep ptr;
dcl  arg_message char (*) var;

/* External */

dcl  analyze_device_stat_$rsnnl entry (char (*) var, ptr, bit (72), bit (18));
dcl  ioa_$rsnnl entry options (variable);

dcl (bin, substr) builtin;

/* entry for decoding the istat (long) structure */

	isp = arg_isp;
	call worker ((istat.completion), istat.level, (istat.iom_stat));
	return;

/* entry for decoding the imess (short) sturcture */

analyze_ioi_imess_: entry (arg_imp, arg_tablep, arg_message);

	imp = arg_imp;
	call worker (imess.completion, bin (imess.level), (imess.status));
	return;

/* procedure that does the work */

worker:	proc (comp, level, status);

dcl 1 comp like istat.completion;
dcl  level fixed bin (3);
dcl  status bit (72);

	     arg_message = "";
	     if level = 7 then
		call ioa_$rsnnl ("Special status: ^.3b", arg_message, (0), substr (status, 1, 36));
	     else if level = 1 then
		call ioa_$rsnnl ("System fault: ^.3b", arg_message, (0), substr (status, 1, 36));
	     else if level = 3 | level = 5 then do;
		if comp.time_out then arg_message = "Timeout";
		else call analyze_device_stat_$rsnnl (arg_message, arg_tablep, status, ("0"b));
	     end;
	     else call ioa_$rsnnl ("Unknown level ^d status : ^.3b", level, substr (status, 1, 36));
	     return;

	end worker;

%include ioi_stat;

     end analyze_ioi_istat_;




		    binary_segmsg_util_.pl1         11/15/82  1825.9rew 11/15/82  1505.4       36684



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


binary_segmsg_util_: proc (a_datap) returns (char (250));

/* Procedure to make heads and tails out of binary messages produced by page control/vtoc salvager. */
/* This procedure knows the format and decision trees of these binary messages, which happen */
/* to be transmitted via the syserr log, most usually.  This procedure has no knowledge */
/* of syserr or its logs. */

/* Bernard Greenberg 8/4/77 */

dcl (datap, a_datap) ptr;				/* Pointer to binary stuff */
dcl  path char (168);				/* Ostensible vpn_cv_.. answer */
dcl  segname char (250);				/* Answer */
dcl (linkage_error, command_error) condition;		/* vpn_cv_ is a mighty funny boy */
dcl  brief char (8) aligned;				/* For convert_status_code_ */
dcl  long char (100) aligned;				/* Ditto */
dcl  code fixed bin (35);				/* Status code in general */
dcl  volname char (32);				/* Phys vol name */
dcl (error_table_$noentry, error_table_$no_dir) fixed bin (35) external;

dcl  convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  vpn_cv_uid_path_ entry (ptr, char (*), fixed bin (35)); /* for dirnames */
dcl  vpn_cv_uid_path_$ent entry (ptr, char (*), bit (36) aligned, fixed bin (35));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  ioa_$rsnnl entry options (variable);
dcl  mdc_$find_volname entry (bit (36), char (*), char (*), fixed bin (35));


%include segdamage_msg;
dcl 1 sd like segdamage based (datap) aligned;
/* 	*/

	datap = a_datap;
	volname = cv_pvname ();

	if sd.vtocx = -2 then do;
						/* PD case */
	     if sd.uid = "0"b then segname = "VTOCEless segment on pv " || volname;
	     else call ioa_$rsnnl ("UID ^w on pv ^a", segname, (0), sd.uid, volname);
	end;
	else if sd.vtocx = -1 then segname = "VTOCEless segment on pv " || volname;
	else do;
						/* Have vtocx, if we have uid, golden */
	     if sd.uid = "0"b then do;
		path = "Cannot determine pathname.";
		on command_error;
		on linkage_error go to vpnf1;
		call vpn_cv_uid_path_ (addr (sd.uid_path), path, code);
vpnf1:		revert linkage_error;
		revert command_error;

		call ioa_$rsnnl ("Seg at vtocx ^o on pv ^a, dir = ^a", segname, (0), sd.vtocx, volname);
	     end;
	     else do;				/* Got ALL goods! */
		on linkage_error go to vpnf2;
		on command_error;
		path = "Cannot determine pathname";
		call vpn_cv_uid_path_$ent (addr (sd.uid_path), path, sd.uid, code);
vpnf2:		revert command_error;
		revert linkage_error;
		if code = 0 then segname = rtrim (path) || " on pv " || volname;
		else if code = error_table_$noentry then do;
		     call expand_pathname_ ((path), path, (" "), (0));
		     call ioa_$rsnnl ("Deleted segment in ^a, on pv ^a.", segname, (0), path, volname);
		end;
		else if code = error_table_$no_dir then call ioa_$rsnnl ("Segment on pv ^a in deleted directory: ^a",
		     segname, (0), volname, path);
		else do;
		     call convert_status_code_ (code, brief, long);
		     call ioa_$rsnnl ("Cannot determine full path name: ^a ^a = UID ^w.",
			segname, (0), long, path, sd.uid);
		end;
	     end;
	end;

	return (segname);

/* */
cv_pvname: proc () returns (char (32));

dcl (pvname, lvname) char (32);
dcl  code fixed bin (35);

	     if sd.pvid = "777777777777"b3 then return ("Paging Device");
	     call mdc_$find_volname ((sd.pvid), pvname, lvname, code);
	     if code ^= 0 then call ioa_$rsnnl ("<<PVID ^w>>", pvname, (0), sd.pvid);
	     return (pvname);

	end cv_pvname;

interpret_pvname: entry (a_datap) returns (char (32));

	datap = a_datap;

	return (cv_pvname ());

     end binary_segmsg_util_;




		    copy_out.pl1                    02/07/84  1156.0rew 02/07/84  1121.4       58005



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


copy_out: cpo: proc;

/* Fixed to delete output seg if copy fails 02/08/80 S. Herbst */
/* Fixed to copy non-connected segments properly, 09/19/80 W. Olin Sibert */

dcl (bound, tc, i) fixed bin;
dcl  bit_count fixed bin (24);
dcl  code fixed bin (35);
dcl  got_copy bit (1);
dcl (segptr, segptr0, tp) ptr;
dcl  dirname char (168);
dcl  (high_seg, hcsc) fixed bin;
dcl  test_word fixed bin (35);
dcl  tsdw fixed bin (71);
dcl  ename char (32);
dcl  targ char (tc) based (tp);

dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  get_wdir_ entry returns (char (168));
dcl  hcs_$delentry_file entry (char (*), char (*), fixed bin (35));
dcl  hcs_$high_low_seg_count entry (fixed bin, fixed bin);
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$set_bc_seg entry (ptr, fixed bin(24), fixed bin(35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  phcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  nd_handler_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  pathname_ entry (char(*), char(*)) returns(char(168));
dcl  ring0_get_$name entry (char (*), char (*), ptr, fixed bin (35));
dcl  ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35));
dcl  ring_zero_peek_ entry (ptr, ptr, fixed bin, fixed bin (35));
dcl (com_err_, com_err_$suppress_name, ioa_) entry options (variable);

dcl (error_table_$action_not_performed,
     error_table_$namedup,
     error_table_$segknown) fixed bin (35) external static;

dcl  myname char (32) int static options (constant) init ("copy_out");

dcl (cleanup, linkage_error) condition;

dcl (null, addr, addrel, binary, baseno, baseptr, size) builtin;

/*  */

	call cu_$arg_ptr (1, tp, tc, code);		/* pick up name of segment to copy out */
	if code ^= 0 | tc = 0 then do;		/* no arguments, give calling sequence */
	     call com_err_$suppress_name (0, myname, "Usage:  ^a name/number {alternate name}", myname);
	     return;
	     end;

	segptr = null;
	got_copy = "0"b;

	i = cv_oct_check_ (targ, code);		/* see if it's a number */
	if code ^= 0 then do;			/* it isn't, must be name */
	     call ring0_get_$segptr ("", targ, segptr0, code); /* get segptr for this name */
	     if segptr0 = null then do;		/* name not found */
		call expand_pathname_ (targ, dirname, ename, code);
		if code ^= 0 then do;
		     call com_err_ (code, myname);
		     return;
		     end;

		on condition (linkage_error) begin;
		     code = 0;
		     goto rzp_error;
		     end;

		call phcs_$initiate (dirname, ename, "", 0, 0, segptr0, code);

		revert condition (linkage_error);

		if segptr0 = null then do;
		     call com_err_ (code, myname, "^a", pathname_ (dirname, ename));
		     return;
		     end;
		goto get_alternate_name;
		end;
	     ename = targ;				/* default name of seg to create */
	     end;

	else do;					/* number was given */
	     call hcs_$high_low_seg_count (high_seg, hcsc);
	     if i > high_seg + hcsc
	     then do;
		call com_err_ (0, myname, "Segment ^o is greater than the highest segment number ^o.", i, high_seg+hcsc);
		return;
		end;
	     segptr0 = baseptr (i);			/* create pointer to segment */
	     call ring0_get_$name (dirname, ename, segptr0, code); /* get name for this segment */
	     if code ^= 0 then do;			/* no name for the segment */
		ename = targ;
		goto get_alternate_name;
		end;
	     call ioa_ ("Segment name is ^a", ename);	/* tell user name of segment */
	     end;

get_alternate_name:
	call cu_$arg_ptr (2, tp, tc, code);		/* see if optional segment name is given */
	if code ^= 0 | tc = 0 then do;
	     if dirname = ">" & ename = "" then ename = "root";
	     dirname = get_wdir_ ();
	     end;
	else do;					/* if arg is given expand_path_ it, else use wdir */
	     call expand_pathname_ (targ, dirname, ename, code);
	     if code ^= 0 then do;			/* trouble with path name */
cerr:		call com_err_ (code, myname, targ); /* tell user */
		call clean_up;
		return;
		end;
	     end;

/* Test whether copying is possible, and also cause segment fault to get sdw.bound right */

	call ring_zero_peek_ (segptr0, addr (test_word), size (test_word), code);
	if code ^= 0 then
	     goto rzp_error;

	call ring_zero_peek_ (addr (baseptr (0) -> sdwa (binary (baseno (segptr0), 15))),
	     addr (tsdw), size (tsdw), code);
	if code ^= 0 then
	     goto rzp_error;

	bound = (binary (addr (tsdw) -> sdw.bound, 14) + 1) * 16; /* get number of words */
	bit_count = bound * 36;			/* bit of segment */

	call ring_zero_peek_ (addrel (segptr0, bound - 1), addr (test_word), size (test_word), code);
	if code ^= 0 then				/* test whether whole segment is copyable -- in case we're */
	     goto rzp_error;			/* stuck with using metering_ring_zero_peek_ */

	on cleanup call clean_up;

CREATE:	call hcs_$make_seg (dirname, ename, "", 01011b, segptr, code); /* get segment to copy data into */
	if code ^= 0 then
	     if code = error_table_$namedup then do;
		call nd_handler_ ("copy_out", dirname, ename, code);
		if code = error_table_$action_not_performed then
		     return;
		goto CREATE;
		end;
	     else if code ^= error_table_$segknown then go to cerr;

	call ring_zero_peek_ (segptr0, segptr, bound, code); /* copy segment into user ring */
	if code ^= 0 then
	     goto rzp_error;

	got_copy = "1"b;

	call hcs_$set_bc_seg (segptr, bit_count, (0)); /* set bit count */
	call hcs_$terminate_noname (segptr, (0));	/* and terminate the segment */

	return;

rzp_error:
	call com_err_ (code, myname, "This operation requires access to phcs_.");
	call clean_up ();
	return;


clean_up: proc ();

	if segptr ^= null & ^got_copy then
	     call hcs_$delentry_file (dirname, ename, (0));

	end clean_up;

%page;
%include sdw;

	end copy_out;




		    dump_fnp.pl1                    11/15/82  1825.9rew 11/15/82  1505.4       47097



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


/* DUMP_FNP - Command to dump fnp memory */
/* PATCH_FNP - Command to patch fnp memory */
/*
   Re-implemented October 1978 by Larry Johnson to use debug_fnp interfaces.
   Modified 1979 June 1 by Art Beattie to remove maximum address checks.
*/

dump_fnp: proc;

/* Automatic */

dcl  name char (16);
dcl  n_args fixed bin;
dcl  arg_no fixed bin;
dcl  arg_ptr ptr;
dcl  arg_len fixed bin;
dcl  fnp fixed bin;
dcl  fnp_addr fixed bin;
dcl  fnp_len fixed bin;
dcl  code fixed bin (35);
dcl  display_mode fixed bin;
dcl  length_given bit (1);
dcl  mem_buf (0:2047) bit (18) unal;
dcl  patch_buf (10) fixed bin (17) unal;

/* Based */

dcl  arg char (arg_len) based (arg_ptr);

/* External */

dcl  cu_$arg_count entry (fixed bin);
dcl  com_err_ entry options (variable);
dcl  db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35));
dcl  db_fnp_display_ entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin, fixed bin (35));
dcl  db_fnp_memory_$store entry (ptr, fixed bin, fixed bin, fixed bin, ptr, char (*), fixed bin, fixed bin (35));
dcl  db_fnp_eval_ entry (ptr, fixed bin, char (*), ptr, char (*), fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));

dcl (addr, index, null, substr) builtin;

dcl  error_table_$too_many_args ext fixed bin (35);
dcl  error_table_$noarg ext fixed bin (35);

/* Dump_fnp command */

	name = "dump_fnp";
	call cu_$arg_count (n_args);
	if n_args < 2 then do;
	     call com_err_ (0, name, "Usage: ^a tag address {length} {-ch}", name);
	     return;
	end;

	arg_no = 1;
	fnp = get_fnp ();
	fnp_addr = get_address ();

	display_mode = 0;				/* Octal */
	length_given = "0"b;
	fnp_len = 1;				/* The default */
	do while (arg_no <= n_args);
	     call get_arg;
	     if arg = "-character" | arg = "-ch" then display_mode = 1;
	     else if ^length_given then do;
		fnp_len = eval_arg ();
		length_given = "1"b;
	     end;
	     else do;
		call com_err_ (0, name, "Unrecognized argument: ^a", arg);
		return;
	     end;
	end;

	call check_values;

	call db_fnp_memory_$fetch (null (), fnp, fnp_addr, fnp_len, addr (mem_buf), code);
	if code ^= 0 then do;
	     call com_err_ (code, name, "Unable to read memory.");
	     return;
	end;

	call db_fnp_display_ (null (), fnp, fnp_addr, fnp_len, addr (mem_buf), display_mode, code);
	if code ^= 0 then do;
	     call com_err_ (code, name, "Unable to display memory");
	     return;
	end;

	return;

/* Patch_fnp command */

patch_fnp: entry;

	name = "patch_fnp";
	call cu_$arg_count (n_args);
	if n_args < 3 then do;
	     call com_err_ (0, name, "Usage: ^a tag address word1 {... word10}", name);
	     return;
	end;

	arg_no = 1;
	fnp = get_fnp ();
	fnp_addr = get_address ();

	fnp_len = 0;
	do while (arg_no <= n_args);
	     call get_arg;
	     if fnp_len >= 10 then do;
		call com_err_ (error_table_$too_many_args, name, "^a", arg);
		return;
	     end;
	     fnp_len = fnp_len + 1;
	     patch_buf (fnp_len) = eval_arg ();
	end;

	call check_values;

	call db_fnp_memory_$store (null (), fnp, fnp_addr, fnp_len, addr (patch_buf), name, 2, code);
	if code ^= 0 then do;
	     call com_err_ (code, name, "Unable to patch memory");
	     return;
	end;

done:	return;

/* Check fnp arg */

get_fnp:	proc returns (fixed bin);

dcl  i fixed bin;

	     call get_arg;
	     i = index ("abcdefgh", arg);
	     if i = 0 then do;
bad_tag:		call com_err_ (0, name, "Bad FNP tag: ^a", arg);
		go to done;
	     end;
	     if substr ("abcdefgh", i, 1) ^= arg then go to bad_tag;
	     return (i);

	end get_fnp;

/* Get address argument */

get_address: proc returns (fixed bin);

	     if arg_no > n_args then do;
		call com_err_ (error_table_$noarg, name, "Address");
		go to done;
	     end;

	     call get_arg;
	     return (eval_arg ());

	end get_address;

/* Procedure to handle numeric args */

eval_arg:	proc returns (fixed bin);

dcl  i fixed bin;

	     call db_fnp_eval_ (null (), fnp, arg, null (), name, i, code);
	     if code ^= 0 then go to done;
	     return (i);

	end;

/* Get next argument */

get_arg:	proc;

	     call cu_$arg_ptr (arg_no, arg_ptr, arg_len, code);
	     if code ^= 0 then do;
		call com_err_ (code, name, "Arg ^d", arg_no); /* Should be impossible */
		go to done;
	     end;
	     arg_no = arg_no + 1;
	     return;

	end get_arg;

/* Check FNP address and length values */

check_values: proc;

	     if fnp_addr < 0 then do;
		call com_err_ (0, name, "Starting address out of range: ^o", fnp_addr);
		go to done;
	     end;

	     if fnp_len < 1 | fnp_len > dim (mem_buf, 1) then do;
		call com_err_ (0, name, "Invalid length: ^o", fnp_len);
		go to done;
	     end;

	     return;

	end check_values;

     end dump_fnp;




		    ed_appending_simulation_.pl1    01/26/85  1311.3r w 01/22/85  1300.8      106992



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
ed_appending_simulation_: proc;

/* Modified routine to access segments in the saved Multics memory image.
Taken from bce_appending_simulation.  Keith Loepere, December 1983. */

/* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */

dcl  address		        fixed bin (26);	/* running absolute or virtual (within segment) address */
dcl  code			        fixed bin (35) parameter;
dcl  crash_system_type	        fixed bin static;	/* supplied from dump */
dcl  data_length		        fixed bin (18);	/* running data left to be gotten */
dcl  data_part		        (data_part_length) bit (36) aligned based; /* part of page to extract toward total desired */
dcl  data_part_length	        fixed bin (18);
dcl  data_ptr		        ptr;		/* running ptr to user data area */
dcl  dbr_value		        bit (72) aligned parameter;
dcl  desired_segnum		        fixed bin (15) parameter;
dcl  dseg_sdw		        fixed bin (71);
dcl  1 dseg_info		        aligned like seg_info static; /* describe dseg in dump */
dcl  error_table_$argerr	        fixed bin (35) ext static;
dcl  error_table_$boundviol	        fixed bin (35) ext static;
dcl  error_table_$invalidsegno        fixed bin (35) ext static;
dcl  error_table_$out_of_bounds       fixed bin (35) ext static;
dcl  memory_block_ptrs	        (4) ptr static;	/* forms a set of 4 128k blocks of memory */
dcl  multics_data_ptr	        ptr;		/* running ptr to area in dump to copy out for user */
dcl  1 my_dbr_info		        aligned like dbr_info;
dcl  1 my_ptw_info		        aligned like ptw_info;
dcl  p_address		        fixed bin (26) parameter; /* desired address */
dcl  p_crash_system_type	        fixed bin parameter;
dcl  p_data_length		        fixed bin (18) parameter; /* desired data length */
dcl  p_data_ptr		        ptr parameter;	/* ptr to user data area */
dcl  p_last_segnum		        fixed bin (15) parameter;
dcl  p_memory_block_ptrs	        (4) ptr parameter;
dcl  p_seg_info_ptr		        ptr parameter;
dcl  page_num		        fixed bin;		/* loop counter */
dcl  page_offset		        fixed bin;		/* start within page of data to get */
dcl  ptp			        ptr;		/* ptw ptr */
dcl  sdwp			        ptr;		/* sdw ptr */
dcl  seg_sdw		        fixed bin (71);
dcl  size			        builtin;
%page;
init: entry (p_memory_block_ptrs, p_crash_system_type);

/* save away data about dump */

	memory_block_ptrs = p_memory_block_ptrs;
	crash_system_type = p_crash_system_type;
	return;
%page;
new_dbr: entry (dbr_value, p_last_segnum, code);

/* Supply a new dseg for the simulation. */

/* Examine the new dbr. */

	code = 0;
	dbr_info_ptr = addr (my_dbr_info);
	ptw_info_ptr = addr (my_ptw_info);
	call dbr_util_$dissect (addr (dbr_value), dbr_info_ptr);
	p_last_segnum = divide (dbr_info.bound, 2, 15) - 1;
	dseg_info.sdwi.paged = dbr_info.paged;
	dseg_info.sdwi.address = dbr_info.address;

/* Get the sdw & page table for dseg. */

	if dseg_info.sdwi.paged then do;
	     call get_absolute (dseg_info.sdwi.address - size (aste), size (aste) + divide (dbr_info.bound + 1023, 1024, 8), addr (dseg_info.sst_data), code);
	     if code ^= 0 then return;
	     call ptw_util_$dissect (addr (dseg_info.page_table (0)), ptw_info_ptr);
	     call get_absolute (ptw_info.address, 2, addr (dseg_sdw), code);
	     if code ^= 0 then return;
	end;
	else do;
	     call get_absolute (dseg_info.sdwi.address, 2, addr (dseg_sdw), code);
	     if code ^= 0 then return;
	end;
	call sdw_util_$dissect (addr (dseg_sdw), addr (dseg_info.sdwi));
	return;
%page;
get_absolute: entry (p_address, p_data_length, p_data_ptr, code);

	data_length = p_data_length;

/* We march the address we desire downwards, by at most a page at a time.  As
we do this, we appropriately keep track of the memory this is in (or not in)
to validate the address. */

	do while (data_length > 0);

/* Find amount of data in this page. */

	     data_part_length = mod (p_address + data_length - 1, 1024) + 1; /* amount from start of page to last word */
	     if data_part_length <= data_length then address = p_address + data_length - data_part_length; /* data crosses into this page */
	     else do;				/* data within a page */
		address = p_address;
		data_part_length = data_length;
	     end;
	     data_ptr = addrel (p_data_ptr, address - p_address);

	     if address >= 512 * 1024 then do;		/* address beyond this memory */
		code = error_table_$out_of_bounds;
		unspec (data_ptr -> data_part) = "0"b;
	     end;
	     else do;
		multics_data_ptr = addrel (memory_block_ptrs (divide (address, 128 * 1024, 17) + 1), mod (address, 128 * 1024));
		data_ptr -> data_part = multics_data_ptr -> data_part;
	     end;
	     data_length = data_length - data_part_length;
	end;
	return;
%page;
new_segment: entry (desired_segnum, p_seg_info_ptr, code);

/* Supply a new segnum for virtual simulation. */

	code = 0;
	seg_info_ptr = p_seg_info_ptr;

/*  We will get the user's new segment's sdw and page table.  We call virtual, 
telling it to get the seg's sdw. */

	call get_virtual (addr (dseg_info), desired_segnum * 2, 2, addr (seg_sdw), code);
	if code ^= 0 then go to bad_segment;

	call sdw_util_$dissect (addr (seg_sdw), addr (seg_info.sdwi));
	if seg_info.sdwi.faulted then do;
	     code = error_table_$invalidsegno;
	     go to bad_segment;
	end;
	if seg_info.sdwi.paged then do;		/* Get the seg's aste/page table */
	     call get_absolute (seg_info.sdwi.address - size (aste), size (aste) + divide (seg_info.sdwi.size + 1023, 1024, 8), addr (seg_info.sst_data), code);
	     if code ^= 0 then do;			/* It could just be that the page table is in good memory and has no aste in front of it, but... */
		seg_info.sdwi.faulted = "1"b;
bad_segment:	return;
	     end;
	end;
	return;
%page;
get_virtual: entry (p_seg_info_ptr, p_address, p_data_length, p_data_ptr, code);

/* Fetch a given set of words from the current segment. */

	code = 0;
	seg_info_ptr = p_seg_info_ptr;
	ptw_info_ptr = addr (my_ptw_info);

	data_length = p_data_length;
	if p_address + p_data_length > seg_info.sdwi.size then do;
	     data_part_length = p_address + data_length - seg_info.sdwi.size;
	     data_ptr = addrel (p_data_ptr, data_length - data_part_length);
	     unspec (data_ptr -> data_part) = "0"b;
	     code = error_table_$boundviol;
	     data_length = data_length - data_part_length;
	end;
	if seg_info.sdwi.paged then do;
	     do while (data_length > 0);
		data_part_length = mod (p_address + data_length - 1, 1024) + 1; /* amount from start of page to last word */
		if data_part_length <= data_length then address = p_address + data_length - data_part_length; /* data crosses into this page */
		else do;				/* data within a page */
		     address = p_address;
		     data_part_length = data_length;
		end;
		data_ptr = addrel (p_data_ptr, address - p_address);
		page_num = divide (address, 1024, 8);
		page_offset = mod (address, 1024);

/* Find the appropriate page.  Move the amount found in that page to the
user's area. */

		call ptw_util_$dissect (addr (seg_info.page_table (page_num)), ptw_info_ptr);
		if ptw_info.valid then		/* properly in memory */
		     call get_absolute (ptw_info.address + page_offset, data_part_length, data_ptr, code);
		else do;
bad_page:		     unspec (data_ptr -> data_part) = "0"b;
		     if code = 0 then code = error_table_$argerr;
		end;
		data_length = data_length - data_part_length;
	     end;
	end;
	else do;					/* in memory (unpaged) */
	     address = seg_info.sdwi.address + p_address;
	     call get_absolute (address, p_data_length, p_data_ptr, code);
	end;
	return;
%page;

/* The following routines were stolen from their namesakes for use here.
They are striped down and key off crash_system_type for operation. */

dbr_util_$dissect: proc (dbr_ptr, p_dbr_info_ptr);

/* Routine to take apart (and assemble?) dbr (descriptor segment base register)
values.  Initially coded by Keith Loepere, October 1983. */

dcl  dbr_ptr		        ptr parameter;
dcl  p_dbr_info_ptr		        ptr parameter;

	dbr_info_ptr = p_dbr_info_ptr;
	if crash_system_type = ADP_SYSTEM then do;
	     dbr_info.address = bin (dbr_ptr -> adp_dbr.add, 26);
	     dbr_info.bound = (bin (dbr_ptr -> adp_dbr.bound, 14) + 1) * 16;
	     dbr_info.stack_base_segnum = dbr_ptr -> adp_dbr.stack_base_segno * 8;
	     dbr_info.paged = ^ dbr_ptr -> adp_dbr.unpaged;
	end;
	else do;
	     dbr_info.address = bin (dbr_ptr -> l68_dbr.add, 24);
	     dbr_info.bound = (bin (dbr_ptr -> l68_dbr.bound, 14) + 1) * 16;
	     dbr_info.stack_base_segnum = dbr_ptr -> l68_dbr.stack_base_segno * 8;
	     dbr_info.paged = ^ dbr_ptr -> l68_dbr.unpaged;
	end;
	return;
     end;
%page;
ptw_util_$dissect: proc (P_ptw_ptr, P_ptw_info_ptr);

dcl  P_ptw_ptr		        pointer parameter;
dcl  P_ptw_info_ptr		        pointer parameter;

	ptp = P_ptw_ptr;
	ptw_info_ptr = P_ptw_info_ptr;
	if crash_system_type = ADP_SYSTEM then do;
	     if adp_ptw.add_type = add_type.core then do;
		ptw_info.address = adp_core_ptw.frame * 1024;
		ptw_info.null_disk = "0"b;
	     end;
	     else if adp_ptw.add_type = add_type.disk then do;
		ptw_info.address = bin (substr (adp_ptw.add, 2, 17), 17);
		ptw_info.null_disk = substr (adp_ptw.add, 1, 1);
	     end;
	     else do;
		ptw_info.address = bin (adp_ptw.add, 18);
		ptw_info.null_disk = "0"b;
	     end;
	     ptw_info = adp_ptw.flags, by name;
	end;
	else do;
	     if l68_ptw.add_type = add_type.core then do;
		ptw_info.address = l68_core_ptw.frame * 1024;
		ptw_info.null_disk = "0"b;
	     end;
	     else if l68_ptw.add_type = add_type.disk then do;
		ptw_info.address = bin (substr (l68_ptw.add, 2, 17), 17);
		ptw_info.null_disk = substr (l68_ptw.add, 1, 1);
	     end;
	     else do;
		ptw_info.address = bin (l68_ptw.add, 18);
		ptw_info.null_disk = "0"b;
	     end;
	     ptw_info = l68_ptw.flags, by name;
	end;
	return;
     end;
%page;
sdw_util_$dissect: proc (P_sdw_ptr, P_sdw_info_ptr);

dcl  P_sdw_ptr		        pointer parameter;
dcl  P_sdw_info_ptr		        pointer parameter;

	sdwp = P_sdw_ptr;				/* Make it addressable */
	sdw_info_ptr = P_sdw_info_ptr;
	unspec (sdw_info) = ""b;			/* Clear it out, and fill it in */

	if crash_system_type = ADP_SYSTEM then do;
	     string (sdw_info.access) = string (adp_sdw.access);
	     string (sdw_info.rings) = string (adp_sdw.rings);

	     sdw_info.faulted = ^adp_sdw.valid;		/* Bits are different in state */
	     sdw_info.paged = ^adp_sdw.unpaged;

	     if ^adp_sdw.not_a_gate then		/* Copy the entry bound, if interesting */
		sdw_info.gate_entry_bound = 1 + binary (adp_sdw.entry_bound, 14);

	     sdw_info.size = 16 + 16 * binary (adp_sdw.bound, 14);
	     sdw_info.address = binary (adp_sdw.add, 26);
	end;

	else do;					/* Ordinary Level 68 */
	     string (sdw_info.access) = string (l68_sdw.access);
	     string (sdw_info.rings) = string (l68_sdw.rings);

	     sdw_info.faulted = ^l68_sdw.valid;		/* Bits are different in state */
	     sdw_info.paged = ^l68_sdw.unpaged;
	     sdw_info.cache = l68_sdw.cache;		/* Only on the Level 68 */

	     if ^l68_sdw.not_a_gate then		/* Copy the entry bound, if interesting */
		sdw_info.gate_entry_bound = 1 + binary (l68_sdw.entry_bound, 14);

	     sdw_info.size = 16 + 16 * binary (l68_sdw.bound, 14);
	     sdw_info.address = binary (l68_sdw.add, 24);
	end;

	return;
     end;
%page; %include add_type;
%page; %include bce_appending_seg_info;
%page; %include "dbr.adp";
%page; %include "dbr.l68";
%page; %include dbr_info;
%page; %include "ptw.adp";
%page; %include "ptw.l68";
%page; %include ptw_info;
%page; %include "sdw.adp";
%page; %include "sdw.l68";
%page; %include system_types;
     end;




		    edit_mos_rscr_.pl1              06/02/83  1219.9r   06/02/83  1103.3      156807



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


/* EDIT_MOS_RSCR_: Procedure to interpret and edit contents memory maintence register. */

/* Written May 1976 by Larry Johnson */
/* Modified September 1977 by Larry Johnson for 16k chips */
/* Modified November 1979 by Larry Johnson for $decode entry */
/* Modified April 1983 by Paul Farley, with input from D. A. Fudge (UofC), for 64k chips */

edit_mos_rscr_: proc (arg_scrp, arg_descrip);

/* Arguments */

dcl  arg_descrip char (*) var;			/* Description built here */
dcl  arg_mem_type char (*);
dcl  arg_error char (*);
dcl  arg_scrp ptr;

/* Automatic */

dcl  decode_sw bit (1);
dcl  mem_type char (32);
dcl  error char (32);
dcl  syndrome fixed bin;
dcl  bit_no fixed bin;
dcl  board char (1);
dcl  quad fixed bin;
dcl  i fixed bin;
dcl  chip fixed bin;

dcl  ioa_ entry options (variable);
dcl  ioa_$rsnpnnl entry options (variable);

dcl (bin, bit, divide, mod, substr) builtin;

%include scr;
%page;
/* The following delcarations are for 1k MOS chips */

/* This table translates a syndrome to a board bit number */

dcl  bit_1k (128) fixed bin (8) unal int static options (constant) init (
     19, 18, 19, 17, 18, 16, 15, -1, 19, 14, 13, 11, 12, 10, 09, -1,
     18, 08, 07, 05, 06, 04, 03, -1, -1, 02, 01, -1, 00, -1, -1, -1,
     19, -1, -1, 17, -1, 16, 15, -1, -1, 14, 13, 11, 12, 10, 09, -1,
     -1, 08, 07, 05, 06, 04, 03, -1, -1, 02, 01, -1, 00, -1, -1, -1,
     18, -1, -1, 17, -1, 16, 15, -1, -1, 14, 13, 11, 12, 10, 09, -1,
     -1, 08, 07, 05, 06, 04, 03, -1, -1, 02, 01, -1, 00, -1, -1, -1,
     -1, -1, -1, 17, -1, 16, 15, -1, -1, 14, 13, 11, 12, 10, 09, -1,
     -1, 08, 07, 05, 06, 04, 03, -1, -1, 02, 01, -1, 00, -1, -1, -1);

/* This table translates a syndrom into a "quandrant" in the error chart */

dcl  quad_1k (128) fixed bin (3) unal int static options (constant) init (
     4, 4, 3, 4, 3, 4, 4, 0, 2, 4, 4, 4, 4, 4, 4, 0,
     2, 4, 4, 4, 4, 4, 4, 0, 0, 4, 4, 0, 4, 0, 0, 0,
     1, 0, 0, 3, 0, 3, 3, 0, 0, 3, 3, 3, 3, 3, 3, 0,
     0, 3, 3, 3, 3, 3, 3, 0, 0, 3, 3, 0, 3, 0, 0, 0,
     1, 0, 0, 2, 0, 2, 2, 0, 0, 2, 2, 2, 2, 2, 2, 0,
     0, 2, 2, 2, 2, 2, 2, 0, 0, 2, 2, 0, 2, 0, 0, 0,
     0, 0, 0, 1, 0, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 0,
     0, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 0);

/* This table is used to determine a board number. One string applies to each quandrant. */

dcl  board_1k (4) char (8) int static options (constant) init (
     "ACEGBDFH", "JLNQKMPR", "LJGEKHFD", "USQNTRPM");

dcl  bay_1k (4) char (3) int static options (constant) init (
     "AA0", "AA0", "AA1", "AA1");

/* End of 1k chip declarations */
%page;
/* The following declarations are for 4k and 16k mos chips. */

dcl  bit_4k (128) fixed bin (8) unal int static options (constant) init (
     19, 18, 17, 15, 16, 14, 13, -1, 19, 12, 11, 09, 10, 08, 07, -1,
     18, 06, 05, 03, 04, 02, 01, -1, -1, 00, 19, -1, 18, -1, -1, -1,
     17, -1, -1, 17, -1, 16, 15, -1, -1, 14, 13, 11, 12, 10, 09, -1,
     -1, 08, 07, 05, 06, 04, 03, -1, -1, 02, 01, -1, 00, -1, -1, -1,
     16, -1, -1, 15, -1, 14, 13, -1, -1, 12, 11, 09, 10, 08, 07, -1,
     -1, 06, 05, 03, 04, 02, 01, -1, -1, 00, 19, -1, 18, -1, -1, -1,
     -1, -1, -1, 17, -1, 16, 15, -1, -1, 14, 13, 11, 12, 10, 09, -1,
     -1, 08, 07, 05, 06, 04, 03, -1, -1, 02, 01, -1, 00, -1, -1, -1);

/* The following table translate a syndrome into a quadrant in the error chard */

dcl  quad_4k (128) fixed bin (3) unal int static options (constant) init (
     4, 4, 4, 4, 4, 4, 4, 0, 2, 4, 4, 4, 4, 4, 4, 0,
     2, 4, 4, 4, 4, 4, 4, 0, 0, 4, 3, 0, 3, 0, 0, 0,
     2, 0, 0, 3, 0, 3, 3, 0, 0, 3, 3, 3, 3, 3, 3, 0,
     0, 3, 3, 3, 3, 3, 3, 0, 0, 3, 3, 0, 3, 0, 0, 0,
     2, 0, 0, 2, 0, 2, 2, 0, 0, 2, 2, 2, 2, 2, 2, 0,
     0, 2, 2, 2, 2, 2, 2, 0, 0, 2, 1, 0, 1, 0, 0, 0,
     0, 0, 0, 1, 0, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 0,
     0, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 0);

dcl  board_4k (4) char (4) int static options (constant) init (
     "ABCD", "FGHJ", "KLMN", "QRST");

/* End of 4k chip declarations */
%page;
/* The following tables are for M264 16k chips */

dcl  bit_16k (128) fixed bin (8) unal int static options (constant) init (
     79, 78, 77, 71, 76, 70, 69, -1, 75, 68, 67, 65, 66, 64, 63, -1,
     74, 62, 61, 59, 60, 58, 57, -1, -1, 56, 55, -1, 54, -1, -1, -1,
     73, -1, -1, 53, -1, 52, 51, -1, -1, 50, 49, 47, 48, 46, 45, -1,
     -1, 44, 43, 41, 42, 40, 39, -1, -1, 38, 37, -1, 36, -1, -1, -1,
     72, -1, -1, 35, -1, 34, 33, -1, -1, 32, 31, 29, 30, 28, 27, -1,
     -1, 26, 25, 23, 24, 22, 21, -1, -1, 20, 19, -1, 18, -1, -1, -1,
     -1, -1, -1, 17, -1, 16, 15, -1, -1, 14, 13, 11, 12, 10, 09, -1,
     -1, 08, 07, 05, 06, 04, 03, -1, -1, 02, 01, -1, 00, -1, -1, -1);

dcl  chip_16k (0:79) char (3) unal int static options (constant) init (
     "0A", "2A", "4A", "6A", "0B", "2B", "4B", "6B", "0C", "2C",
     "4C", "6C", "0D", "2D", "4D", "6D", "0E", "2E", "4E", "6E",
     "0F", "2F", "4F", "6F", "0G", "2G", "4G", "6G", "0H", "2H",
     "4H", "6H", "0J", "2J", "4J", "6J", "0K", "2K", "4K", "6K",
     "0R", "2R", "4R", "6R", "0S", "2S", "4S", "6S", "0T", "2T",
     "4T", "6T", "0U", "2U", "4U", "6U", "0V", "2V", "4V", "6V",
     "0W", "2W", "4W", "6W", "0X", "2X", "4X", "6X", "0Y", "2Y",
     "4Y", "6Y", "0Z", "2Z", "4Z", "6Z", "0AA", "2AA", "4AA", "6AA");

dcl  board_16k (0:15) char (1) unal int static options (constant) init (
     "A", "B", "C", "D", "E", "F", "G", "H", "J", "K", "L", "M", "N", "P", "Q", "R");
%page;
/* The following tables are for M64 64k chips */

dcl  bit_64k (128) fixed bin (8) unal int static options (constant) init (
     79, 78, 77, 71, 76, 70, 69, -1, 75, 68, 67, 65, 66, 64, 63, -1,
     74, 62, 61, 59, 60, 58, 57, -1, -1, 56, 55, -1, 54, -1, -1, -1,
     73, -1, -1, 53, -1, 52, 51, -1, -1, 50, 49, 47, 48, 46, 45, -1,
     -1, 44, 43, 41, 42, 40, 39, -1, -1, 38, 37, -1, 36, -1, -1, -1,
     72, -1, -1, 35, -1, 34, 33, -1, -1, 32, 31, 29, 30, 28, 27, -1,
     -1, 26, 25, 23, 24, 22, 21, -1, -1, 20, 19, -1, 18, -1, -1, -1,
     -1, -1, -1, 17, -1, 16, 15, -1, -1, 14, 13, 11, 12, 10, 09, -1,
     -1, 08, 07, 05, 06, 04, 03, -1, -1, 02, 01, -1, 00, -1, -1, -1);

dcl  chip_64k_not_a6 (0:79) char (3) unal int static options (constant) init (
     "01A", "19A", "37A", "55A", "01B", "19B", "37B", "55B", "01C", "19C",
     "37C", "55C", "01D", "19D", "37D", "55D", "01E", "19E", "37E", "55E",
     "01F", "19F", "37F", "55F", "01G", "19G", "37G", "55G", "01H", "19H",
     "37H", "55H", "01J", "19J", "37J", "55J", "01K", "19K", "37K", "55K",
     "01N", "19N", "37N", "55N", "01P", "19P", "37P", "55P", "01Q", "19Q",
     "37Q", "55Q", "01R", "19R", "37R", "55R", "01S", "19S", "37S", "55S",
     "01T", "19T", "37T", "55T", "01U", "19U", "37U", "55U", "01V", "19V",
     "37V", "55V", "01W", "19W", "37W", "55W", "01X", "19X", "37X", "55X");

dcl  chip_64k_a6 (0:79) char (3) unal int static options (constant) init (
     "10A", "28A", "46A", "64A", "10B", "28B", "46B", "64B", "10C", "28C",
     "46C", "64C", "10D", "28D", "46D", "64D", "10E", "28E", "46E", "64E",
     "10F", "28F", "46F", "64F", "10G", "28G", "46G", "64G", "10H", "28H",
     "46H", "64H", "10J", "28J", "46J", "64J", "10K", "28K", "46K", "64K",
     "10N", "28N", "46N", "64N", "10P", "28P", "46P", "64P", "10Q", "28Q",
     "46Q", "64Q", "10R", "28R", "46R", "64R", "10S", "28S", "46S", "64S",
     "10T", "28T", "46T", "64T", "10U", "28U", "46U", "64U", "10V", "28V",
     "46V", "64V", "10W", "28W", "46W", "64W", "10X", "28X", "46X", "64X");

dcl  board_64k (0:15) char (1) unal int static options (constant) init (
     "A", "B", "C", "D", "E", "F", "G", "H", "J", "K", "L", "M", "N", "P", "Q", "R");
%page;
/* The edit_mos_rscr_ entry */

	decode_sw = "0"b;

join:	scrp = arg_scrp;
	mem_type, error = "";

/* First, determine the kind of memory */

	if scr_su.identification = "0000"b then mem_type = "High Speed Core, Model AA1";
	else if scr_su.identification = "0001"b then mem_type = "High Speed Core, Model AA3";
	else if scr_su.identification = "1100"b then mem_type = "MOS, 1k chip, EDAC disabled";
	else if scr_su.identification = "0100"b then call edit_1k;
	else if scr_su.identification = "1111"b then call edit_M16;
	else if scr_su.identification = "1110"b then call edit_M128;
          else if scr_su.identification = "1010"b then call edit_M64;
	else if scr_su.identification = "1011"b then call edit_M264;
	else if scr_su.identification = "0011"b then call edit_M32;
	else do;
	     call ioa_$rsnpnnl ("Unknown memory type, id=^4b", mem_type, (0), scr_su.identification);
	     call ioa_$rsnpnnl ("ZAC line(bits 36-41)=^b, syndrome=^.3b", error, (0), scr_su.ZAC_line, "0"b || scr_su.syndrome);
	end;

	if decode_sw then do;
	     arg_mem_type = mem_type;
	     arg_error = error;
	end;
	else call ioa_$rsnpnnl ("^a, ^[Error: ^a^;No error.^]", arg_descrip, (0), mem_type, (error ^= ""), error);
	return;



/* The edit_mos_rscr_$decode entry. Returns mem_type and error in seperate feilds */

decode:	entry (arg_scrp, arg_mem_type, arg_error);

	decode_sw = "1"b;
	go to join;
%page;
/* Procedure to edit data for 1k chip */

edit_1k:	proc;

dcl  a234 fixed bin;				/* Bits 2,3,4 of addr */
dcl  a56 fixed bin;					/* Bits 5 and 6 */

	     mem_type = "MOS, 1k chip";
	     if scr_su.syndrome = "0"b then return;	/* No error */

	     if ^substr (scr_su.syndrome, 8, 1) then do;	/* Syndrome must be odd */
bad_1k_synd:	call ioa_$rsnpnnl ("A2-A6=^b, syndrome=^.3b",
		     error, (0), substr (scr_su.ZAC_line, 1, 5), "0"b || scr_su.syndrome);
		return;
	     end;

	     syndrome = bin (substr (scr_su.syndrome, 1, 7), 7) + 1;
	     bit_no = bit_1k (syndrome);		/* Map syndrome into bit number */
	     if bit_no < 0 then go to bad_1k_synd;
	     quad = quad_1k (syndrome);

	     a234 = bin (substr (scr_su.ZAC_line, 2, 3), 3);
	     board = substr (board_1k (quad), a234 + 1, 1);
	     a56 = bin (substr (scr_su.ZAC_line, 5, 2), 2);
	     if bit_no < 10 then chip = 10 * a56 + bit_no + 1;
	     else chip = 10 * a56 + (bit_no - 10) + 41;
	     call ioa_$rsnpnnl ("board ^a-^a, chip A^d", error, (0), bay_1k (quad), board, chip);
	     return;

	end edit_1k;
%page;
/* Procedure to edit 4k mos data */

edit_M16:	proc;

dcl  a78 fixed bin;					/* Bits 7-8 of address */
dcl  a910 fixed bin;				/* Bits 9 and 10 of address */

	     mem_type = "MOS-M16, 4k chip";
	     if scr_su.syndrome = "0"b then return;

	     if ^substr (scr_su.syndrome, 8, 1) then do;	/* Must be odd */
bad_4k_synd:	call ioa_$rsnpnnl ("A7-A10=^b, syndrome=^.3b",
		     error, (0), substr (scr_su.ZAC_line, 1, 4), "0"b || scr_su.syndrome);
		return;
	     end;

	     syndrome = bin (substr (scr_su.syndrome, 1, 7), 7) + 1;
	     bit_no = bit_4k (syndrome);
	     if bit_no < 0 then go to bad_4k_synd;
	     quad = quad_4k (syndrome);
	     a78 = bin (substr (scr_su.ZAC_line, 1, 2), 2);
	     board = substr (board_4k (quad), a78 + 1, 1);
	     a910 = bin (substr (scr_su.ZAC_line, 3, 2), 2);
	     chip = 20 * a910 + bit_no;
	     call ioa_$rsnpnnl ("board ^a, chip A^d", error, (0), board, chip);
	     return;

	end edit_M16;
%page;
/* Procedure to edit data from 16-pin chip memories - 4k and 16k chips */

edit_M128: proc;

dcl  a45 fixed bin;
dcl  a678 fixed bin;
dcl  chip_letter char (1);
dcl  chip_pic picture "99";
dcl  addr_bits char (32) var;

	     mem_type = "MOS-M128, 16k chip";
	     addr_bits = "A4-A8";
edit_join:
	     if scr_su.syndrome = "0"b then return;	/* No error */

	     if ^substr (scr_su.syndrome, 8, 1) then do;	/* Syndrome not odd */
bad_M128_synd:	call ioa_$rsnpnnl ("^a=^b, syndrome=^.3b", error, (0),
		     addr_bits, substr (scr_su.ZAC_line, 1, 5), "0"b || scr_su.syndrome);
		return;
	     end;

	     syndrome = bin (substr (scr_su.syndrome, 1, 7), 7) + 1;
	     bit_no = bit_4k (syndrome);
	     if bit_no < 0 then go to bad_M128_synd;
	     quad = quad_4k (syndrome);
	     a45 = bin (substr (scr_su.ZAC_line, 1, 2));
	     a678 = bin (substr (scr_su.ZAC_line, 3, 3));
	     board = substr (board_4k (quad), a45 + 1);
	     chip_letter = substr ("ABCDEGHJKL", divide (bit_no, 2, 17, 0) + 1, 1);
	     if mod (bit_no, 2) = 1 then chip_pic = 7 - a678;
	     else chip_pic = 18 - a678;
	     call ioa_$rsnpnnl ("board ^a, chip ^a^a", error, (0),
		board, chip_pic, chip_letter);
	     return;

edit_M32:	     entry;

	     mem_type = "MOS-M32, 4k chip";
	     addr_bits = "A6-A10";
	     go to edit_join;

	end edit_M128;
%page;
/* Procedure to edit 16k M264 chip */

edit_M264: proc;

dcl  a4567 fixed bin;
dcl  a8 bit (1);
dcl  chip_name char (3);
dcl  chip_pic pic "9";

	     mem_type = "MOS-M264, 16k chip";

	     if scr_su.syndrome = "0"b then return;

	     if ^substr (scr_su.syndrome, 8, 1) then do;	/* Must be odd */
bad_M264_synd:	call ioa_$rsnpnnl ("A4-A8=^b, syndrome=^.3b", error, (0),
		     substr (scr_su.ZAC_line, 1, 5), "0"b || scr_su.syndrome);
		return;
	     end;

	     syndrome = bin (substr (scr_su.syndrome, 1, 7), 7) + 1;
	     bit_no = bit_16k (syndrome);
	     if bit_no < 0 then go to bad_M264_synd;
	     a4567 = bin (substr (scr_su.ZAC_line, 1, 4), 4);
	     a8 = substr (scr_su.ZAC_line, 5, 1);
	     chip_name = chip_16k (bit_no);
	     if a8 then do;
		chip_pic = bin (substr (chip_name, 1, 1)) + 1;
		substr (chip_name, 1, 1) = chip_pic;
	     end;
	     call ioa_$rsnpnnl ("board ^a, chip ^a", error, (0),
		board_16k (a4567), chip_name);
	     return;

	end edit_M264;
%page;
/* Procedure to edit 64k M64 chip */

edit_M64: proc;

dcl  a2345 fixed bin;
dcl  a6 bit (1);
dcl  chip_name char (3);

	     mem_type = "MOS-M64, 64k chip";

	     if scr_su.syndrome = "0"b then return;

	     if ^substr (scr_su.syndrome, 8, 1) then do;	/* Must be odd */
bad_M64_synd:	call ioa_$rsnpnnl ("A2-A6=^b, syndrome=^.3b", error, (0),
		     substr (scr_su.ZAC_line, 1, 5), "0"b || scr_su.syndrome);
		return;
	     end;

	     syndrome = bin (substr (scr_su.syndrome, 1, 7), 7) + 1;
	     bit_no = bit_64k (syndrome);
	     if bit_no < 0 then go to bad_M64_synd;
	     a2345 = bin (substr (scr_su.ZAC_line, 1, 4), 4);
	     a6 = substr (scr_su.ZAC_line, 5, 1);
	     if a6 then chip_name = chip_64k_a6 (bit_no);
               else chip_name = chip_64k_not_a6 (bit_no);     
	     call ioa_$rsnpnnl ("board ^a, chip ^a", error, (0),
		board_64k (a2345), chip_name);
	     return;

	end edit_M64;
%page;
/* The following debuging entries are commands which will check
   the translation tables for consistency and print a syndome table in a format
   similiar to that on the memory. These entries are not retained and are used
   only to help in verifying the correctness of the tables. */

debug_1k:	entry;

	call debug_test (bit_1k, quad_1k);
	return;

debug_4k:	entry;

	call debug_test (bit_4k, quad_4k);
	return;

debug_test: proc (b, q);

dcl  b (128) fixed bin (8) unal;
dcl  q (128) fixed bin (3) unal;
dcl  dat (4, 0:19) fixed bin;				/* Table built here */
dcl (i, j) fixed bin;
dcl  bits (4) bit (9);

	     dat = -1;
	     do i = 1 to 128;
		if ^(b (i) = -1 & q (i) = 0) then do;	/* If position not undefined */
		     if b (i) < 0 | b (i) > 19 | q (i) < 1 | q (i) > 4 then /* Bad number */
			call ioa_ ("error at ^d: ^d, ^d", i, b (i), q (i));
		     else if dat (q (i), b (i)) ^= -1 then /* Duplicate (reused address?) */
			call ioa_ ("duplicate at ^d: ^d, ^d", i, b (i), q (i));
		     else dat (q (i), b (i)) = i;
		end;
	     end;
	     do i = 1 to 4;				/* Check for missing entries */
		do j = 0 to 19;
		     if dat (i, j) = -1 then call ioa_ ("no entry for ^d, ^d", j, i);
		end;
	     end;
	     do j = 0 to 19;			/* Print table */
		do i = 1 to 4;
		     if dat (i, j) = -1 then bits (i) = (9)"1"b;
		     else bits (i) = bit (bin (dat (i, j)-1, 8), 8) || "1"b;
		end;
		call ioa_ ("^2d   ^(^3.3b ^)", j, bits);
	     end;
	     return;

	end debug_test;
%page;
debug_16k: entry;

	do i = 1 to 128;
	     if bit_16k (i) >= 0 then
		call ioa_ ("^.3b ^a", "0"b || bit (bin (2 * (i-1) + 1, 8), 8), bit_name_16k ((bit_16k (i))));
	end;
	do i = 0 to 79;
	     call ioa_ ("^4a ^a ^d^a", bit_name_16k (i), chip_16k (i), bin (substr (chip_16k (i), 1, 1)) + 1, substr (chip_16k (i), 2));
	end;
	return;

bit_name_16k: proc (b) returns (char (2));

dcl  b fixed bin;
dcl  p picture "99";

	     if b <= 71 then do;
		p = b;
		return (p);
	     end;
	     else do;
		p = b-71;
		return ("P" || substr (p, 2));
	     end;

	end bit_name_16k;
%page;
debug_64k: entry;

	do i = 1 to 128;
	     if bit_64k (i) >= 0 then
		call ioa_ ("^.3b ^a", "0"b || bit (bin (2 * (i-1) + 1, 8), 8), bit_name_64k ((bit_64k (i))));
	end;
	do i = 0 to 79;
	     call ioa_ ("^4a ^a ^a", bit_name_64k (i), chip_64k_not_a6 (i), chip_64k_a6 (i));
	end;
	return;

bit_name_64k: proc (b) returns (char (3));

dcl  b fixed bin;
dcl  p picture "99";

	     if b <= 71 then do;
		p = b;
		return (p);
	     end;
	     else do;
		p = b-71;
		return ("PC" || substr (p, 2));
	     end;

	end bit_name_64k;

     end edit_mos_rscr_;




		    extract.pl1                     11/21/84  1206.3rew 11/21/84  1034.8       40221



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

/* format: style1,ind2,^inddcls,ifthenstmt,dclind2,declareind2,ifthendo,ifthen*/

extract: ext: proc;

/* Modified 2/24/81 by J. A. Bush for larger fdump header size */
/* Modified 10/15/81 by J. A. Bush to add the "-pathname" control arg */
/* Modified: October 1984 by Greg Texada to use copy_erf_seg_ to get the data.				*/

dcl seg_no	     fixed bin (15) uns;
dcl delete_seg	     bit (1) init ("0"b);
dcl tc		     fixed bin;
dcl code		     fixed bin (35);
dcl arg		     char (tc) based (tp);
dcl (dump_name, ename, segname) char (32);
dcl (dirname, dump_dir)  char (168);
dcl p_length	     fixed bin (19) uns;
dcl (addrel, baseno, divide, fixed, mod, null, ptr, rel, size) builtin;
dcl (p, tp)	     ptr;

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

dcl cu_$arg_ptr	     entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl copy_erf_seg_	     entry (char (*), uns fixed bin (15), ptr, uns fixed bin (19),
		     fixed bin (35));
dcl copy_erf_seg_$name   entry (char (*), char (*), ptr, uns fixed bin (19), fixed bin (35));
dcl delete_$ptr	     entry (ptr, bit (36) aligned, char (*), fixed bin (35));
dcl get_dump_ptrs_$dump_dir entry (char (*), char (*), (0:31) ptr,
		     (0:31) fixed bin, fixed bin, char (32));
dcl (ioa_, com_err_)     entry options (variable);
dcl ring0_get_$segptr_given_slt entry (char (*), char (*), ptr, fixed bin (35), ptr, ptr);
dcl cv_oct_check_	     entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl absolute_pathname_   entry (char (*), char (*), fixed bin (35));
dcl get_wdir_	     entry returns (char (168));
dcl hcs_$make_seg	     entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl hcs_$get_max_length_seg entry (ptr, fixed bin, fixed bin (35));
dcl hcs_$set_bc	     entry (char (*), char (*), fixed bin (24), fixed bin (35));
dcl terminate_file_	     entry (ptr, fixed bin (24), bit (*), fixed bin (35));
%page;
    segname = "";
    call cu_$arg_ptr (1, tp, tc, code);			/* pick up erf number */
    if code ^= 0 then do;
tell:   call ioa_ ("Usage: extract erfno seg_name/number {-pathname (-pn) path}");
        return;
      end;

    dump_name = arg;				/* get name of dump from which to extract the segment */
    call cu_$arg_ptr (3, tp, tc, code);			/* get possible pathname arg */
    if code = 0 then do;				/* if present, check for -pathname arg */
        if arg = "-pathname" | arg = "-pn" then do;
	  call cu_$arg_ptr (4, tp, tc, code);		/* get path */
	  if code ^= 0 then go to tell;		/* give user usage message */
	  call absolute_pathname_ (arg, dump_dir, code);	/* expand it */
	  if code ^= 0 then do;
	      call com_err_ (code, "extract", "expanding pathname ""^a""", arg);
	      return;
	    end;
	end;
        else go to tell;				/* give user usage message */
      end;
    call cu_$arg_ptr (2, tp, tc, code);			/* get name/number of segment to extract */
    if tc = 0 | code ^= 0 then goto tell;
    seg_no = cv_oct_check_ (arg, code);			/* assume octal arg was given */
    if code ^= 0 then segname = arg;
    dirname = get_wdir_ ();
    ename = arg || "." || dump_name;
    call hcs_$make_seg (dirname, ename, "", 01011b, p, code); /* make the segment to contain the data */
    if p = null then do;
        call com_err_ (code, "extract", "Creating ^a>^a", dirname, ename);
        return;
      end;
    delete_seg = ^(code = error_table_$namedup | code = error_table_$segknown);
						/* delete it if we can't do the work		*/
    if segname = "" then call copy_erf_seg_ (dump_name, seg_no, p, p_length, code);
    else call copy_erf_seg_$name (dump_name, segname, p, p_length, code);
    if code ^= 0 then do;
        call com_err_ (code, "extract", "Could not find ERF ^a using the dumps search list.", dump_name);
        if delete_seg then call delete_$ptr (p, "010111"b, "extract", code);
      end;
    else call terminate_file_ (p, 0, TERM_FILE_TERM, (0));
%page;
%include terminate_file;

  end extract;




		    find_config_card_.pl1           11/15/82  1825.9rew 11/15/82  1450.1       33507



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


/* FIND_CONFIG_CARD_ - Procedure to find a card in the config deck */
/* Adapted January 1980 by Larry Johnson from hardcore procedure 'config', written 3/12/74 by N. I. Morris */
/* Modified September 1982 by C. Hornig to remove common code to config_. */

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend */
find_config_card_:
     procedure;

dcl  p ptr parameter;				/* pointer to config card */
dcl  a_iom fixed bin (3) parameter;
dcl  a_chan fixed bin (6) parameter;

dcl  config_$find entry (char (4) aligned, ptr);
dcl  config_$find_periph entry (char (4) aligned, ptr);

dcl  card_iom fixed bin (3);
dcl  card_chan fixed bin (8);
dcl  card_nchan fixed bin;
dcl  i fixed bin;					/* iteration variable */

dcl  (hbound, null, substr) builtin;
%page;
/* PRPH_FOR_CHANNEL - Given an iom and channel, this entry returns
   the prph card for the device connected to the channel.

   calling sequence:

   call find_config_card_$prph_for_channel (iom, chann, p); */

prph_for_channel:
     entry (a_iom, a_chan, p);

	prph_cardp = null ();
	do while ("1"b);
	     call config_$find ("prph", prph_cardp);
	     if prph_cardp = null () then goto no_prph;
	     if substr (prph_card.name, 1, 3) = "tap" then do;
		prph_tap_cardp = prph_cardp;
		card_iom = prph_tap_card.iom;
		card_chan = prph_tap_card.chan;
		card_nchan = prph_tap_card.nchan;
		end;
	     else if substr (prph_card.name, 1, 3) = "dsk" then do;
		prph_dsk_cardp = prph_cardp;
		card_iom = prph_dsk_card.iom;

		card_chan = prph_dsk_card.chan;
		card_nchan = prph_dsk_card.nchan;
		end;
	     else do;
		card_iom = prph_card.iom;
		card_chan = prph_card.chan;
		card_nchan = 1;
		end;
	     if (card_iom = a_iom) & (card_chan <= a_chan) & (card_chan + card_nchan > a_chan) then do;
		p = prph_cardp;
		return;
		end;
	end;

no_prph:
	chnl_cardp = null ();
	do while ("1"b);
	     call config_$find ("chnl", chnl_cardp);
	     if chnl_cardp = null () then do;
		p = null ();
		return;
		end;
	     do i = 1 to hbound (chnl_card.group, 1) while (chnl_card.iom (i) ^= -1);
		if (chnl_card.iom (i) = a_iom) & (chnl_card.chan (i) <= a_chan)
		     & (chnl_card.chan (i) + chnl_card.nchan (i) > a_chan) then do;
		     call config_$find_periph (chnl_card.name, p);
						/* Get associated prph card */
		     return;
		     end;
	     end;
	end;
%page;
/* MPC_FOR_CHANNEL - Given an iom and channel, this entry returns
   the mpc card for the controller connected to the channel.

   calling sequence:

   call find_config_card_$mpc_for_channel (iom, chann, p); */

mpc_for_channel:
     entry (a_iom, a_chan, p);

	mpc_cardp = null ();
	do while ("1"b);
	     call config_$find ("mpc", mpc_cardp);
	     if mpc_cardp = null () then do;
		p = null ();
		return;
		end;
	     do i = 1 to hbound (mpc_card.port, 1) while (mpc_card.port (i).iom ^= -1);
		if (a_iom = mpc_card.port (i).iom) & (a_chan >= mpc_card.port (i).chan)
		     & (a_chan < mpc_card.port (i).chan + mpc_card.port (i).nchan) then do;
		     p = mpc_cardp;
		     return;
		     end;
	     end;
	end;
%page;
%include config_chnl_card;
%include config_mpc_card;
%include config_prph_card;
%include config_prph_dsk_card;
%include config_prph_tap_card;

     end find_config_card_;





		    identify_io_channel_.pl1        03/25/86  0857.0rew 03/25/86  0856.3       51219



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



/****^  HISTORY COMMENTS:
  1) change(85-09-09,Farley), approve(85-09-09,MCR6979),
     audit(86-02-19,Coppola), install(86-03-21,MR12.0-1033):
     Support IMU.
                                                   END HISTORY COMMENTS */

/* format: style2,indcomtxt */
identify_io_channel_:
     procedure (P_configp, P_iom, P_channel, P_name, P_code);

/* Procedure to identify individual IOM channels */
/* Split out of interrupt_meters, August, 1981, W. Olin Sibert */
/* Modified for prph fnp cards BIM 83-12-15 */
/* Modified Feb 1985 by Paul Farley for IMU changes */

	dcl     P_configp		 pointer parameter; /* Pointer to config deck used for channel identification */
	dcl     P_iom		 fixed bin (3) parameter;
						/* IOM number */
	dcl     P_channel		 fixed bin (8) parameter;
						/* Channel number */
	dcl     P_name		 char (*) parameter;/* Returned, interpreted channel name */
	dcl     P_code		 fixed bin (35) parameter;

	dcl     iom		 fixed bin (3);
	dcl     channel		 fixed bin (8);

	dcl     error_table_$bad_channel
				 fixed bin (35) external static;

	dcl     OVERHEAD_CHANNELS	 (0:7) char (32) varying internal static options (constant)
				 init ("overhead channel zero", "system fault", "connect", "snapshot",
				 "wraparound", "bootload", "special", "scratchpad");

	dcl     IOM_NAMES		 (1:8) char (8) varying internal static options (constant)
				 init ("IOM A", "IOM B", "IOM C", "IOM D", "IOM E", "IOM F", "IOM G", "IOM H");

	dcl     IMU_OVERHEAD_CHANNELS	 (0:7) char (32) varying internal static options (constant)
				 init ("overhead channel zero", "system fault", "connect", "mca",
				 "overhead channel four", "bootload", "special", "overhead channel seven");

	dcl     IMU_NAMES		 (1:8) char (8) varying internal static options (constant)
				 init ("IMU A", "IMU B", "IMU C", "IMU D", "IMU E", "IMU F", "IMU G", "IMU H");

	dcl     TAGS		 (1:8) char (1) aligned internal static options (constant)
				 init ("a", "b", "c", "d", "e", "f", "g", "h");

	dcl     (addr, addrel, divide, hbound, max, min, null, size, substr)
				 builtin;

/**/

	iom = P_iom;
	channel = P_channel;

	if (iom < 1) | (iom > 4) | (channel < 0) | (channel > 63)
	then do;
INVALID_IO_CHANNEL:
		P_name = "invalid channel number";
		P_code = error_table_$bad_channel;
		return;
	     end;

	if P_configp = null ()
	then /* Default is running system config deck */
	     cardp = addr (config_deck$);		/* Prepare to look through the config deck */
	else cardp = P_configp;

	P_name = lookup ();
	P_code = 0;				/* Consider successful, even if unidentifiable */

	return;					/* All done */

/**/

lookup:
     procedure () returns (char (32));

/* This procedure returns the "name" of the specified channel, as best it can */

	dcl     first_channel	 fixed bin (8);
	dcl     last_channel	 fixed bin (8);
	dcl     field		 fixed bin;


	if (channel <= hbound (OVERHEAD_CHANNELS, 1))
	then do;
		do while (config_card.word ^= FREE_CARD_WORD);
						/* look for sentinel at end */
		     if config_card.word = IOM_CARD_WORD
		     then do;
			     iom_cardp = cardp;
			     if iom_card.tag = iom
			     then do;
				     if iom_card.model = "imu" | iom_card.model = "iioc"
				     then return (IMU_NAMES (iom) || " " || IMU_OVERHEAD_CHANNELS (channel));
				     else return (IOM_NAMES (iom) || " " || OVERHEAD_CHANNELS (channel));

				end;
			end;
		     cardp = addrel (cardp, size (config_card));
						/* On to the next config card */
		end;
		return (IOM_NAMES (iom) || " " || OVERHEAD_CHANNELS (channel));
	     end;

	do while (config_card.word ^= FREE_CARD_WORD);	/* look for sentinel at end */

	     if config_card.word = CHNL_CARD_WORD
	     then do;
		     chnl_cardp = cardp;

		     do field = 1 to hbound (chnl_card_array.group, 1);
						/* Loop through channels which exist */
			first_channel = chnl_card.chan (field);
			last_channel = chnl_card.chan (field) + chnl_card.nchan (field) - 1;

			if iom = chnl_card.iom (field)
			then if channel >= first_channel
			     then if channel <= last_channel
				then return (chnl_card.name);
		     end;
		end;

	     else if config_card.word = PRPH_CARD_WORD
	     then do;
		     prph_cardp = cardp;
		     prph_dsk_cardp = cardp;
		     prph_tap_cardp = cardp;

		     if iom ^= prph_card.iom
		     then goto NEXT_CARD;

		     first_channel = prph_card.chan;

		     if /* case */ substr (prph_card.name, 1, 3) = "dsk"
		     then last_channel = first_channel + prph_dsk_card.nchan - 1;
		     else if substr (prph_card.name, 1, 3) = "tap"
		     then last_channel = first_channel + prph_tap_card.nchan - 1;
		     else last_channel = first_channel;

		     if channel >= first_channel
		     then if channel <= last_channel
			then return (prph_card.name);
		end;

NEXT_CARD:
	     cardp = addrel (cardp, size (config_card));	/* On to the next config card */
	end;

	return ("unidentifiable channel");

     end lookup;

%page;
%include config_deck;
%page;
%include config_iom_card;
%page;
%include config_chnl_card;
%page;
%include config_prph_card;
%page;
%include config_prph_tap_card;
%page;
%include config_prph_dsk_card;

     end identify_io_channel_;




		    mc_trace.pl1                    11/15/82  1825.9rew 11/15/82  1450.1      193473



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


mc_trace: mct: proc;

/* mc_trace - machine condition trace, initially coded March 1977 by James A. Bush
   taken from original idea by Bernie Greenberg and Steve Webber
   Modified 780327 by J. A. Bush to add -all and -hc control args
   Modified Oct 1982 by Rich Coppola to disable tracing when displaying
   MCs or hregs. Also corrected hreg headers when hregs are from a DPS8 CPU.
*/


dcl  cu_$cp entry (ptr, fixed bin, fixed bin (35));
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  phcs_$trace_buffer_init entry (ptr, bit (1) aligned, fixed bin, ptr, fixed bin (35));
dcl  phcs_$hc_trace_on_off entry (bit (1) aligned, fixed bin (35));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl (ioa_, com_err_, ioa_$ioa_switch, ioa_$ioa_switch_nnl) entry options (variable);
dcl  iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  prtscu_$on_line entry (ptr, ptr, bit (1));
dcl  dump_machine_cond_$mc_only entry (ptr, char (32));
dcl  get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin);
dcl  find_condition_info_ entry (ptr, ptr, fixed bin (35));
dcl  ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35));
dcl  ring0_get_$name entry (char (*), char (*), ptr, fixed bin (35));
dcl  continue_to_signal_ entry (fixed bin (35));
dcl  hran_$hrlgnd entry (ptr);
dcl  hran_$hranl entry (ptr, ptr, bit (1));

dcl (null, fixed, addr, addrel, divide, baseno, baseptr, length, substr, rel, ltrim, search) builtin;

dcl (iox_$user_input, iox_$error_output) ptr ext;
dcl (any_other, cleanup) condition;
dcl  dir_name char (168);
dcl  ename char (32);
dcl  com_string char (132) aligned;
dcl  arg char (al) based (ap);
dcl (code, lp_cnt) fixed bin (35);
dcl (i, j, k, acnt, al, lp) fixed bin;
dcl (ap, sp, mcp, scup) ptr;
dcl  mc_pos (260) fixed bin unaligned;
dcl  p_name char (8) init ("mc_trace");
dcl  ll fixed bin (21);
dcl  buf_size fixed bin init (5);			/* default buffer size */
dcl (trace_on, brief, lo, path_sw, buf_sw, hc_all, hc_sw) bit (1) unaligned init ("0"b);
dcl  WS char (2) int static options (constant) init (" 	");


% include mc_trace_buf;

/*  */

/* process arguments */

	call cu_$arg_count (acnt);			/* get no of args */
	if acnt = 0 then do;			/* tell user what to do */
arger:
	     call com_err_ (0, p_name, "Usage: ^a path {-brief | -bf} {-buffer <size> | -buf <size>}", p_name);
	     return;
	end;
	do i = 1 to acnt;				/* process arguments */
	     call cu_$arg_ptr (i, ap, al, code);	/* get arg */
	     if code ^= 0 then do;			/* some days you can't win */
		call com_err_ (code, p_name, "getting arg");
		return;
	     end;
	     if arg = "-all" | arg = "-hc" then do;	/* if special trace */
		hc_all, path_sw = "1"b;
		if arg = "-all" then		/* if tracing all faults and interrupts */
		     sp = baseptr (0);		/* set indicator for hardcore */
		else hc_sw = "1"b;			/* tracing hardcore seg */
	     end;
	     else if ^path_sw then do;		/* if not special trace, pathname arg must be first */
		path_sw = "1"b;
		call expand_pathname_ (arg, dir_name, ename, code);
		if code ^= 0 then do;		/* some problem with pathname */
		     call com_err_ (code, p_name, "expanding pathname ^a", arg);
		     return;
		end;
	     end;
	     else if hc_sw then do;			/* user wants to trace hard core seg */
		hc_sw = "0"b;
		lp_cnt = cv_oct_check_ (arg, code);	/* convert to seg number */
		if code ^= 0 then do;		/* might be name */
		     call ring0_get_$segptr ("", arg, sp, code);
		     if code ^= 0 then do;		/* user got something wrong */
			call com_err_ (code, p_name, "getting hardcore segment ^a", arg);
			return;			/* let him re-enter */
		     end;
		end;
		else do;				/* user entered number, verify */
		     sp = baseptr (lp_cnt);		/* that it is a valid hc seg */
		     call ring0_get_$name ("", ename, sp, code);
		     if code ^= 0 then do;		/* not a valid hc seg */
			call com_err_ (code, p_name, "getting hardcore segment ^o", lp_cnt);
			return;			/* return and make him get it right */
		     end;
		end;
		if fixed (baseno (sp)) = 0 then	/* tracing dseg will get all faults and ints. */
		     call com_err_ (0, p_name, "Warning tracing segment # 0 will result in tracing all faults and interrupts");
	     end;
	     else if buf_sw then do;			/* got buffer size arg */
		buf_sw = "0"b;			/* don't want to come here again */
		lp_cnt = cv_dec_check_ (arg, code);
		buf_size = lp_cnt;
		if code ^= 0 | buf_size > max_buf_size | buf_size <= 0 then do; /* user goofed */
		     call com_err_ (0, p_name, "buffer size arg ^a invalid or too big", arg);
		     return;
		end;
	     end;
	     else if arg = "-buffer" | arg = "-buf" then	/* user wants a bigger buffer */
		buf_sw = "1"b;
	     else if arg = "-brief" | arg = "-bf" then	/* user does not want prompt */
		brief = "1"b;			/* set brief switch */
	     else do;
		call com_err_ (0, p_name, "Invalid argument ^a", arg);
		go to arger;
	     end;
	end;


/* initiate object segment to trace */

	if ^hc_all then do;				/*  if ring 4 segment to be traced */
	     call hcs_$initiate (dir_name, ename, "", 0, 0, sp, code);
	     if sp = null then do;			/* can't find it */
		call com_err_ (code, p_name, "initiating object segment ^a>^a", dir_name, ename);
		return;
	     end;
	end;

/* Now we are ready to start the hardcore trace */

	call phcs_$trace_buffer_init (sp, "1"b, buf_size, bp, code);
	if code ^= 0 then do;			/* must have had problem starting trace */
	     call com_err_ (code, p_name, "attempting to initialize hardcore tracing");
	     return;
	end;
	trace_on = "1"b;				/* set switch to indicate we are traceing */

	on any_other begin;
	     call cond_hand;			/* set up condition handler */
	     call phcs_$hc_trace_on_off ("0"b, code);	/* turn off hardcore tracing mechanism */
	end;

	on cleanup call clean;			/* set up condition handler for cleanup condition */

/* Now we are ready to ask user for input to trace something */

request:
	com_string = "";				/* clear out last command */
	if ^brief then				/*  if not in brief mode */
	     call ioa_$ioa_switch_nnl (iox_$error_output, "--> "); /* print out prompt for user */
	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, p_name, "reading input from user_input");
	     go to request;
	end;
	ll = ll - 1;				/* adjust line length to ignor the N. L. char */
	if ll = 0 then go to request;			/* ignor white space */

/* strip off leading white space */

	i = length (ltrim (substr (com_string, 1, ll), WS));
	j = (ll - i) + 1;				/* get start of good data */
	substr (com_string, 1, i) = substr (com_string, j, ll);
	substr (com_string, i + 1) = "";		/* pad rest of line with blanks */

/* Process requests */

	if substr (com_string, 1, 1) ^= "." then do;	/* user made syntax error */
errsp:
	     call com_err_ (0, p_name, "Invalid response ^a, reenter", com_string);
	     go to request;
	end;
	ll = i;					/* copy new line length */
	if ll = 1 then				/* user wants to know where he is at */
	     call ioa_ ("^a", p_name);		/* so tell him */
	else if substr (com_string, 1, ll) = ".q" then do; /* user wants to quit */
	     call clean;				/* clean up */
	     return;
	end;					/* and exit */
	else if substr (com_string, 1, 2) = ".." then do; /* user wants to execute Multics cmd */
	     substr (com_string, 1, ll - 2) = substr (com_string, 3, ll - 2); /* adjust cmd in buffer */
	     call phcs_$hc_trace_on_off ("1"b, code);	/* turn on hardcore tracing mechanism */
	     if code ^= 0 then do;			/* can't turn trace on */
		call com_err_ (code, p_name, "attempting to turn trace on");
		go to request;
	     end;
	     call cu_$cp (addr (com_string), ll - 2, code); /* and execute cmd */
	     call phcs_$hc_trace_on_off ("0"b, code);	/* turn off hardcore tracing mechanism */
	end;
	else if substr (com_string, 1, 4) = ".rpt" then do; /* user wants to repeat cmd */
	     lp = 5;				/* set line position */
	     lp_cnt = parse ();			/* get the loop count arg */
	     if lp_cnt = -1 then			/* user goofed typing in */
		go to errsp;
	     j = ll - lp + 1;
	     substr (com_string, 1, j) = substr (com_string, lp, j); /* adjust cmd */
	     call phcs_$hc_trace_on_off ("1"b, code);	/* turn on hardcore tracing mechanism */
	     if code ^= 0 then do;			/* can't turn trace on */
		call com_err_ (code, p_name, "attempting to turn trace on");
		go to request;
	     end;
	     do i = 1 to lp_cnt;			/* execute cmd requested number of times */
		call cu_$cp (addr (com_string), j, code);
	     end;
	     call phcs_$hc_trace_on_off ("0"b, code);	/* turn off hardcore tracing mechanism */
	end;
	else if substr (com_string, 1, 5) = ".pmc " then	/* user wants to print M. C. */
	     call display_mc (5, 1);			/* display M. C. in octal */
	else if substr (com_string, 1, 5) = ".pmci" then	/* user wants interpreted M. C. */
	     call display_mc (6, 2);			/* display M. C. interpreted */
	else if substr (com_string, 1, 5) = ".pscu" then	/* user wants only scu data */
	     call display_mc (6, 3);			/* Display M. C. scu data only */
	else if substr (com_string, 1, 4) = ".hr " then	/* User wants to see history regs in octal */
	     call display_hregs (4, 1, "1"b);		/* display all history regs */
	else if substr (com_string, 1, 5) = ".hrou" then	/* user wants only OU history regs */
	     call display_hregs (6, 1, "0"b);
	else if substr (com_string, 1, 5) = ".hrcu" then	/* user only wants to see CU histroy regs */
	     call display_hregs (6, 2, "0"b);
	else if substr (com_string, 1, 5) = ".hrdu" then	/* user wants to see DU history regs */
	     call display_hregs (6, 3, "0"b);
	else if substr (com_string, 1, 5) = ".hrau" then	/* user wants to see APU History regs */
	     call display_hregs (6, 4, "0"b);
	else if substr (com_string, 1, 6) = ".hranl" then /* user wants analisis of history regs */
	     call display_hregs (7, 5, "0"b);
	else if substr (com_string, 1, 6) = ".hrlgd" then do; /* user wants to know what abrevs mean */
	     call ioa_ ("^/Abbreviations used in History Register Analysis^/");
	     call hran_$hrlgnd (null);
	end;
	else go to errsp;				/* invalid request */
	go to request;				/* get nxt request */


/* display_mc - internal procedure to display requested number of Machine Conditions from the M. C. buffer */

display_mc: proc (line_pos, type);
dcl (line_pos, type, count, limit) fixed bin;

	     call phcs_$hc_trace_on_off ("0"b, code);	/* turn off hardcore tracing mechanism */

	     j = mc_trace_buf.mc_nxtad;		/* start with next avail location */
	     if j = mc_trace_buf.mc_strt then		/* if at beginning of buffer */
		if mach_cond (1).scu_dta (1) = buf_init then do; /* no M. C. stored */
		     call ioa_ ("Machine Condition buffer empty");
		     return;
		end;
	     call get_args (line_pos, count, limit);	/* get further args */
	     if count = 0 then			/* No args set count to display entire buffer */
		count = mc_trace_buf.mc_cnt;

/* first get cronilogical order of M. C.'s, last to first */
	     do i = 1 to count;			/* get each requested M. C. */
		if j = mc_trace_buf.mc_strt then	/* if at beginning of buffer */
		     j = (mc_cnt - 1) * mc_size + mc_trace_buf.mc_strt; /* set to last M. C. */
		else j = j - mc_size;		/* just decrement to nxt M. C. */
		k = divide ((j + mc_size) - mc_trace_buf.mc_strt, mc_size, 17, 0); /* get array index */
		if mach_cond (k).scu_dta (1) ^= buf_init then mc_pos (i) = k; /* if M. C. valid */
		else go to too_many;		/* if not valid, exit */
	     end;
too_many:
	     if i - 1 ^= count then do;		/* if not all requested M. C.'s valid */
		call ioa_ ("Only ^d sets of Machine Conditions are valid", i - 1);
		count = i - 1;			/* adjust count */
	     end;
	     call set_line_length;			/* set up output length parameters */
	     if limit = 0 | limit > count then		/* set up defaults */
		limit = 1;
	     else limit = count - (limit - 1);
	     do i = count to limit by -1;		/* this  is really forward */
		j = mc_pos (i);
		mcp = addr (mc_trace_buf.mach_cond (j)); /* form ptr to machine condition */
		call ioa_ ("^/^/*****Machine Conditions at mc_trace_buffer|^o*****",
		     fixed (rel (mcp)));
		go to mc_prt (type);		/* print  M. C.'s in requested form */
mc_prt (1):					/* display M. C.'s in octal format */
		call ioa_ ("^/Pointer Registers");
		call display_oct (addr (mach_cond (j).spri_dta (1)), 2); /* print in octal format */
		call ioa_ ("^/Processor Registers");
		call display_oct (addr (mach_cond (j).sreg_dta (1)), 1); /* print in octal format */
		call ioa_ ("^/SCU Data");
		call display_oct (addr (mach_cond (j).scu_dta (1)), 1); /* print in octal format */
		call ioa_ ("^/Software Data");
		call display_oct (addr (mach_cond (j).sw_dta (1)), 1); /* print in octal format */
		call ioa_ ("^/EIS Pointers and Lengths");
		call display_oct (addr (mach_cond (j).spl_dta (1)), 1); /* print in octal format */
		go to p_nxt;			/* go print next M. C. */
mc_prt (2):					/* display M. C.'s in interpreted form */
		call ioa_ (" ");
		call dump_machine_cond_$mc_only (mcp, "user_output"); /* that was simple */
		go to p_nxt;			/* go print next M.C. */
mc_prt (3):					/* display SCU data only */
		scup = addr (mc_trace_buf.mach_cond (j).scu_dta (1)); /* set up ptr first */
		call ioa_ ("^/SCU data at mc_trace_buffer|^o^/", fixed (rel (scup)));
		call prtscu_$on_line (null, scup, "1"b); /* interpret scu data */
p_nxt:
	     end;
	end display_mc;

/* parse - internal procedure to parse cmd line for numerical string and return as decimal constant */

parse:	proc returns (fixed bin (35));
dcl  count fixed bin (35);

	     if lp > ll then			/* if at end of line */
		return (-1);
	     i = length (ltrim (substr (com_string, lp, ll - lp), WS)); /* strip off leading white space */
	     lp = lp + ((ll - lp) - i);		/* update line position */
	     i = search (substr (com_string, lp), WS);	/* find end of string */
	     count = cv_dec_check_ (substr (com_string, lp, i - 1), code); /* convert to decimal */
	     if code ^= 0 then			/* not decimal number return w/error */
		return (-1);
	     lp = lp + i;				/* update line position */
	     return (count);
	end parse;

/* clean - internal procedure to turn off trace and unwire trace buffer */

clean:	proc;

	     if trace_on then do;			/* turn trace off if on */
		call phcs_$trace_buffer_init (sp, "0"b, buf_size, bp, code);
		if code ^= 0 then
		     call com_err_ (code, p_name, "attempting to turn trace off");
		trace_on = "0"b;
	     end;
	end clean;

/* set_line_length - internal procedure to set output length parameters based on the terminal line length */

set_line_length: proc;
	     i = get_line_length_$switch (null, code);	/* get terminal line length */
	     if i < 104 & code = 0 then
		lo = "0"b;
	     else lo = "1"b;
	end set_line_length;

/*  */

/* display_hregs - internal procedure to display requested number of history registers */

display_hregs: proc (line_pos, type, cont);
dcl  cont bit (1);
dcl (line_pos, type, count, limit, cpu_type) fixed bin;

	     call phcs_$hc_trace_on_off ("0"b, code);	/* turn off hardcore tracing mechanism */

	     j = mc_trace_buf.hr_nxtad;		/* start with next avail location */
	     if j = mc_trace_buf.hr_strt then		/* if at beginning of buffer */
		if substr (h_regs (1).ou_hr (1), 1, 36) = buf_init then do; /* no H. R. stored */
		     call ioa_ ("History Register buffer empty");
		     return;
		end;
	     call get_args (line_pos, count, limit);	/* get further args */
	     if count = 0 then			/* No args set count to display entire buffer */
		count = mc_trace_buf.hr_cnt;

/* first get cronilogical order of H. R.'s, last to first */
	     do i = 1 to count;			/* get each requested H. R. */
		if j = mc_trace_buf.hr_strt then	/* if at beginning of buffer */
		     j = (hr_cnt - 1) * hr_size + mc_trace_buf.hr_strt; /* set to last H. R. */
		else j = j - hr_size;		/* just decrement to nxt H. R. */
		k = divide ((j + hr_size) - mc_trace_buf.hr_strt, hr_size, 17, 0); /* get array index */
		if substr (h_regs (k).ou_hr (1), 1, 36) ^= buf_init then mc_pos (i) = k; /* if H. R. valid */
		else go to too_many2;		/* if not valid, exit */
	     end;
too_many2:
	     if i - 1 ^= count then do;		/* if not all requested H. R.'s valid */
		call ioa_ ("Only ^d sets of History Registers are valid", i - 1);
		count = i - 1;			/* adjust count */
	     end;
	     call set_line_length;			/* set up output length parameters */
	     if limit = 0 | limit > count then		/* set up defaults */
		limit = 1;
	     else limit = count - (limit - 1);
	     do i = count to limit by -1;		/* this  is really forward */
		j = mc_pos (i);
		call ioa_ ("^2/*****History Registers at mc_trace_buffer|^o*****",
		     fixed (rel (addr (mc_trace_buf.h_regs (j)))));
		if substr (h_regs (j).du_hr (1), 72, 1) = "1"b then
		     cpu_type = 0;			/* its a l68 */
		go to dhr (type);			/* display requested history reg */

dhr (1):						/* label for OU history register display */
		if cpu_type = 0 then
		     call ioa_ ("^/Operations Unit (OU) History Registers");
		else call ioa_ ("^/Decimal Unit/Operations Unit (DU/OU) History Registers");
		call display_oct (addr (h_regs (j).ou_hr (1)), 4); /* print out octal history regs */
		if ^cont then go to p_nxt1;		/* user wants OU history regs only */
dhr (2):						/* label for CU History Registers */
		call ioa_ ("^/Control Unit (CU) History Registers");
		call display_oct (addr (h_regs (j).cu_hr (1)), 4); /* print out octal history regs */
		if ^cont then go to p_nxt1;		/* user wants CU history regs only */
dhr (3):						/* label for DU history reg display */
		if cpu_type = 0 then
		     call ioa_ ("^/Decimal Unit (DU) History Registers");
		else call ioa_ ("^/Appending Unit #2 (AU2) History Registers");
		call display_oct (addr (h_regs (j).du_hr (1)), 4); /* print out octal history regs */
		if ^cont then go to p_nxt1;		/* user wants du history regs only */
dhr (4):						/* label for APU history reg display */
		if cpu_type = 0 then
		     call ioa_ ("^/Appending Unit (AU) History Registers");
		else call ioa_ ("^/Appending Unit #1 (AU1) History Registers");
		call display_oct (addr (h_regs (j).au_hr (1)), 4); /* print out octal history regs */
		go to p_nxt1;
dhr (5):
		call ioa_ ("^/Composite Analysis of History Registers^/");
		call hran_$hranl (addr (h_regs (j).ou_hr (1)), null, lo);
p_nxt1:
	     end;
	end display_hregs;


/* display_oct - internal procedure for displaying a requested number of 8 word blocks in octal to stream user_output */

display_oct: proc (iwp, sets);

dcl (iwp, wp) ptr;
dcl (sets, i) fixed bin;

dcl  w (8) fixed bin based (wp);

	     wp = iwp;				/* copy pointer */
	     do i = 1 to sets;			/* iterate requested number of times */
		call ioa_ ("^4(^w ^)^[^;^/^]^4(^w ^)",
		     w (1), w (2), w (3), w (4), lo, w (5), w (6), w (7), w (8));
		wp = addrel (wp, 8);		/* increment pointer */
	     end;
	end display_oct;

/* get_args - internal procedure to get numerical args from cmd line and return count and limit values */

get_args:	proc (init_lp, cnt, lmt);
dcl (init_lp, cnt, lmt) fixed bin;

	     cnt, lmt = 0;				/* initially set returns to 0 */
	     if init_lp >= ll then			/* no further args */
		return;
	     lp = init_lp;				/* set up line position */
	     lp_cnt = parse ();			/* get count arg */
	     if lp_cnt = -1 then			/* conversion error */
		go to errsp;			/* no local goto */
	     cnt = lp_cnt;				/* conversion ok set return count parameter */
	     lp_cnt = parse ();
	     if lp_cnt ^= -1 then			/* set limit only if valid */
		lmt = lp_cnt;
	end get_args;

/*  */

/* cond_hand - internal procedure to implement the "any_other" condition handler */

cond_hand: proc;
dcl  ec fixed bin (35);
dcl 1 condinfo aligned,
% include cond_info;

     call find_condition_info_ (null, addr (condinfo), ec); /* get  some info about condition */

/* pass on any condition we can not handle */

	     if condition_name = "alrm" then go to cts;
	     if condition_name = "cput" then go to cts;
	     if condition_name = "program_interrupt" then go to cts;
	     if condition_name = "mme2" then go to cts;
	     if condition_name = "stack" then go to cts;
	     if condition_name = "command_error" then go to cts;
	     if condition_name = "finish" | condition_name = "cleanup" then do;
		call clean;
cts:
		call continue_to_signal_ (ec);
		return;
	     end;
	     call phcs_$hc_trace_on_off ("0"b, ec);	/* turn off hardcore tracing mechanism */
	     call ioa_$ioa_switch (iox_$error_output, "^a condition raised, enter command",
		condition_name);
	     go to request;
	end cond_hand;

     end mc_trace;




		    mcs_version.pl1                 10/25/89  1202.5r w 10/25/89  1000.0       28755



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


mcs_version: proc;

/* a command/active function that returns/prints the name of the version
   *  of MCS most recently bootloaded into a specified FNP (defaults to a)
   *
   *  Written 6/9/77 by Robert Coren
*/


/* ENTRIES */

dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl (ioa_, com_err_, active_fnc_err_) entry options (variable);
dcl  ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35));
dcl  ring_zero_peek_ entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  parse_fnp_name_ entry (char (*), fixed bin);

dcl  err_entry entry variable options (variable);


/* ARGUMENT STUFF */

dcl  ret_ptr ptr;
dcl  ret_l fixed bin;
dcl  ret_str char (ret_l) varying based (ret_ptr);

dcl  argp ptr;
dcl  argl fixed bin;
dcl  arg char (argl) based (argp);


/* EXT STATIC */

dcl (error_table_$not_act_fnc,
     error_table_$too_many_args)
     fixed bin (35) ext static;


/* INTERNAL STATIC */

dcl  prog_name char (11) int static options (constant) init ("mcs_version");


/* AUTOMATIC */

dcl  code fixed bin (35);
dcl  nargs fixed bin;
dcl  fnp_no fixed bin;
dcl  sourcep ptr;
dcl  our_version char (4);
dcl  af bit (1);


dcl (addr, index) builtin;

%include dn355_data;

	call cu_$af_return_arg (nargs, ret_ptr, ret_l, code);
	if code = error_table_$not_act_fnc
	then do;
	     af = "0"b;
	     err_entry = com_err_;
	     call cu_$arg_count (nargs);
	end;

	else if code ^= 0
	then do;
	     call active_fnc_err_ (code, prog_name);
	     return;
	end;

	else do;
	     af = "1"b;
	     err_entry = active_fnc_err_;
	end;

	if nargs = 0
	then fnp_no = 1;

	else if nargs = 1
	then do;
	     call cu_$arg_ptr (1, argp, argl, code);
	     call parse_fnp_name_ (arg, fnp_no);
	     if fnp_no < 0
	     then do;
		call err_entry (0, prog_name, "Invalid FNP tag ^a", arg);
		return;
	     end;
	end;

	else do;
	     call err_entry (error_table_$too_many_args, prog_name,
		"Usage:  mcs_version {fnp_tag}");
	     return;
	end;

	call ring0_get_$segptr ("", "dn355_data", infop, code);
	if code ^= 0
	then do;
	     call err_entry (code, prog_name, "Could not get pointer to dn355_data");
	     return;
	end;

	sourcep = addr (datanet_info.per_datanet (fnp_no).version);
	call ring_zero_peek_ (sourcep, addr (our_version), 1, code);
	if code ^= 0
	then do;
	     call err_entry (code, prog_name, "Could not copy version from dn355_data");
	     return;
	end;
	if our_version = "" | our_version = low (4) then our_version = "none";

	if af
	then ret_str = our_version;
	else call ioa_ (our_version);

	return;
     end /* mcs_version */ ;




		    parse_io_channel_name_.pl1      11/15/82  1825.9rew 11/15/82  1450.1       18468



/* ***********************************************************
   *                                                         *
   * 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 */
parse_io_channel_name_:
     proc (arg_string, arg_iom, arg_channel, arg_code);

/* PARSE_IO_CHANNEL_NAME_ - Procedure to parse a character string representing an iom and channel */
/* Written February 1980 by Larry Johnson */
/* Modified 11 August, 1981, W. Olin Sibert, for decimal channel numbers */
/* Modified October 1982 by C. Hornig for new PRPH TAP card. */

/* The format of the string is:
   tdd - an iom tag (a thru h) followed by a channel number */

/* Arguments */

dcl  arg_string char (*);
dcl  arg_iom fixed bin (3);
dcl  arg_channel fixed bin (8);
dcl  arg_code fixed bin (35);

/* Automatic */

dcl  code fixed bin (35);
dcl  iom fixed bin (3);
dcl  channel fixed bin (35);

/* External */

dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));

dcl  error_table_$bad_channel fixed bin (35) ext static;

dcl  (index, length, substr) builtin;
%page;
	if length (arg_string) < 1 then do;
error:
	     arg_iom = 0;
	     arg_channel = 0;
	     arg_code = error_table_$bad_channel;
	     return;
	     end;

	iom = index ("abcdefgh", substr (arg_string, 1, 1));
	if iom = 0 then iom = index ("ABCDEFGH", substr (arg_string, 1, 1));
	if iom = 0 then go to error;
	if length (arg_string) < 2 then go to error;
	channel = cv_dec_check_ (substr (arg_string, 2), code);
	if code ^= 0 then go to error;
	if channel < 0 | channel > 63 then go to error;

	arg_iom = iom;
	arg_channel = channel;
	arg_code = 0;
	return;

     end parse_io_channel_name_;




		    patch_ring_zero.pl1             11/15/82  1825.9rew 11/15/82  1505.7       44028



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


patch_ring_zero:
prz:
     procedure () options (variable);

/* This procedure allows privileged users to patch locations in ring 0.
   If necessary the descriptor segment is patched to give access to patch a non-write
   permit segment */

dcl  tc fixed bin (21);
dcl  tp pointer;
dcl  targ char (tc) based (tp);
dcl  code fixed bin (35);
dcl  i fixed bin;
dcl  first fixed bin;
dcl  force_sw bit (1) aligned;
dcl  processid bit (36) aligned;
dcl  data (0 : 99) fixed bin (35);
dcl  data1 (0 : 99) fixed bin (35);
dcl  count fixed bin (18);
dcl  datap pointer;
dcl  data1p pointer;
dcl  ok_to_patch bit (1) aligned;
dcl  segptr pointer;
dcl  dsp0 pointer;
dcl  tsdwp pointer;

dcl 1 tsdw aligned like sdw automatic;

dcl  error_table_$noarg fixed bin (35) external static;

dcl  com_err_ entry options (variable);
dcl  command_query_$yes_no entry options (variable);
dcl  cv_oct_ entry (char (*)) returns (fixed bin (35));
dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, pointer, fixed bin (21), fixed bin (35));
dcl  get_process_id_ entry () returns (bit (36) aligned);
dcl  hphcs_$pxss_set_timax entry (bit (36) aligned, fixed bin (35));
dcl  hphcs_$ring_0_patch entry (pointer, pointer, fixed bin (18));
dcl  ioa_ entry options (variable);
dcl  ring_zero_peek_ entry (pointer, pointer, fixed bin (18), fixed bin (35));
dcl  ring0_get_$segptr entry (char (*), char (*), pointer, fixed bin (35));

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

dcl (fixed, null, addr, baseno, baseptr, ptr) builtin;

/*  */

	datap = addr (data);			/* get pointer to data area */
	count = 0;

	call cu_$arg_ptr (1, tp, tc, code);		/* pick up the first arg (name/number) */
	if code = error_table_$noarg then do;
mess:	     call com_err_ (0, WHOAMI, "Usage: ^a name/segno offset value1 ... valueN", WHOAMI);
	     return;
	end;
	i = cv_oct_check_ (targ, code);		/* get segment number */
	if code ^= 0 then do;			/* didn't give number */
	     segptr = null;				/* if null we're still in trouble */
	     call ring0_get_$segptr ("", targ, segptr, code); /* so assume ring 0 name */
	     if segptr = null then do;
		call com_err_ (0, WHOAMI, "^a not found.", targ);
		return;
	     end;
	     i = fixed (baseno (segptr));		/* get segment number */
	end;
	else segptr = baseptr (i);			/* segment number given */

	call cu_$arg_ptr (2, tp, tc, code);		/* pick up second arg (first word to dump ) */
	if code = error_table_$noarg then go to mess;
	first = cv_oct_ (targ);
	segptr = ptr (segptr, first);
	call ring0_get_$segptr ("", "dseg", dsp0, code);
	tsdwp = addr (dsp0 -> sdwa (i));		/* get a pointer to the SDW */


/* Now pick off the arguments */

	i = 2;
loop:	i = i + 1;				/* get next argument */
	call cu_$arg_ptr (i, tp, tc, code);
	if code = error_table_$noarg then go to endarg;
	data1 (i-3) = cv_oct_ (targ);			/* convert i'th arg */
	go to loop;
endarg:
	count = i - 3;
	if count = 0 then go to mess;
	call ring_zero_peek_ (segptr, datap, count, code);
	if code ^= 0 then do;
	     call com_err_ (code, WHOAMI);
	     return;
	end;
	do i = 0 to count-1;
	     call ioa_ ("^6o  ^w to ^w", first+i, data (i), data1 (i));
	end;

	call command_query_$yes_no (ok_to_patch, 0, WHOAMI, "", "Type ""yes"" if patches are correct:");
	if ^ok_to_patch then return;

/* Now set priority so that syserr messages dont hang process */

	processid = get_process_id_ ();
	call hphcs_$pxss_set_timax (processid, 1);

/* Now check the access on the segment about to be patched */

	data1p = addr (data1);
	call ring_zero_peek_ (tsdwp, addr (tsdw), size (tsdw), code); /* copy out the SDW */
	if code ^= 0 then do;
	     call com_err_ (code, WHOAMI, "Cannot get SDW for ^o", binary (baseno (segptr)));
	     return;
	end;

	if ^tsdw.write then do;
	     tsdw.write = "1"b;
	     force_sw = "1"b;
	     call hphcs_$ring_0_patch (addr (tsdw), tsdwp, size (tsdw));
	end;
	else force_sw = "0"b;			/* indicates we don't have to restore SDW */


/* Now do the patches */

	call hphcs_$ring_0_patch (data1p, segptr, count);

/* Now reset access (in dseg) if necessary */

	if force_sw then do;
	     tsdw.write = "0"b;
	     call hphcs_$ring_0_patch (addr (tsdw), tsdwp, size (tsdw));
	end;

	if processid ^= (36)"1"b then call hphcs_$pxss_set_timax (processid, -1);

	return;

%page; %include sdw;

     end;




		    read_early_dump_tape.pl1        01/26/85  1311.3r w 01/22/85  1300.8      138060



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
read_early_dump_tape: redt: proc () options (variable);

/* Command level utility to read in the tape produced by the early dump 
feature of Multics initialization.  The output of this program is a dump 
compatible with the standard analysis tools.
Keith Loepere, November 1983. */

/* Modified November of 1984 by Allen Ball to fix bad reference to error_table_. */

/* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */

dcl  Magic_number		        bit (36) aligned init ("654365234214"b3) options (constant) static; /* present in dump records to identify them */
dcl  addr			        builtin;
dcl  addrel		        builtin;
dcl  arg			        char (arg_len) based (arg_ptr);
dcl  arg_len		        fixed bin (21);
dcl  arg_num		        fixed bin;
dcl  arg_ptr		        ptr;
dcl  attach_descr		        char (256);		/* attach description for tape */
dcl  bin			        builtin;
dcl  bit			        builtin;
dcl  character		        builtin;
dcl  cleanup		        condition;
dcl  clock		        builtin;
dcl  code			        fixed bin (35);
dcl  codeptr		        builtin;
dcl  com_err_		        entry () options (variable);
dcl  current_dump_record	        fixed bin;		/* record in dump (0 is first in 1st seg, 255 is 1st in 2nd...) */
dcl  crash_dbr		        bit (72) aligned;	/* from dump record */
dcl  crash_system_type	        fixed bin;		/* from dump record */
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  cv_dec_check_		        entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  date			        builtin;
dcl  date_str		        char (6);		/* for building dump seg names */
dcl  density		        char (4);		/* current density we're trying */
dcl  dimension		        builtin;
dcl  divide		        builtin;
dcl  dummy_ptr		        ptr;
dcl  dump_dir		        char (168);		/* directory in which to place dump segs */
dcl  dump_name		        char (12);		/* base name of dump segs */
dcl  dump_number		        fixed bin;		/* used when naming dump */
dcl  dump_seg_ptrs		        (0:63) ptr init ((64) null); /* ptrs to successive segs of dump */
dcl  dump_segment		        fixed bin;		/* current number (0 orig) of current seg we're writing */
dcl  dump_segment_name	        char (32);		/* name of current dump seg */
dcl  1 dump_record		        aligned,		/* record read from tape */
       2 magic_number	        bit (36) aligned,	/* as in Magic_number above */
       2 address		        fixed bin (26),	/* starting address of page this is */
       2 dbr		        bit (72) aligned,	/* at time of dump */
       2 system_type	        fixed bin,
       2 pad		        fixed bin,
       2 memory_record	        bit (1024 * 36);	/* page of memory */
dcl  ed_appending_simulation_$get_virtual entry (ptr, fixed bin (26), fixed bin (18), ptr, fixed bin (35));
dcl  ed_appending_simulation_$init    entry ((4) ptr, fixed bin);
dcl  ed_appending_simulation_$new_dbr entry (bit (72) aligned, fixed bin (15), fixed bin (35));
dcl  ed_appending_simulation_$new_segment entry (fixed bin (15), ptr, fixed bin (35));
dcl  entry		        char (32);		/* from dump_dir expansion */
dcl  error_count		        fixed bin;		/* while reading current record */
dcl  error_table_$bad_arg	        fixed bin (35) ext static;
dcl  error_table_$bad_density	        fixed bin (35) ext static;
dcl  error_table_$improper_data_format fixed bin (35) ext static;
dcl  error_table_$noarg	        fixed bin (35) ext static;
dcl  expand_pathname_	        entry (char (*), char (*), char (*), fixed bin (35));
dcl  get_temp_segments_	        entry (char (*), (*) ptr, fixed bin (35));
dcl  good_records		        fixed bin;		/* number read so far */
dcl  hbound		        builtin;
dcl  hcs_$make_seg		        entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$set_bc_seg	        entry (ptr, fixed bin (24), fixed bin (35));
dcl  hcs_$terminate_noname	        entry (ptr, fixed bin (35));
dcl  ioa_			        entry () options (variable);
dcl  iocb_ptr		        ptr;		/* for tape */
dcl  iox_$attach_name	        entry (char (*), ptr, char (*), ptr, fixed bin (35));
dcl  iox_$close		        entry (ptr, fixed bin (35));
dcl  iox_$control		        entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$detach_iocb	        entry (ptr, fixed bin (35));
dcl  iox_$open		        entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  iox_$read_record	        entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  last_non_null_page	        fixed bin;		/* used when writing seg pages to dump so we don't  write trailing null pages */
dcl  last_segnum		        fixed bin (15);	/* last valid segnum in dump */
dcl  ltrim		        builtin;
dcl  me			        char (20) static options (constant) init ("read_early_dump_tape");
dcl  memory_block_num	        fixed bin;		/* which memory page we're reading */
dcl  memory_block_ptrs	        (4) ptr init ((4) null); /* forms a set of 4 128k areas */
dcl  memory_blocks		        (0:127) bit (1024 * 36) based; /* a 128k area */
dcl  mod			        builtin;
dcl  1 my_dump		        aligned like dump;	/* header for dump */
dcl  my_page_buffer		        bit (36 * 1024) based (addr (dump_record.memory_record)); /* area for appending simulation reading of memory blocks */
dcl  1 my_seg_info		        aligned like seg_info;/* describe current segment being dumped */
dcl  n_args		        fixed bin;
dcl  new_memory_block_num	        fixed bin;		/* memory block alleged to be in current tape record */
dcl  null			        builtin;
dcl  null_page_num		        fixed bin;		/* loop counter */
dcl  page_num		        fixed bin;		/* loop counter */
dcl  original_density	        char (4);		/* command level specified initial density */
dcl  release_temp_segments_	        entry (char (*), (*) ptr, fixed bin (35));
dcl  rtrim		        builtin;
dcl  segnum		        fixed bin (15);	/* loop counter */
dcl  size			        builtin;
dcl  substr		        builtin;
dcl  tape_record_len	        fixed bin (21);	/* for checking for valid records */
dcl  tape_reel		        char (32);		/* user name */
dcl  time			        builtin;
dcl  time_str		        char (12);		/* for building dump seg name */
dcl  unspec		        builtin;
dcl  write		        bit (1) aligned;	/* mount with ring */
%page;

/* Process arguments */

	call cu_$arg_count (n_args, code);
	if n_args = 0 | code ^= 0 then do;
	     call com_err_ (code, me, "Usage is: read_early_dump_tape <tape reel> -dump <dump num> {-dump_dir <dir>} {-density <n>} {-ring}");
	     return;
	end;
	dump_number = -1;
	original_density = "1600";
	tape_reel = "";
	dump_dir = ">dumps";
	write = "0"b;
	do arg_num = 1 to n_args;
	     call cu_$arg_ptr (arg_num, arg_ptr, arg_len, code);
	     if arg_len > 0 then do;
		if substr (arg, 1, 1) ^= "-" then tape_reel = arg;
		else if arg = "-dump" then do;
		     arg_num = arg_num + 1;
		     if arg_num > n_args then do;
			call com_err_ (error_table_$noarg, me, "dump number");
			return;
		     end;
		     call cu_$arg_ptr (arg_num, arg_ptr, arg_len, code);
		     dump_number = cv_dec_check_ (arg, code);
		     if code ^= 0 | dump_number < 1 then do;
			call com_err_ (error_table_$bad_arg, me, "dump number ^a", arg);
			return;
		     end;
		end;
		else if arg = "-ring" | arg = "-rg" then write = "1"b;
		else if arg = "-dump_dir" then do;
		     arg_num = arg_num + 1;
		     if arg_num > n_args then do;
			call com_err_ (error_table_$noarg, me, "dump dir");
			return;
		     end;
		     call cu_$arg_ptr (arg_num, arg_ptr, arg_len, code);
		     call expand_pathname_ (arg, dump_dir, entry, code);
		     if code ^= 0 then do;
			call com_err_ (code, me, "dump dir ^a", arg);
			return;
		     end;
		     dump_dir = rtrim (dump_dir) || ">" || entry;
		end;
		else if arg = "-density" | arg = "-den" then do;
		     arg_num = arg_num + 1;
		     if arg_num > n_args then do;
			call com_err_ (error_table_$noarg, me, "density");
			return;
		     end;
		     call cu_$arg_ptr (arg_num, arg_ptr, arg_len, code);
		     if arg ^= "800" & arg ^= "1600" & arg ^= "6250" then do;
			call com_err_ (error_table_$bad_density, me, "^a", arg);
			return;
		     end;
		     original_density = arg;
		end;
		else do;
		     call com_err_ (error_table_$bad_arg, me, "^a", arg);
		     return;
		end;
	     end;
	end;

	if tape_reel = "" then do;
	     call com_err_ (0, me, "A tape reel name must be specified.");
	     return;
	end;
	if dump_number < 1 then do;
	     call com_err_ (0, me, "-dump must be specified");
	     return;
	end;
%page;

/* Read the dump tape into temp segments. */

	on cleanup call clean_up;

	density = original_density;
	attach_descr = "tape_nstd_ " || rtrim (tape_reel) || " -den " || density;
	if write then attach_descr = rtrim (attach_descr) || " -write";
	call iox_$attach_name ("redt_switch_", iocb_ptr, attach_descr, codeptr (read_early_dump_tape), code);
	if code ^= 0 then go to iox_error;
	call iox_$open (iocb_ptr, Sequential_input, "0"b, code);
	if code ^= 0 then do;
iox_error:     call com_err_ (code, me, "^a", attach_descr);
	     go to abort;
	end;
	call get_temp_segments_ (me, memory_block_ptrs, code);
	if code ^= 0 then do;
	     call com_err_ (code, me, "Getting temp segments.");
	     go to abort;
	end;

read:	memory_block_num = -1;
	good_records = 0;
	do while (memory_block_num < 511);
	     code = -1;
	     do error_count = 1 to 16 while (code ^= 0);
		call iox_$read_record (iocb_ptr, addr (dump_record), 4 * size (dump_record), tape_record_len, code);
	     end;
	     if code ^= 0 then
		if density = original_density & good_records = 0 then do; /* try another density */
		     if original_density = "6250" then density = "1600";
		     else if original_density = "1600" then density = "6250";
		     else density = "1600";
		     call iox_$control (iocb_ptr, "rewind", null, code);
		     call iox_$control (iocb_ptr, "d" || density, null, code);
		     go to read;
		end;
		else do;
		     call com_err_ (code, me, "More than 16 errors.");
		     go to abort;
		end;
	     else do;
		new_memory_block_num = divide (dump_record.address, 1024, 9);
		if tape_record_len ^= 4 * size (dump_record) | /* valid record? */
		     dump_record.magic_number ^= Magic_number |
		     new_memory_block_num < memory_block_num | /* the one we expect? */
		     memory_block_num + 1 < new_memory_block_num then do;
		     call com_err_ (error_table_$improper_data_format, me);
		     go to abort;
		end;
		else do;
		     good_records = good_records + 1;
		     memory_block_num = new_memory_block_num;
		     crash_dbr = dump_record.dbr;
		     crash_system_type = dump_record.system_type;
		     memory_block_ptrs (divide (memory_block_num, 128, 7) + 1) -> memory_blocks (mod (memory_block_num, 128)) = dump_record.memory_record;
		end;
	     end;
	end;
	call clean_up_tape;
%page;

/* Now get the data into a regular format dump. */

	dumpptr = addr (my_dump);
	seg_info_ptr = addr (my_seg_info);

	unspec (my_dump) = "0"b;
	call ed_appending_simulation_$init (memory_block_ptrs, crash_system_type);
	call ed_appending_simulation_$new_dbr (crash_dbr, last_segnum, code);
	if code ^= 0 then do;
	     call com_err_ (code, me, "Bad dbr value in dump");
	     go to abort;
	end;
	dump.valid = "0"b;
	dump.erfno = dump_number;

	dump.words_dumped = 0;
	begin;
dcl  kludge_valid		        bit (36) aligned based (addr (dump.valid));
	     kludge_valid = "111111111111111111111111111111111111"b; /* azm expects it */
	end;
	dump.time = clock;
	dump.num_segs = 0;
	dump.valid_355 = "0"b;
	dump.dumped_355s = "0"b;
	dump.time_355 = 0;
	dump.version = DUMP_VERSION_2;

	dump.dbr = crash_dbr;

	time_str = time;
	date_str = date;
	dump_name = substr (date_str, 3, 2) || substr (date_str, 5, 2) || substr (date_str, 1, 2) || "." || substr (time_str, 1, 4) || ".";
	dump_segment = 0;
	current_dump_record = 2;			/* header */

	dump_segment_name = dump_name || ltrim (character (dump_segment)) || "." || ltrim (character (dump_number));
	call hcs_$make_seg (dump_dir, dump_segment_name, "", 10, dump_seg_ptrs (dump_segment), code);
	if dump_seg_ptrs (dump_segment) = null then do;
	     call com_err_ (code, me, dump_segment_name);
	     go to abort;
	end;

	do segnum = 0 to last_segnum;
	     call ed_appending_simulation_$new_segment (segnum, seg_info_ptr, code);
	     if code ^= 0 then go to next_seg;

	     if dump.num_segs = dimension (dump.segs, 1) then do;
		call ioa_ ("Segment array overflow.");
		go to end_dump;
	     end;
	     dump.num_segs = dump.num_segs + 1;
	     dump.segs.segno (dump.num_segs) = bit (bin (segnum, 18), 18);
	     dump.segs.length (dump.num_segs) = "0"b;

/* read pages from simulated segment, writing to dump.  Don't write null pages.
If we do find a non-null page, write it and any null pages we didn't write
before. */

	     last_non_null_page = -1;
	     do page_num = 0 to divide (seg_info.size + 1023, 1024, 8) - 1;
		call ed_appending_simulation_$get_virtual (seg_info_ptr, page_num * 1024, 1024, addr (my_page_buffer), code);
		if my_page_buffer ^= "0"b then do;	/* output non-null page and all null pages up to it */
		     do null_page_num = last_non_null_page + 1 to page_num - 1;
			dummy_ptr = get_put ();
		     end;
		     get_put () -> my_page_buffer = my_page_buffer;
		     last_non_null_page = page_num;
		end;
	     end;
	     dump.segs.length (dump.num_segs) = bit (bin ((last_non_null_page + 1) * 16, 18), 18);
	     dump.words_dumped = dump.words_dumped + (last_non_null_page + 1) * 1024;
next_seg:
	end;

/* Write out header */
end_dump:
	dump_seg_ptrs (0) -> dump = my_dump;
	call hcs_$set_bc_seg (dump_seg_ptrs (dump_segment), (mod (current_dump_record - 1, 255) + 1) * 1024 * 36, code);

abort:	call clean_up;
	return;
%page;
clean_up: proc;

	call release_temp_segments_ (me, memory_block_ptrs, code);
	do dump_segment = 0 to hbound (dump_seg_ptrs, 1);
	     if dump_seg_ptrs (dump_segment) ^= null then call hcs_$terminate_noname (dump_seg_ptrs (dump_segment), code);
	end;

clean_up_tape: entry;

	call iox_$close (iocb_ptr, code);
	call iox_$detach_iocb (iocb_ptr, code);
	return;
     end;
%page;
get_put: proc () returns (ptr);

/* add page to dump (returns ptr to page to place data) */

	if mod (current_dump_record, 255) = 0 then do;
	     call hcs_$set_bc_seg (dump_seg_ptrs (dump_segment), 255 * 1024 * 36, code);
	     dump_segment = dump_segment + 1;
	     dump_segment_name = dump_name || ltrim (character (dump_segment)) || "." || ltrim (character (dump_number));
	     call hcs_$make_seg (dump_dir, dump_segment_name, "", 10, dump_seg_ptrs (dump_segment), code);
	     if dump_seg_ptrs (dump_segment) = null then do;
		call com_err_ (code, me, dump_segment_name);
		go to abort;
	     end;
	end;
	current_dump_record = current_dump_record + 1;
	return (addrel (dump_seg_ptrs (dump_segment), mod (current_dump_record - 1, 255) * 1024));
     end;
%page; %include bce_appending_seg_info;
%page; %include bos_dump;
%page; %include iox_modes;
     end;




		    save_history_registers.pl1      11/15/82  1825.9rew 11/15/82  1505.7       33867



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


save_history_registers: proc;

/* save_history_registers - command to set, reset  or  display  state  of  the  per-process  switch,
   pds$save_history_regs  or  the  per-system  switch  wired_hardcore_data$save_hregs,  (with the -priv
   control arg). When signalable faults ocurr, history registers are either stored or not stored in the
   signallers  stack frame (return_to_ring_0_) depending on the state of both of these switches. If the
   per-system switch is on, then all processes will store history registers  in  the  signallers  stack
   frame.  If  the  per-system switch is off but a users per-process switch is on, then only that users
   process will store history registers. The default state of both the per-process and  the  per-system
   switchs is "0"b or off.

   Written 9/16/80 by J. A. Bush for the DPS8/70M CPU
*/

dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl (com_err_, ioa_) entry options (variable);
dcl  hcs_$history_regs_set entry (bit (1) aligned);
dcl  hcs_$history_regs_get entry (bit (1) aligned);
dcl  hphcs_$history_regs_get entry (bit (1) aligned);
dcl  hphcs_$history_regs_set entry (bit (1) aligned);
dcl  ap ptr;
dcl (al, i) fixed bin;
dcl  code fixed bin (35);
dcl (desired_state, old_state, priv_sw, print_sw, set_sw) bit (1) aligned;
dcl  arg char (al) based (ap);
dcl  pname char (22) int static options (constant) init ("save_history_registers");
dcl  error_table_$bad_arg fixed bin (35) ext;

	priv_sw, print_sw, set_sw = "0"b;
	call cu_$arg_ptr (1, ap, al, code);		/* get arg * */
	if code ^= 0 then do;
usage:	     call com_err_ (code, pname, "Usage: ^a {on | off} {-priv} {-print (-pr)}", pname);
	     return;
	end;
	do i = 2 by 1 while (code = 0);
	     if arg = "-priv" then priv_sw = "1"b;	/* user wants per-system history regs */
	     else if arg = "-print" | arg = "-pr" then print_sw = "1"b; /* user wants old state of switch */
	     else if arg = "on" then			/* user wants history regs turned on */
		set_sw, desired_state = "1"b;
	     else if arg = "off" then do;		/* user wants  saving of hregs turned off */
		desired_state = "0"b;
		set_sw = "1"b;
	     end;
	     else do;
		code = error_table_$bad_arg;
		go to usage;			/* tell user what is valid */
	     end;
	     call cu_$arg_ptr (i, ap, al, code);	/* get next arg */
	end;
	if priv_sw then do;				/* if dealing with  per-system history reg saving */
	     if print_sw then do;			/* if user wants to know old state */
		call hphcs_$history_regs_get (old_state); /* get current setting */
		call ioa_ ("per-system history register saving ^[was previously^;is^] turned ^[on^;off^]",
		     set_sw, old_state);
	     end;
	     if set_sw then				/* if user wants to change state */
		call hphcs_$history_regs_set (desired_state);
	end;
	else do;					/* dealing with per-process history regs */
	     if print_sw then do;			/* if user wants to know old state */
		call hcs_$history_regs_get (old_state); /* get current setting */
		call ioa_ ("per-process history register saving ^[was previously^;is^] turned ^[on^;off^]",
		     set_sw, old_state);
	     end;
	     if set_sw then				/* if user wants to change state */
		call hcs_$history_regs_set (desired_state);
	end;

     end save_history_registers;




		    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
