



		    bce_component_to_wordnum_.pl1   11/11/89  1134.9r w 11/11/89  0826.6       25344



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

bce_component_to_wordnum_: proc (p_segnum, p_segname, p_component, return_segnum, return_wordnum, p_code);

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

/* Program to take a segment number and an entry name which will return a word number relative to the beginning of the segment. */

/* Coded June of 1984 by Allen Ball. */

dcl  bce_get_defptr_		entry (ptr, ptr, ptr, ptr, fixed bin (35));
dcl  code				fixed bin (35);
dcl  1 component_acc		aligned,
       2 num_chars			fixed bin (9) unsigned unaligned,
       2 string			char (32) unaligned;
dcl  crash_definitions_$		external;
dcl  crash_lot$			external;
dcl  error_table_$no_ext_sym		external;
dcl  p_code			fixed bin (35) parameter;
dcl  p_component			char (32) parameter;
dcl  p_segname			char (32);
dcl  p_segnum			fixed bin (15) parameter;
dcl  return_segnum			fixed bin (15) parameter;
dcl  return_wordnum			fixed bin (26) parameter;
dcl  1 segname_acc			aligned like component_acc;

dcl  (addr, addrel, length, rtrim, segno, substr, unspec, wordno) builtin;

	code = 0;
	p_code = 0;
	unspec (component_acc) = "0"b;		/* Set up acc strings for get_defptr_ */
	component_acc.num_chars = length (rtrim (p_component));
	substr (component_acc.string, 1, component_acc.num_chars) = rtrim (p_component);
	unspec (segname_acc) = "0"b;
	segname_acc.num_chars = length (rtrim (p_segname));
	substr (segname_acc.string, 1, segname_acc.num_chars) = rtrim (p_segname);
	lotp = addr (crash_lot$);
	definitions_ptr = addr (crash_definitions_$);
	def_header_ptr = addrel (definitions_ptr, definitions.dot (p_segnum).offset);
	call bce_get_defptr_ (def_header_ptr, addr (segname_acc), addr (component_acc), def_ptr, code);
	if code ^= 0 then do;
	     p_code = code;
	     return;
	end;
	if definition.class = CLASS_TEXT then do;
	     return_segnum = p_segnum;
	     return_wordnum = definition.thing_relp;
	end;
	else if definition.class = CLASS_LINKAGE then do;
	     return_segnum = segno (lot.lp (p_segnum));
	     return_wordnum = wordno (lot.lp (p_segnum)) + definition.thing_relp;
	end;

/* Otherwise class is equal to CLASS_SYMBOL, CLASS_SEGNAME, or CLASS_STATIC and we are not interested in it. */

	else p_code = error_table_$no_ext_sym;
	return;

%include definition_dcls;
%include hc_definitions_seg;
%include lot;

     end /* bce_component_to_wordnum */;




		    bce_display_instruction_.pl1    11/11/89  1134.9r w 11/11/89  0826.6      134037



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */
bce_display_instruction_ : proc (P_data_ptr, P_count, P_label);

/* prints an instruction using no more than P_count words starting at 
P_data_ptr with label P_label.  Update P_count to how many words dumped.

   an instruction may be several words long

   James R. Davis 20 May 79
   Modified 21 Sept 79 to print address and raw words, too. JRD

   Stolen from print_instructions_ by Keith Loepere. 
   It differs from print_instructions_ in that:
   1) It doesn't take a i/o switch argument.
   2) It needs a label for the display (the wordno of the pointer supplied is
      meaningless).
   3) It displays only one instruction at a time.

   FEATURES that it would be nice to put in someday:
   decoding the special tags (used by puls1, puls2 s9bd, s6bd, s4bd,
   sbd,stba,stbq,stca and stcq)

   showing either the address of the operand (for a tra, or pl1_operators_ ref) or i$
   the contents of the word addressed - one or two words, depending
*/
/* Fixed not to print more than P_count words despite multi-word instructions 09/01/83 S. Herbst */

dcl  P_data_ptr ptr parameter;			/* input: to probe_info structure */
dcl  P_count fixed bin parameter;			/* input/output: number of instructions to print */
dcl  P_label fixed bin (26) parameter;			/* label (- => none) */

/* the following variables are used globally throughout - but not altered */

dcl  ip ptr;					/* to current instruction's first word */
dcl  op_index fixed bin;				/* the op code, an index into instruction info tables */
dcl  op_code char (6) aligned;			/* mnemonic name of op_index */
dcl  number_of_words fixed bin;			/* number of words in current instruction */
dcl  COLUMN_SPACING fixed bin internal static options (constant) init (8); /* bewteen op_code and address */

dcl (addrel, char, divide, hbound, lbound, min) builtin;

dcl (ioa_$rsnnl, ioa_, ioa_$nnl) entry options (variable);

dcl 1 instr_pr aligned based (ip),
    2 address unal,
      3 pr fixed bin (3) unsigned unal,
      3 offset fixed bin (14) unal,
    2 opcode fixed bin (10) unsigned unal,
    2 inhibit bit (1) unal,
    2 use_pr bit (1) unal,
    2 tag fixed bin (6) unsigned unal;

dcl 1 instr aligned based (ip),
    2 address unal,
      3 offset fixed bin (17),
    2 opcode fixed bin (10) unsigned unal,
    2 inhibit bit (1) unal,
    2 use_pr bit (1) unal,
    2 tag fixed bin (6) unsigned unal;

%include op_mnemonic_format;


	ip = P_data_ptr;

	op_index = ip -> instr.opcode;
	op_code = op_mnemonic_$op_mnemonic (op_index).opcode;
	number_of_words = op_mnemonic_$op_mnemonic (op_index).num_words;
	
	if number_of_words > 1			/* must be EIS */
	then call disassemble_eis;
	else if is_repeat_instr (op_code)
	then call disassemble_repeat;
	else call disassemble_normal;

	P_count = number_of_words;
	return;



disassemble_normal: proc;

	     call print_addr_and_raw (ip, 0);
	     call ioa_ ("   ^a^vt^a^[,^a^]",
		op_code,
		COLUMN_SPACING,
		address_field (ip, (ip -> instr.use_pr)),
		instr.tag ^= 0, tag_field ((instr.tag)));

/* add code to print what is pointed to */

	end disassemble_normal;




disassemble_repeat: proc ;

	     call print_addr_and_raw (ip, 0);
	     call ioa_ ("   ^a^[a^]^[b^]^[^vt^d^;x^vt^s^],^d^[,tze^]^,tmi^]^[,tpl^]^[,trc^]^[tnc^]",
		op_code,
		ip -> repeat_instr.a,
		ip -> repeat_instr.b,
		ip -> repeat_instr.use_tally, COLUMN_SPACING, ip -> repeat_instr.tally,
		ip -> repeat_instr.delta,
		ip -> repeat_instr.zero_on,
		ip -> repeat_instr.zero_off,
		ip -> repeat_instr.neg_on,
		ip -> repeat_instr.neg_off,
		ip -> repeat_instr.carry_on,		/* CSNY ? */
		ip -> repeat_instr.carry_off);

dcl 1 repeat_instr aligned based,
    2 tally fixed bin (8) unsigned unal,
    2 a bit (1) unal,
    2 b bit (1) unal,
    2 use_tally bit (1) unal,
    2 term_conditions unal,
      3 zero_on bit (1) unal,
      3 zero_off bit (1) unal,
      3 neg_on bit (1) unal,
      3 neg_off bit (1) unal,
      3 carry_on bit (1) unal,
      3 carry_off bit (1) unal,
    2 process_overflow bit (1) unal,
    2 opcode fixed bin (10) unsigned unal,
    2 pad bit (2) unal,
    2 delta fixed bin (6) unsigned unal;

	end disassemble_repeat;

disassemble_eis: proc;

dcl  data_type fixed bin;
dcl  ndesc fixed bin;				/* how many descriptors  it has */
dcl (ALPHA_TYPE init (0), BIT_TYPE init (1), OTHER_TYPE init (2)) fixed bin internal static options (constant);
dcl  dp ptr;					/* to a descriptor */
dcl  descx fixed bin;				/* index as we step over descriptors */

dcl 1 eis_instr_all_descs aligned based (ip),
    2 pad1 bit (2) unal,
    2 mf3 unal like mod_factor,
    2 enablefault bit (1) unal,
    2 pad2 bit (1) unal,
    2 mf2 unal like mod_factor,
    2 pad3 bit (11) unal,
    2 mf1 unal like mod_factor;

dcl 1 mod_factor aligned based,
    2 ext_base bit (1) unal,				/* there is a pr number in address */
    2 length_in_reg bit (1) unal,			/* the length of the operand is in a reg */
    2 indirect_descriptor bit (1) unal,			/* the descriptor is an indirect ptr */
    2 tag fixed bin (4) unsigned unal;

dcl 1 eis_args_info (3) aligned like mod_factor;

	     ndesc = op_mnemonic_$op_mnemonic (op_index).num_desc;
	     data_type = op_mnemonic_$op_mnemonic (op_index).dtype;
	     if data_type > OTHER_TYPE then data_type = OTHER_TYPE;

	     eis_args_info (1) = eis_instr_all_descs.mf1;
	     eis_args_info (2) = eis_instr_all_descs.mf2;
	     eis_args_info (3) = eis_instr_all_descs.mf3;

	     call print_addr_and_raw (ip, 0);
	     call print_instr_word;

	     number_of_words = min (number_of_words, P_count);
	     dp = ip;
	     do descx = 1 to number_of_words -1;
		dp = addrel (dp, 1);
		call print_addr_and_raw (dp, descx);

/* CASE on what kind of descriptor we have */

		if descx > ndesc			/* it is an arg, not a desc */
		then call print_ind_desc (dp, eis_args_info (descx));
		else if eis_args_info (descx).indirect_descriptor
		then call print_ind_desc (dp, eis_args_info (descx));
		else if desc_is_obscure (op_code, descx) /* abnormal type, such as MOP ptr of mvne */
		then call print_obscure_desc (dp, eis_args_info (descx));
		else if data_type = ALPHA_TYPE
		then call print_alpha_desc (dp, eis_args_info (descx));
		else if data_type = BIT_TYPE
		then call print_bit_desc (dp, eis_args_info (descx));
		else call print_numeric_desc (dp, eis_args_info (descx));
	     end;					/* of loop over all descriptors */




print_instr_word: proc;

dcl  descx fixed bin;
dcl  need_comma bit (1) aligned;
dcl  line char (256) varying;				/* holds output as built */
dcl  HT char (1) internal static options (constant) init ("	");

dcl 1 eis_alpha_fill based (ip),
    2 field bit (9) unal,
    2 pad bit (27) unal;

dcl 1 eis_bit_fill based (ip),
    2 field bit (1) unal,
    2 pad bit (4) unal,
    2 bolr fixed bin (4) unsigned unal,
    2 pad1 bit (27) unal;

dcl 1 eis_numeric_fill aligned based (dp),
    2 pad bit (10) unal,
    2 round bit (1) unal,
    2 pad2 bit (25) unal;

dcl  bool_word (0:15) char (6) internal static options (constant) init
    ("clear", "and", "02", "03", "04", "05", "xor", "or",
     "10", "11", "12", "13", "invert", "15", "nand", "set");

		line = op_code;
		line = line || HT;

		do descx = 1 to ndesc;
		     line = line || "(";
		     need_comma = "0"b;

		     if eis_args_info (descx).ext_base
		     then call add_option ("pr");
		     if eis_args_info (descx).length_in_reg
		     then call add_option ("rl");
		     if eis_args_info (descx).indirect_descriptor
		     then call add_option ("id");
		     if eis_args_info (descx).tag ^= 0
		     then call add_option (tag_field ((eis_args_info (descx).tag)));
		     line = line || ")";

		     if descx < ndesc		/* more to come */
		     then line = line || ",";
		end;				/* of loop over all MFs */

		if eis_instr_all_descs.enablefault then line = line || ",enablefault";

		if data_type = ALPHA_TYPE
		then do;
		     if has_fill (op_code)
		     then do;
			line = line || ",fill(";
			line = line || octalize (eis_alpha_fill.field);
			line = line || ")";
		     end;
		     else if has_mask (op_code)
		     then do;
			line = line || ",mask(";
			line = line || octalize (eis_alpha_fill.field);
			line = line || ")";
		     end;				/* mask */
		end;				/* ALPHA type */
		else if data_type = BIT_TYPE
		then do;
		     line = line || ", fill (";
		     line = line || char (eis_bit_fill.field);
		     line = line || ")";

		     if has_boolean (op_code) then do;
			line = line || ", bool (";
			line = line || bool_word (eis_bit_fill.bolr);
			line = line || ")";
		     end;				/* bolr hacking */
		end;				/* BIT type */
		else do;
		     if eis_numeric_fill.round
		     then line = line || ", round";
		end;				/* NUMERIC */

		call ioa_ ("   ^a", line);
		return;

add_option:	proc (c2);
dcl  c2 char (2) aligned parameter;

		     if need_comma			/* we have previously written in this MF, need a separator */
		     then line = line || ",";
		     need_comma = "1"b;
		     line = line || c2;
		end add_option;


octalize:		proc (b9) returns (char (3) aligned);
dcl  c3 char (3) aligned;
dcl  b9 bit (9) parameter;

		     call ioa_$rsnnl ("^.3b", c3, (0), b9);
		     return (c3);
		end octalize;


	     end print_instr_word;


/* here are internal procedures to print the various kinds of descriptors-
   obscure (which isn't nearly as clever as it ought to be)
   indirect
   alphanumeric
   bit
   numeric

*/

print_obscure_desc: proc (descp, mf);

dcl  descp ptr parameter;
dcl 1 mf aligned parameter like mod_factor;

		call ioa_ ("   too obscure a descriptor too decode");

	     end print_obscure_desc;


print_ind_desc: proc (descp, mf);

dcl  descp ptr aligned parameter;
dcl 1 mf aligned parameter like mod_factor;

		call ioa_ ("   arg^vt^a^[,^a^]",
		     COLUMN_SPACING,
		     address_field (descp, (mf.ext_base)),
		     descp -> instr.tag ^= 0, tag_field ((descp -> instr.tag)));

	     end print_ind_desc;



print_alpha_desc: proc (descp, mf);

dcl  descp ptr aligned parameter;
dcl 1 mf aligned parameter like mod_factor;

dcl  alpha_types (0:3) char (1) internal static options (constant) init ("9", "6", "4", "?");
dcl  NINE_BIT fixed bin internal static options (constant) init (0);

dcl 1 alpha_desc aligned based (descp),
    2 y bit (18) unal,
    2 char_no fixed bin (3) unsigned unal,
    2 type_code fixed bin (2) unsigned unal,
    2 pad bit (1) unal,
    2 length fixed bin (12) unsigned unal;

		call ioa_ ("   desc^aa^vt^a(^[^d^s^;^s^d^]),^[^a^s^;^s^d^]",
		     alpha_types (type_code),
		     COLUMN_SPACING,
		     address_field (descp, (mf.ext_base)),
		     alpha_desc.type_code = NINE_BIT, divide (char_no, 2, 17, 0), char_no,
		     mf.length_in_reg, tag_field ((alpha_desc.length)), alpha_desc.length);

	     end print_alpha_desc;


print_bit_desc: proc (descp, mf);

dcl  descp ptr aligned parameter;
dcl 1 mf aligned parameter like mod_factor;

dcl 1 bit_desc aligned based (descp),
    2 y bit (18) unal,
    2 char_no fixed bin (2) unsigned unal,
    2 bit_no fixed bin (4) unsigned unal,
    2 length fixed bin (12) unsigned unal;

		call ioa_ ("   descb^vt^a(^d),^[^a^s^;^s^d^]",
		     COLUMN_SPACING,
		     address_field (descp, (mf.ext_base)),
		     char_no * 9 + bit_no,
		     mf.length_in_reg,
		     tag_field ((bit_desc.length)),
		     bit_desc.length);

	     end print_bit_desc;


print_numeric_desc: proc (descp, mf);

dcl  descp ptr aligned parameter;			/* aren't you getting bored? */
dcl 1 mf aligned parameter like mod_factor;

dcl  sign_name (0:3) char (2) aligned internal static options (constant) init ("fl", "ls", "ts", "ns");

dcl 1 numeric_desc aligned based (descp),
    2 y bit (18) unal,
    2 char_no fixed bin (3) unsigned unal,
    2 type4 bit (1) unal,
    2 sign_type fixed bin (2) unsigned unal,
    2 scale_factor fixed bin (5) unal,
    2 length fixed bin (6) unsigned unal;

		call ioa_ ("   desc^[4^;9^]^a^vt^a(^[^d^s^;^s^d^]),^[^a^s^;^s^d^]^[,^d^]",
		     numeric_desc.type4,		/* which type ? */
		     sign_name (numeric_desc.sign_type),
		     COLUMN_SPACING,
		     address_field (descp, (mf.ext_base)),
		     type4, numeric_desc.length, divide (numeric_desc.length, 2, 17, 0),
		     mf.length_in_reg, tag_field ((numeric_desc.length)), numeric_desc.length,
		     scale_factor ^= 0, scale_factor);

	     end print_numeric_desc;


desc_is_obscure: proc (op_name, desc_no) returns (bit (1) aligned);

/* for certain ops, one of the descriptors will not be of the expected type */

dcl  op_name char (6) aligned parameter;
dcl  desc_no fixed bin parameter;			/* input, which desc */

		return (
		     (op_name = "btd" & desc_no = 1) |
		     (op_name = "dtb" & desc_no = 2) |
		     (op_name = "mvne" & desc_no = 2)
		     );
	     end desc_is_obscure;
	end disassemble_eis;


/* miscellaneous useful things */


print_addr_and_raw: proc (p, label_offset);
dcl  label_offset fixed bin parameter;
dcl  p ptr parameter;
dcl  based_word bit (36) aligned based (p);
	     call ioa_$nnl ("^[^9o  ^;^s^]^w",
		P_label >= 0, P_label + label_offset, based_word);
	end print_addr_and_raw;

address_field: proc (p, use_pr) returns (char (10) aligned);
dcl  p ptr aligned parameter;				/* to instruction */
dcl  use_pr bit (1) aligned parameter;			/* which format is it ? */
dcl  rs char (9) aligned;
	     call ioa_$rsnnl ("^[pr^d|^d^s^;^s^s^d^]", rs, (0),
		use_pr, p -> instr_pr.address.pr, p -> instr_pr.address.offset,
		p -> instr.address.offset);
	     return (rs);

	end address_field;



tag_field: proc (tag) returns (char (3) aligned);

/* this proc exists to isolate references to the modifier data base -
   hope to make it part of op_mnemonic some day */

dcl  tag fixed bin parameter;

	     if tag < lbound (modifier, 1) | tag > hbound (modifier, 1)
	     then return ("bad");
	     else return (modifier (tag));
	end tag_field;


/* predicates on instruction types */

is_repeat_instr: proc (op_name) returns (bit (1) aligned);
dcl  op_name char (6) aligned parameter;

	     return (op_name = "rpd" | op_name = "rpl" | op_name = "rpt");

has_fill:	     entry (op_name) returns (bit (1) aligned);

	     return (op_name = "cmpc" | op_name = "mlr" | op_name = "mvt");

has_boolean:   entry (op_name) returns (bit (1) aligned);

	     return (op_name = "csl" | op_name = "csr" | op_name = "sztl" | op_name = "sztr");

has_mask:	     entry (op_name) returns (bit (1) aligned);

	     return (op_name = "scm");


	end;					/* is_XXXXX_instr */


     end bce_display_instruction_;




		    bce_display_scu_.pl1            11/11/89  1134.9r w 11/11/89  0826.6       96885



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */
bce_display_scu_:	proc (scup, a_offset, lg_sw);

/* Modification History - prtscu_
   Initially coded by J. A. Bush - Dec 1975
   Modified May 1977 by J. A. Bush to be intellegent about group 7 faults and not print out tsr|ca
   Modified Aug 1980  by R.L. Coppola to be more intelligent about IOM channels greater than 37 (octal).
   Also added display of the CT Hold reg in CU status.
   Stolen for bce use, Keith Loepere December 1983.
*/

dcl  scup ptr;					/* pointer to SCU Data */
dcl  a_offset fixed bin (26);				/*  relative offset of SCU data */
dcl  lg_sw bit (1);					/* long format switch "1"b => long */
dcl (strp, byptr, refptr) ptr;
dcl (lnpos, flt_lng, inst6, i, j) fixed bin;
dcl  reoffset fixed bin (26);
dcl  code fixed bin (35);
dcl  w (0 : 7) fixed bin based;
dcl  flt_ln char (100);
dcl  flt_bf char (24) varying;
dcl  iocbp ptr;
dcl (length, fixed, addr, addrel, baseptr, substr, null, hbound, lbound) builtin;
dcl (tsrpr, on_line) bit (1);
dcl  cvbinbuf char (12);
dcl  fltdtab (0:35) bit (1) based (byptr) unaligned;
dcl  cpul (0 : 7) char (1) int static options (constant) init ("a", "b", "c", "d", "e", "f", "g", "h");
dcl  at_by_wd char (2);
dcl (ioa_, ioa_$rsnnl) entry options (variable);
dcl  bce_display_instruction_ entry (ptr, fixed bin, fixed bin (26));
dcl  bce_segptr_to_name_ entry (ptr) returns (char (*));
dcl  cv_bin_$oct entry (fixed bin, char (12));

dcl 1 scud based (scup) aligned,
    2 wd0 unaligned,				/* :: */
      3 prr bit (3),				/* Procedure Ring Register */
      3 psr bit (15),				/* Procedure Segment Register */
      3 apust bit (18),				/* APU Status */
    2 wd1 unaligned,				/* :: */
      3 fid bit (20),				/* fault/interrupt data */
      3 ill_act_lns bit (4),				/* Illegal Action Lines */
      3 ill_act_chan bit (3),				/* Illegal Action Channel (Port) */
      3 con_chan bit (3),				/* Connect Channel (Port) */
      3 fi bit (6),					/* Fault/Interrupt Vector Address */
    2 wd2 unaligned,				/* :: */
      3 trr bit (3),				/* Temporary Ring Register */
      3 tsr bit (15),				/* Temporary Segment Register */
      3 mbz bit (9),				/* :: */
      3 cpu bit (3),				/* Processor Number */
      3 tmd bit (6),				/* :: */
    2 wd3 fixed bin (35),				/* :: */
    2 wd4 unaligned,				/* :: */
      3 ict bit (18),				/* Instruction Counter */
      3 ir bit (18),				/* Indicator Register */
    2 wd5 unaligned,				/* :: */
      3 ca bit (18),				/* Computed Address */
      3 cus bit (12),				/* CU Status */
      3 ct_hold bit (6),				/* remember mod field */
    2 wd6 fixed bin (35),				/* Even Instruction */
    2 wd7 fixed bin (35);				/* Odd Instruction */

dcl  ill_act (0:15) char (37) varying int static options (constant) init
    ("...", "Unasigned", "Non Existant Address", "Fault on Condition",
     "Unassigned", "Data Parity (Store -> SCU)", "Data Parity in Store",
     "Data Parity (Store -> SCU & in Store)", "Not Control", "Port Not Enabled", "Illegal Command",
     "Store Not Ready", "ZAC Parity (Processor -> SCU)", "Data Parity (Processor -> SCU)",
     "ZAC parity (SCU -> Store)", "Data Parity (SCU -> Store)");

dcl  indrs (18:31) char (4) varying int static options (constant) init
    ("zero", "neg", "cary", "ovfl", "eovf", "eufl", "oflm", "tro", "par", "parm", "^bar", "tru", "mif", "abs");

dcl  APU (18:32) char (6) varying int static options (constant) init
    ("priv", "xsf", "sdwamm", "sd-on", "ptwamm", "pt-on", "pi-ap", "dsptw", "sdwnp",
     "sdwp", "ptw", "ptw2", "fap", "fanp", "fabs");

dcl  CU (18:29) char (3) varying int static options (constant) init
    ("rf", "rpt", "rd", "rl", "pot", "pon", "xde", "xdo", "itp", "rfi", "its", "fif");

dcl  g1and7flts (5) bit (6) int static options (constant) unaligned init
    ("01"b3, "11"b3, "21"b3, "31"b3, "37"b3);

dcl  grp1flt (0:19) char (24) varying int static options (constant) init
    ("Illegal Ring Order", "Not in Execute Bracket", "Execute Bit off",
     "Not In Read Bracket", "Read Bit Off", "Not In Write Bracket",
     "Write Bit Off", "Not A Gate", "Not In Call Bracket", "Outward Call",
     "Bad Outward Call", "Inward Return", "Cross Ring Transfer",
     "Ring Alarm", "Associative Memory", "Out of Segment Bounds",
     "Processor Parity Upper", "Processor Parity Lower",
     "SC To Proc. Seq. Error 1", "SC To Proc. Seq. Error 2");

dcl  grp2flt (0:6) char (24) varying int static options (constant) init
    ("Illegal Segment Number", "Illegal Op Code",
     "Illegal Address & Mod", "Illegal Slave Procedure",
     "Illegal Procedure", "Non Existant Address", "Out Of Bounds");

dcl  flt_int_typ (0:63) char (24) varying int static options (constant) init
    ("...", "Shutdown", "...", "Store", "Bulk Store 0 Term", "MME 1", "...", "Fault Tag 1",
     "IOM 0 Overhead", "Timer Runout", "IOM 1 Overhead", "Command", "IOM 2 Overhead", "Derail",
     "IOM 3 Overhead", "Lockup", "IOM 0 Terminate Ch 40-77", "Connect", "IOM 1 Terminate Ch 40-77", "Parity", "Bulk Store 1 Term",
     "Illegal Procedure", "...", "Op Not Complete", "IOM 0 Terminate", "Startup", "IOM 1 Terminate",
     "Overflow", "IOM 2 Terminate", "Divide Check", "IOM 3 Terminate", "Execute", "IOM 0 Marker Ch 40-77",
     "(DF0) Segment", "IOM 1 Marker Ch 40-77", "(DF1) Page", "...", "Directed Fault 2", "...", "Directed Fault 3",
     "IOM 0 Marker", "Access Violation", "IOM 1 Marker", "MME 2", "IOM 2 Marker", "MME 3",
     "IOM 3 Marker", "MME 4", "...", "(FT2) Linkage", "...", "Fault Tag 3", "...", "...", "...", "...",
     "IOM 0 Special", "...", "IOM 1 Special", "...", "IOM 2 Special", "...", "IOM 3 Special", "Trouble");

dcl  TAG_ptr ptr;					/* pointer to tag table */
dcl  tag_prt bit (1) init ("0"b);
dcl  tag_ char (4) init ("");
dcl  TAG_table (8) char (40) init (			/* tag table */
     "     au   qu   du   ic   al   ql   dl   ",
     "x0   x1   x2   x3   x4   x5   x6   x7   ",
     "n*  aau* aqu* ailtg ic* aal* aql* ailtg ",
     "0*  a1*  a2*  a3*  a4*  a5*  a6*  a7*  a",
     "fi   itp  iltg its  sd   scr  f2   f3   ",
     "ci   i    sc   ad   di   dic aid   idc a",
     "*n   *au  *qu  iltg *ic  *al  *ql  iltg ",
     "*0   *1   *2   *3   *4   *5   *6   *7   ");


dcl 1 TAG (64) based (TAG_ptr),
    2 code char (4) unal,
    2 pad bit (8) unal,
    2 chain bit (1);

/*  */

	reoffset = a_offset;			/* copy relative offset */

	if scud.wd0.psr = "0"b then
	     if scud.wd2.tsr = "0"b then do;
		call ioa_ ("No SCU data stored");
		return;
	     end;
	inst6 = reoffset + 6;
	if lg_sw then				/* user wants octal dump too */
	     call ioa_ ("^6o^-^4(^w ^)^/^-^4(^w ^)^/", reoffset, scup -> w);
	flt_ln, flt_bf = "";
	tsrpr = "0"b;				/* assume for now don't print tsr */
	flt_bf = flt_int_typ (fixed (scud.wd1.fi, 6));
	if substr (flt_bf, 1, 3) = "..." then
	     call ioa_ ("Fault/Interrupt (^o), Undefined", fixed (scud.wd1.fi, 6));
	else do;
	     flt_lng = length (flt_int_typ (fixed (scud.wd1.fi, 6)));
	     substr (flt_ln, 1, flt_lng) = substr (flt_bf, 1, flt_lng);
	     byptr = addrel (scup, 1);
	     if fltdtab (35) = "1"b then do;
		substr (flt_ln, flt_lng + 2, 5) = "Fault";
		lnpos = flt_lng + 8;
		do i = 1 to hbound (g1and7flts, 1);	/*  If grp 1 or 7 faults, don't print out tsr|ca */
		     if scud.wd1.fi = g1and7flts (i) then
			tsrpr = "1"b;
		end;
	     end;
	     else do;
		substr (flt_ln, flt_lng + 2, 9) = "Interrupt";
		lnpos = flt_lng + 12;
		tsrpr = "1"b;			/* don't print out tsr|ca for interrupts */
	     end;
	     flt_lng = fixed (scud.wd1.fi, 6);
	     call cv_bin_$oct (flt_lng, cvbinbuf);
	     substr (flt_ln, lnpos, 4) = "(" || substr (cvbinbuf, 11, 2) || ")";
	     lnpos = lnpos + 4;
	     j = lnpos;
	     do i = 0 to hbound (grp1flt, 1);
		if fltdtab (i) then do;
		     if substr (flt_ln, 1, 5) = "Store"|substr (flt_ln, 1, 12) = "Illegal Proc" then
			if i <= 6 then
			     call ioa_$rsnnl ("^a, ^a", flt_ln, j, flt_ln, grp2flt (i));
			else;
		     else call ioa_$rsnnl ("^a, ^a", flt_ln, j, flt_ln, grp1flt (i));
		end;
	     end;
	     call ioa_ ("^a", flt_ln);
	end;
	if ill_act_lns ^= "0"b then do;		/* display illegal action lines if present */
	     call ioa_ ("Illegal Action Code (^o) - ^a", fixed (scud.wd1.ill_act_lns, 4),
		ill_act (fixed (scud.wd1.ill_act_lns, 4)));
	end;
	if tsrpr then at_by_wd = "At";		/* if not printing tsr */
	else at_by_wd = "By";
	byptr = addrel (baseptr (fixed (scud.wd0.psr, 18)), fixed (scud.wd4.ict, 18));
	if ^tsrpr then
	     refptr = addrel (baseptr (fixed (scud.wd2.tsr, 18)), fixed (scud.wd5.ca, 18));
	call ioa_ ("^a: ^p  ^a", at_by_wd, byptr,
	     bce_segptr_to_name_ (byptr));
	if ^tsrpr then				/* if we want to print out tsr|ca */
	     call ioa_ ("Referencing: ^p  ^a", refptr,
		bce_segptr_to_name_ (refptr));
	call ioa_ ("On: cpu ^a (#^o)", cpul (fixed (scud.wd2.cpu, 3)),
	     fixed (scud.wd2.cpu, 3));
	flt_ln = "";
	byptr = addr (scud.wd4);			/* display Indicator register if any bits present */
	do i = lbound (indrs, 1) to hbound (indrs, 1);
	     if fltdtab (i) then
		call ioa_$rsnnl ("^a ^a,", flt_ln, j, flt_ln, indrs (i));
	end;
	if flt_ln ^= "" then do;
	     substr (flt_ln, j, 1) = " ";
	     call ioa_ ("Indicators: ^a", flt_ln);
	     flt_ln = "";
	end;
	byptr = addr (scud.wd0);			/* display interpreted APU status if any bits present */
	do i = lbound (APU, 1) to hbound (APU, 1);
	     if fltdtab (i) then
		call ioa_$rsnnl ("^a ^a,", flt_ln, j, flt_ln, APU (i));
	end;
	if flt_ln ^= "" then do;
	     substr (flt_ln, j, 1) = " ";
	     call ioa_ ("APU Status: ^a", flt_ln);
	     flt_ln = "";
	end;
	byptr = addr (scud.wd5);			/* display interprted CU status if any bits present */
	do i = lbound (CU, 1) to hbound (CU, 1);
	     if fltdtab (i) then
		call ioa_$rsnnl ("^a ^a,", flt_ln, j, flt_ln, CU (i));
	end;

	TAG_ptr = addr (TAG_table);
	i = fixed (wd5.ct_hold);

	if i ^= 0 then do;
	     tag_ = TAG.code (i+1);
	     tag_prt = "1"b;
	end;

	if (flt_ln ^= "") | (tag_ ^= "") then do;
	     substr (flt_ln, j, 1) = " ";
	     call ioa_ ("CU Status:  ^a  ^[^/CT Hold: ^a^]",
		flt_ln, tag_prt, tag_);
	end;


	call ioa_ ("Instructions: ");	/* display Instructions (words 6 & 7) */
	call bce_display_instruction_ (addr (scud.wd6), (1), reoffset + 6);
	call bce_display_instruction_ (addr (scud.wd7), (1), reoffset + 7);

/*  */

     end bce_display_scu_;




		    bce_get_defptr_.pl1             11/11/89  1134.9r w 11/11/89  0826.6       49077



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

bce_get_defptr_: proc (p_def_header_ptr, segname_acc_ptr, symbol_acc_ptr, returned_def_ptr, code);

/* 06/05/84 Program by A.Ball to replace get_defptr_.alm for use later in bce_probe. */
/* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */

dcl  addrel		        builtin;
dcl  code			        fixed bin (35) parameter; /* Standard error code. */
dcl  counter		        fixed bin;
dcl  1 def_name		        like acc_string based (def_name_ptr); /* Definition name we are looking for. */
dcl  def_name_ptr		        ptr;
dcl  1 def_segname_acc	        aligned like acc_string based (def_segname_acc_ptr);
dcl  def_segname_acc_ptr	        ptr;
dcl  duplicate_table_index	        fixed bin;
dcl  error_table_$no_ext_sym	        external fixed bin (35); /* Error code "External symbol not found." */
dcl  hash_index		        fixed bin;
dcl  mod			        builtin;
dcl  null			        builtin;
dcl  out_of_bounds		        condition;
dcl  p_def_header_ptr	        ptr parameter;	/* Pointer to definition section. */
dcl  returned_def_ptr	        ptr parameter;	/* Pointer to found definition. */
dcl  1 segname_acc		        aligned like acc_string based (segname_acc_ptr);
dcl  segname_acc_ptr	        ptr parameter;	/* Pointer to seg name being searched for. */
dcl  1 symbol_acc		        aligned like acc_string based (symbol_acc_ptr);
dcl  symbol_acc_ptr		        ptr parameter;	/* Pointer to symbol name being searched for. */
dcl  word			        fixed bin (36) unsigned unaligned based;

%page;
	def_header_ptr = p_def_header_ptr;
	on out_of_bounds goto no_match;
	code = 0;
	counter = 0;				/* Initiate "sanity" counter. */
	if definition_header.hash_table_relp = 0 then do;

/* Go here if there is no hash table.  First check class 3 defs for segname. */

	     def_ptr = null;
	     do segname_ptr = addrel (def_header_ptr, definition_header.def_list_relp) repeat addrel (def_header_ptr, segname_definition.next_segname_relp) while (segname_ptr -> word ^= 0);
		counter = counter + 1;
		if counter > 1000 then goto no_match;
		def_segname_acc_ptr = addrel (def_header_ptr, segname_definition.name_relp);
		if def_segname_acc.string = segname_acc.string then do;
		     def_ptr = addrel (def_header_ptr, segname_definition.forward_relp);
		     goto start_def_search_loop;
		end;
	     end;

	     def_ptr = addrel (def_header_ptr, definition_header.def_list_relp);

start_def_search_loop:
	     do def_ptr = def_ptr repeat addrel (def_header_ptr, definition.forward_relp) while (def_ptr -> word ^= 0 & counter < 1000);
						/* forwrd_relp -> (zero word) marks the end of the thread. */
		counter = counter + 1;
		if ^definition.flags.ignore then do;
		     def_name_ptr = addrel (def_header_ptr, definition.name_relp); /* Get the name associated with the definition. */
		     if symbol_acc.string = def_name.string then goto found_def;
		end;
	     end;
	end;
%page;
	else do;
	     def_ht_ptr = addrel (def_header_ptr, definition_header.hash_table_relp); /* Have pointer to beginning of hash table. */
						/* Hash index is determined by the length of the name string and the first three characters (the first word) mod divided by the size the table plus one. */
	     do hash_index = mod (symbol_acc_ptr -> word, definition_ht.n_entries) + 1 repeat hash_index + 1 while (definition_ht.table (hash_index).def_relp ^= 0 & hash_index < 1000); /* Sanity check in case definition_ht.n_entries is trashed. */
		def_ptr = addrel (def_header_ptr, definition_ht.table (hash_index).def_relp); /* Get the pointer to the definition for this entry. */
		if definition.forward_relp = 0 then do; /* If true there is pointing to a duplicate name table and not a definition. */
		     dup_table_ptr = def_ptr;
		     if duplicate_table.n_names < 1 | duplicate_table.n_names > 999 then goto no_match;
		     do duplicate_table_index = 1 to duplicate_table.n_names; /* Linear search through the duplicate name table. */
			def_ptr = addrel (def_header_ptr, duplicate_table.table (duplicate_table_index).def_relp);
			def_name_ptr = addrel (def_header_ptr, definition.name_relp);
			segname_ptr = addrel (def_header_ptr, definition.segname_relp);
			def_segname_acc_ptr = addrel (def_header_ptr, segname_definition.name_relp);
			if symbol_acc.string = def_name.string & segname_acc.string = def_segname_acc.string then goto found_def; /* Make the comparision. */
		     end;
		end;
		else do;				/* It is just a normal definition. */
		     def_name_ptr = addrel (def_header_ptr, definition.name_relp); /* Get pointer to name associated with this definition. */
		     if symbol_acc.string = def_name.string then goto found_def; /* Make the comparision. */
		end;
	     end;
	end;
%page;
no_match:
	returned_def_ptr = null ();			/* Return null pointer. */
	code = error_table_$no_ext_sym;		/* Appropriate error code. */
	return;

found_def:
	returned_def_ptr = def_ptr;			/* Return the found pointer. */
	return;

%page; %include definition_dcls;

     end /* get_def_ptr */;





		    bce_inst_length_.pl1            11/11/89  1134.9r w 11/11/89  0826.6       13977



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */
bce_inst_length_: procedure (ip, special) returns (fixed bin);

/* given a ptr to an instruction (ip) - return the number of words that must be
   moved to relocate the instruction.  Stolen from inst_length_.
*/

dcl (ip pointer,					/* to instruction */
     special fixed bin) parameter;			/* if non-EIS, nonzero means special modifiers;
						   if EIS, then number of EIS-type descriptors */
dcl  op_index fixed bin;				/* op code, used as index into op_mnemonic */

dcl 1 instruction_overlay based aligned,		/* for picking out op code */
    2 tag bit (3) unaligned,
    2 offset fixed bin (14) unaligned,
    2 opcode bit (10) unaligned;


dcl (addr, addrel, fixed) builtin;
						/* find out length of the instruction */

	op_index = fixed (ip -> instruction_overlay.opcode, 10, 0); /* get instruction_overlay.opcode */

	if op_mnemonic_$op_mnemonic (op_index).opcode = "xec " then return (0);
	special = op_mnemonic_$op_mnemonic (op_index).num_desc;
	return (op_mnemonic_$op_mnemonic (op_index).num_words);

%include op_mnemonic_format;

     end bce_inst_length_;




		    bce_name_to_segnum_.pl1         11/11/89  1134.9r w 11/11/89  0826.6       90819



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */
bce_name_to_segnum_: proc (p_name, p_segnum, p_code);

/* Look up the segnum for a hardcore seg in the image.
Keith Loepere, December 1983. */

/* Changed June 1984 for the riddance of bce_probe_data - Allen Ball. */
/* Also changed to give more information in bce_segptr_to_name_ - ADB */
/* Added segnum check to segptr entry, Keith Loepere, November 1984. */

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

dcl  addr				builtin;
dcl  addrel			builtin;
dcl  bin				builtin;
dcl  1 closest_hi_def		aligned like definition based (closest_hi_def_ptr);
dcl  closest_hi_def_ptr		ptr;
dcl  1 closest_lo_def		aligned like definition based (closest_lo_def_ptr);
dcl  closest_lo_def_ptr		ptr;
dcl  1 closest_hi_segname_def		aligned like segname_definition based (closest_hi_segname_def_ptr);
dcl  closest_hi_segname_def_ptr	ptr;
dcl  1 closest_lo_segname_def		aligned like segname_definition based (closest_lo_segname_def_ptr);
dcl  closest_lo_segname_def_ptr	ptr;
dcl  component			char (32);
dcl  counter			fixed bin;
dcl  crash_definitions_$		external;
dcl  crash_name_table$		external;
dcl  crash_slt$			external;
dcl  dimension			builtin;
dcl  error_table_$name_not_found	fixed bin (35) ext static;
dcl  hash_index_			entry (ptr, fixed bin (35), fixed bin (35), fixed bin (35)) returns (fixed bin (35));
dcl  hash_value			fixed bin (35);	/* what name hashes to for hash threaded list scan */
dcl  hi_offset			fixed bin (26);
dcl  ioa_$rsnnl			entry () options (variable);
dcl  length			builtin;
dcl  lo_offset			fixed bin (26);
dcl  my_name			char (256);
dcl  my_name_len			fixed bin;
dcl  name				char (32);
dcl  1 name_entry			aligned like segnam.names based (name_entry_ptr); /* an entry in the hash threaded list of names */
dcl  name_entry_ptr			ptr;
dcl  name_entry_rel			bit (18);		/* rel ptr to name_entry */
dcl  name_tries			fixed bin;	/* counter of tries to walk hash threads looking for a name before giving up */
dcl  null				builtin;
dcl  out_of_bounds			condition;
dcl  p_code			fixed bin (35) parameter;
dcl  p_name			char (*) parameter;
dcl  p_segnum			fixed bin (15) parameter;
dcl  return_string			char (256) varying;
dcl  rtrim			builtin;
dcl  seg_name			char (32);
dcl  segno			builtin;
dcl  segnum			fixed bin (15);
dcl  segptr			ptr parameter;
dcl  substr			builtin;
dcl  word				fixed bin (36) unsigned unaligned based;
dcl  wordno			builtin;
dcl  wordnum			fixed bin (26);

	p_code = 0;
	name = p_name;
	on out_of_bounds goto no_name;
	names_ptr = addr (crash_name_table$);
	hash_value = hash_index_ (addr (name), length (name), 0, dimension (name_seg.ht, 1));
	name_tries = 0;
	do name_entry_rel = name_seg.ht (hash_value)
	     repeat (name_entry.hp)
	     while (name_entry_rel);			/* scan down names that hash alike */
	     name_entry_ptr = addrel (names_ptr, name_entry_rel);
	     if name_entry.name = name then do;
		p_segnum = bin (name_entry.segno, 12);
		return;
	     end;
	     name_tries = name_tries + 1;
	     if name_tries > 100 then go to no_name;
	end;
no_name:
	p_code = error_table_$name_not_found;
	return;
%page;
bce_segnum_to_name_: entry (p_segnum) returns (char (*));

/* Find the hcname for a segment. */

	segnum = p_segnum;
	if segnum = 32767 | segnum = 32766 then return ("bad pointer");
	on out_of_bounds goto no_num;
	sltp = addr (crash_slt$);
	if segnum < 0 | segnum < slt.first_sup_seg then go to no_num;
	if slt.last_sup_seg < segnum & segnum < slt.first_init_seg then go to no_num;
	if slt.last_init_seg < segnum then go to no_num;
	sltep = addr (slt.seg (segnum));
	if slte_uns.segno ^= segnum then go to no_num;
	name_entry_ptr = addrel (addr (crash_name_table$), slte.names_ptr);
	name_entry_ptr = addrel (name_entry_ptr, 1);
	return (rtrim (name_entry.name));

no_num:	call ioa_$rsnnl ("^o", my_name, my_name_len, segnum);
	return (substr (my_name, 1, my_name_len));
%page;
bce_segptr_to_name_: entry (segptr) returns (char (*));

	return_string = "";
	counter = 1;
	segnum = segno (segptr);
	wordnum = wordno (segptr);
	call ioa_$rsnnl ("^o", my_name, my_name_len, segnum);
	return_string = return_string || substr (my_name, 1, my_name_len) || "|";
	call ioa_$rsnnl ("^o", my_name, my_name_len, wordnum);
	return_string = return_string || substr (my_name, 1, my_name_len);

	sltp = addr (crash_slt$);
	if segnum < 0 | segnum < slt.first_sup_seg then go to return_simple_ptr;
	if slt.last_sup_seg < segnum & segnum < slt.first_init_seg then go to return_simple_ptr;
	if slt.last_init_seg < segnum then go to return_simple_ptr;

	on out_of_bounds goto return_simple_ptr;

	definitions_ptr = addr (crash_definitions_$);
	def_header_ptr = addrel (definitions_ptr, definitions.dot (segnum).offset);
	closest_hi_def_ptr = null;
	closest_lo_def_ptr = null;

	do def_ptr = addrel (def_header_ptr, definition_header.def_list_relp) repeat addrel (def_header_ptr, definition.forward_relp) while (def_ptr -> word ^= 0 & counter < 1000);
						/* If def_ptr -> zero word then we found the end of the string or if we see a thousand definitions the string must be bad. */
	     counter = counter + 1;
	     if definition.class = CLASS_TEXT then do;	/* We care only about class text definitions. */
		if closest_lo_def_ptr = null then	/*  Find def pointing to closest address below our ptr. */
		     if definition.thing_relp <= wordnum then closest_lo_def_ptr = def_ptr;
		     else ;
		else if closest_lo_def.thing_relp < definition.thing_relp & definition.thing_relp <= wordnum then closest_lo_def_ptr = def_ptr;
		     else ;
		if closest_hi_def_ptr = null then	/* Find def pointing to closest address above our ptr. */
		     if wordnum <= definition.thing_relp then closest_hi_def_ptr = def_ptr;
		     else ;
		else if wordnum <= definition.thing_relp & definition.thing_relp < closest_hi_def.thing_relp then closest_hi_def_ptr = def_ptr;
		     else ;
	     end;
	end;

	seg_name = bce_segnum_to_name_ (segnum);
	if closest_lo_def_ptr = null then do;
	     call ioa_$rsnnl ("^o", my_name, my_name_len, wordnum);
	     return_string = return_string || " [" || rtrim (bce_segnum_to_name_ (segnum)) || "|" || substr (my_name, 1, my_name_len) || "]";
	end;
	else do;
	     return_string = return_string || " [";
	     closest_lo_segname_def_ptr = addrel (def_header_ptr, closest_lo_def.segname_relp);
	     if closest_hi_def_ptr = null then do;
		acc_string_ptr = addrel (def_header_ptr, closest_lo_segname_def.name_relp);
		return_string = return_string || substr (acc_string.string, 1, acc_string.count) || "$";
		acc_string_ptr = addrel (def_header_ptr, closest_lo_def.name_relp);
		return_string = return_string || substr (acc_string.string, 1, acc_string.count) || "+";
		lo_offset = wordnum - closest_lo_def.thing_relp;
		call ioa_$rsnnl ("^o", my_name, my_name_len, lo_offset);
		return_string = return_string || substr (my_name, 1, my_name_len) || "]";
	     end;
	     else do;
		closest_hi_segname_def_ptr = addrel (def_header_ptr, closest_hi_def.segname_relp);
		if closest_hi_segname_def_ptr = closest_lo_segname_def_ptr then do;
		     acc_string_ptr = addrel (def_header_ptr, closest_lo_segname_def.name_relp);
		     if closest_hi_def_ptr = closest_lo_def_ptr & wordnum - closest_lo_def.thing_relp = 0 then do;
			return_string = return_string || substr (acc_string.string, 1, acc_string.count) || "$";
			acc_string_ptr = addrel (def_header_ptr, closest_lo_def.name_relp);
			return_string = return_string || substr (acc_string.string, 1, acc_string.count) || "+0]";
		     end;
		     else do;
			return_string = return_string || substr (acc_string.string, 1, acc_string.count) || "$(";
			acc_string_ptr = addrel (def_header_ptr, closest_lo_def.name_relp);
			return_string = return_string || substr (acc_string.string, 1, acc_string.count) || "+";
			lo_offset = wordnum - closest_lo_def.thing_relp;
			call ioa_$rsnnl ("^o", my_name, my_name_len, lo_offset);
			return_string = return_string || substr (my_name, 1, my_name_len);
			acc_string_ptr = addrel (def_header_ptr, closest_hi_def.name_relp);
			return_string = return_string || " " || substr (acc_string.string, 1, acc_string.count) || "-";
			hi_offset = closest_hi_def.thing_relp - wordnum;
			call ioa_$rsnnl ("^o", my_name, my_name_len, hi_offset);
			return_string = return_string || substr (my_name, 1, my_name_len) || ")]";
		     end;
		end;
		else do;
		     acc_string_ptr = addrel (def_header_ptr, closest_lo_segname_def.name_relp);
		     return_string = return_string || "(" || substr (acc_string.string, 1, acc_string.count) || "$";
		     acc_string_ptr = addrel (def_header_ptr, closest_lo_def.name_relp);
		     return_string = return_string || substr (acc_string.string, 1, acc_string.count) || "+";
		     lo_offset = wordnum - closest_lo_def.thing_relp;
		     call ioa_$rsnnl ("^o", my_name, my_name_len, lo_offset);
		     return_string = return_string || substr (my_name, 1, my_name_len);
		     acc_string_ptr = addrel (def_header_ptr, closest_hi_segname_def.name_relp);
		     return_string = return_string || " " || substr (acc_string.string, 1, acc_string.count) || "$";
		     acc_string_ptr = addrel (def_header_ptr, closest_hi_def.name_relp);
		     return_string = return_string || substr (acc_string.string, 1, acc_string.count) || "-";
		     hi_offset = closest_hi_def.thing_relp - wordnum;
		     call ioa_$rsnnl ("^o", my_name, my_name_len, hi_offset);
		     return_string = return_string || substr (my_name, 1, my_name_len) || ")]";
		end;
	     end;
	end;

return_simple_ptr:
	return (return_string);

%page; %include definition_dcls;
%page; %include hc_definitions_seg;
%page; %include slt;
%page; %include slte;
     end;




		    bce_probe.pl1.pmac              11/11/89  1134.9rew 11/11/89  0826.6      639468



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

/****^  HISTORY COMMENTS:
  1) change(86-01-10,Farley), approve(86-01-10,MCR6979),
     audit(86-01-24,GDixon), install(86-03-21,MR12.0-1033):
     Corrected to use first_rec_num & last_rec_num instead of 0 & rec_per_dev.
  2) change(86-04-11,Fawcett), approve(86-04-11,MCR7383),
     audit(86-05-14,Farley), install(86-07-17,MR12.0-1097):
     Add subvolume support, by calling disk_name_pvtx.
                                                   END HISTORY COMMENTS */

bce_probe: proc (p_ss_info_ptr);

/* Program to examine and change locations in the saved Multics image.
Written in November of 1983 by Keith Loepere. */
/* Modified (get_address) June of 1984 to find addresses with symbolic
references. - Allen Ball. */
/* Modified March 1985 to move relocate_instruction_ into hardcore, Keith Loepere. */

/* WARNING: this must be run through pl1_macro, without args, before compilation. */

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

/* Types of addresses and modes... */


dcl  Absolute			fixed bin static options (constant) init (1);
dcl  Accessing_breakpoint_page	char (25) static options (constant) init ("Accessing breakpoint page");
dcl  Accessing_segment		char (17) static options (constant) init ("Accessing segment");
dcl  Address_missing		char (15) static options (constant) init ("Address missing");
dcl  Address_type_must_be_virtual	char (28) static options (constant) init ("Address type must be virtual");
dcl  Apte_number_missing		char (19) static options (constant) init ("Apte number missing");
dcl  Ascii			fixed bin static options (constant) init (1); /* mode */
dcl  Bad_apte			char (8) static options (constant) init ("Bad apte");
dcl  Bad_component_name		char (18) static options (constant) init ("Bad component name");
dcl  Bad_disk_record		char (15) static options (constant) init ("Bad disk record");
dcl  Bad_decimal_value		char (17) static options (constant) init ("Bad decimal value");
dcl  Bad_octal_value		char (15) static options (constant) init ("Bad octal value");
dcl  Bad_page_offset		char (15) static options (constant) init ("Bad page offset");
dcl  Bad_segment_offset		char (18) static options (constant) init ("Bad segment offset");
dcl  Base8			fixed bin static options (constant) init (8);
dcl  Base10			fixed bin static options (constant) init (10);
dcl  Bce_mode			fixed bin static options (constant) init (3);
dcl  Break_already_set		char (17) static options (constant) init ("Break already set");
dcl  Break_mode			fixed bin static options (constant) init (1);
dcl  Crash_mode			fixed bin static options (constant) init (2);
dcl  DRL_1			bit (36) aligned static options (constant) init ("777777002000"b3);
dcl  Decimal			fixed bin static options (constant) init (2); /* mode */
dcl  Disk				fixed bin static options (constant) init (2);
dcl  Dot_must_be_followed_by_plus_or_minus char (37) static options (constant) init ("Dot must be followed by plus or minus");
dcl  Function_arg_list_missing	char (25) static options (constant) init ("Function arg list missing");
dcl  Function_argument_missing	char (25) static options (constant) init ("Function argument missing");
dcl  Improper_arg_list_end_for_function char (34) static options (constant) init ("Improper arg list end for function");
dcl  Improper_syntax_in_line		char (23) static options (constant) init ("Improper syntax in line");
dcl  Instruction			fixed bin static options (constant) init (3); /* mode */
dcl  Invalid_word_offset		char (19) static options (constant) init ("Invalid word offset");
dcl  Instruction_cannot_be_breakpointed char (34) static options (constant) init ("Instruction cannot be breakpointed");
dcl  Missing_component		char (17) static options (constant) init ("Missing component");
dcl  Missing_equals			char (9) static options (constant) init ("Missing =");
dcl  Missing_offset			char (14) static options (constant) init ("Missing offset");
dcl  Missing_seg_id			char (14) static options (constant) init ("Missing seg id");
dcl  Missing_value			char (13) static options (constant) init ("Missing value");
dcl  Missing_word_offset		char (19) static options (constant) init ("Missing word offset");
dcl  NOP				bit (36) static options (constant) init ("000000011000"b3);
dcl  Name				char (4) static options (constant) init ("Name");
dcl  Name_missing			char (12) static options (constant) init ("Name missing");
dcl  No_break_set			char (12) static options (constant) init ("No break set");
dcl  No_current_address		char (18) static options (constant) init ("No current address");
dcl  No_current_break		char (16) static options (constant) init ("No current break");
dcl  No_image_to_restart		char (19) static options (constant) init ("No image to restart");
dcl  No_offset_may_be_added_to_register_addresses char (44) static options (constant) init ("No offset may be added to register addresses");
dcl  No_such_drive			char (13) static options (constant) init ("No such drive");
dcl  Octal			fixed bin static options (constant) init (4); /* mode */
dcl  Offset_makes_address_negative	char (29) static options (constant) init ("Offset makes address negative");
dcl  Plus_or_minus_allowed_only_with_an_entry_name char (45) static options (constant) init ("Plus or minus allowed only with an entry name");
dcl  Pointer			fixed bin static options (constant) init (5); /* mode */
dcl  Reading_a_line			char (14) static options (constant) init ("Reading a line");
dcl  Reading_disk			char (12) static options (constant) init ("Reading disk");
dcl  Register			fixed bin static options (constant) init (3);
dcl  Register_address_not_allowed	char (28) static options (constant) init ("Register address not allowed");
dcl  Segment_name			char (12) static options (constant) init ("Segment name");
dcl  Segment_not_breakpointable	char (26) static options (constant) init ("Segment not breakpointable");
dcl  Segment_number_missing		char (22) static options (constant) init ("Segment number missing");
dcl  TRA				bit (18) init ("710000"b3);
dcl  Too_many_breakpoints_in_segment	char (31) static options (constant) init ("Too many breakpoints in segment");
dcl  Unexpected_args_follow		char (22) static options (constant) init ("Unexpected args follow");
dcl  Unknown_mode			char (12) static options (constant) init ("Unknown mode");
dcl  Unmatched_quotes		char (16) static options (constant) init ("Unmatched_quotes");
dcl  Unrecognizable_address		char (22) static options (constant) init ("Unrecognizable address");
dcl  Unrecognizable_request		char (22) static options (constant) init ("Unrecognizable request");
dcl  Unrecognizable_option		char (21) static options (constant) init ("Unrecognizable option");
dcl  Unrecognizable_value		char (20) static options (constant) init ("Unrecognizable value");
dcl  Unknown_register		char (16) static options (constant) init ("Unknown register");
dcl  Values_being_let_too_long	char (25) static options (constant) init ("Values being let too long");
dcl  Virtual			fixed bin static options (constant) init (4);
dcl  Writing_disk			char (12) static options (constant) init ("Writing disk");

dcl  absadr			entry (ptr, fixed bin (35)) returns (fixed bin (26));
dcl  addbitno			builtin;
dcl  addcharno			builtin;
dcl  addr				builtin;
dcl  addrel			builtin;
dcl  addwordno			builtin;
dcl  arg				char (arg_len) based (arg_ptr);
dcl  arg_index			fixed bin;	/* loop var for function args */
dcl  arg_len			fixed bin (21);
dcl  arg_num			fixed bin;
dcl  arg_ptr			ptr;
dcl  1 arg_list			aligned,		/* for calling functions within us */
       2 twice_num_args		fixed bin (18) uns unal, /* standard stuff */
       2 tag			bit (18) unal init ("000004"b3),
       2 pad_descriptors		fixed bin (18) uns unal init (0),
       2 arg_ptrs			(8) ptr;
dcl  arg_str_lens			(4) fixed bin;	/* used as built arguments to functions we call */
dcl  arg_str_ptrs			(4) ptr;		/* used as built arguments to functions we call */
dcl  baseptr			builtin;
dcl  bce_appending_simulation$get_absolute entry (fixed bin (26), fixed bin (18), ptr, fixed bin (35));
dcl  bce_appending_simulation$get_virtual entry (ptr, fixed bin (26), fixed bin (18), ptr, fixed bin (35));
dcl  bce_appending_simulation$put_absolute entry (fixed bin (26), fixed bin (18), ptr, fixed bin (35));
dcl  bce_appending_simulation$put_virtual entry (ptr, fixed bin (26), fixed bin (18), ptr, fixed bin (35));
dcl  bce_appending_simulation$init	entry (bit (1) aligned, fixed bin (35));
dcl  bce_appending_simulation$new_dbr	entry (bit (72) aligned, fixed bin (15), fixed bin (35));
dcl  bce_appending_simulation$new_segment entry (fixed bin (15), ptr, fixed bin (35));
dcl  bce_component_to_wordnum_	entry (fixed bin (15), char (32), char (32), fixed bin (15), fixed bin (26), fixed bin (35));
dcl  bce_continue			entry;
dcl  bce_data$get_line		external variable entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35));
dcl  disk_name_pvtx		entry (char (8), fixed bin, fixed bin (35));
dcl  bce_display_instruction_		entry (ptr, fixed bin, fixed bin (26));
dcl  bce_display_scu_		entry (ptr, fixed bin (26), bit (1) aligned);
dcl  bce_inst_length_		entry (ptr, fixed bin) returns (fixed bin);
dcl  bce_name_to_segnum_		entry (char (*), fixed bin (15), fixed bin (35));
dcl  1 bce_probe_data		aligned,
       2 my_seg_info_ptr		ptr,		/* current seg_info */
       2 last_segnum		fixed bin (15),	/* highest segnum valid for this dbr */
       2 address,					/* current address */
         3 type			fixed bin,
         3 pvtx			fixed bin,	/* for disk address */
         3 record_num		fixed bin (18),
         3 pad			bit (36),
         3 reg_ptr			ptr,		/* address of register (in toehold or breakpoint_page)  */
         3 segnum			fixed bin (15),
         3 wordnum			fixed bin (26),
         3 default_mode		fixed bin,
         3 default_len		fixed bin (24),	/* in bits */
         3 error_name		char (32) unal;	/* used in error msgs */
dcl  bce_relocate_instruction_	entry (ptr, ptr, fixed bin (18), fixed bin, fixed bin, fixed bin (35));
dcl  bce_segnum_to_name_		entry (fixed bin (15)) returns (char (*));
dcl  bce_segptr_to_name_		entry (ptr) returns (char (*));
dcl  bin				builtin;
dcl  bit				builtin;
dcl  breakpoint_absadr		fixed bin (26);	/* to breakpoint_page */
dcl  breakpoint_at			ptr;		/* within simulated space of active break */
dcl  breakpoint_page$		external;
dcl  1 breakpoint_page_buffer		aligned like bkpt_page.header;
dcl  code				fixed bin (35);
dcl  com_err_			entry () options (variable);
dcl  crash_definitions_$		ext;
dcl  crash_name_table$		ext;
dcl  crash_lot$			ext;
dcl  crash_slt$			ext;
dcl  cu_$arg_count_rel		entry (fixed bin, ptr, fixed bin (35));
dcl  cu_$arg_ptr_rel		entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  cu_$generate_call		entry (entry, ptr);
dcl  cv_integer_string_check_		entry (char (*), fixed bin, fixed bin (35)) returns (fixed bin (35));
dcl  date_time_			entry (fixed bin (71), char (*));
dcl  definitions_$			ext;
dcl  dimension			builtin;
dcl  divide			builtin;
dcl  error_table_$bad_arg		fixed bin (35) ext static;
dcl  examine_mode			fixed bin;	/* break versus crash vs bce */
dcl  fixed			builtin;
dcl  get_ptrs_$given_segno		entry (fixed bin (15)) returns (ptr);
dcl  index			builtin;
dcl  ioa_				entry () options (variable);
dcl  length			builtin;
dcl  line				char (line_len) based (line_ptr); /* amount of input request line left to process */
dcl  line_buffer			char (128);	/* area to hold input request line */
dcl  line_len			fixed bin;
dcl  line_ptr			ptr;
dcl  lot$				external;
dcl  me				char (5) static options (constant) init ("probe");
dcl  min				builtin;
dcl  mod				builtin;
dcl  my_dbr			bit (72) aligned;
dcl  my_initial_dbr			bit (72) aligned;
dcl  1 my_seg_info			aligned like seg_info; /* describe seg being dumped for virtual addr */
dcl  name_table$			ext;
dcl  null				builtin;
dcl  old_instr_buffer		(4) bit (36) aligned;
dcl  p_ss_info_ptr			ptr parameter;
dcl  pc$nullify			entry (ptr);
dcl  prs				(0:7) char (4) int static options (constant)
				init ("(ap)", "(ab)", "(bp)", "(bb)", "(lp)", "(lb)", "(sp)", "(sb)");
dcl  ptr				builtin;
dcl  read_disk			entry (fixed bin, fixed bin (18), ptr, fixed bin (35));
dcl  rtrim			builtin;
%set reg_num to 0;
%set reg_num to reg_num + 1; %set pr0_num to reg_num;
%set reg_num to reg_num + 1; %set pr1_num to reg_num;
%set reg_num to reg_num + 1; %set pr2_num to reg_num;
%set reg_num to reg_num + 1; %set pr3_num to reg_num;
%set reg_num to reg_num + 1; %set pr4_num to reg_num;
%set reg_num to reg_num + 1; %set pr5_num to reg_num;
%set reg_num to reg_num + 1; %set pr6_num to reg_num;
%set reg_num to reg_num + 1; %set pr7_num to reg_num;
%set reg_num to reg_num + 1; %set x0_num to reg_num;
%set reg_num to reg_num + 1; %set x1_num to reg_num;
%set reg_num to reg_num + 1; %set x2_num to reg_num;
%set reg_num to reg_num + 1; %set x3_num to reg_num;
%set reg_num to reg_num + 1; %set x4_num to reg_num;
%set reg_num to reg_num + 1; %set x5_num to reg_num;
%set reg_num to reg_num + 1; %set x6_num to reg_num;
%set reg_num to reg_num + 1; %set x7_num to reg_num;
%set reg_num to reg_num + 1; %set a_num to reg_num;
%set reg_num to reg_num + 1; %set q_num to reg_num;
%set reg_num to reg_num + 1; %set e_num to reg_num;
%set reg_num to reg_num + 1; %set t_num to reg_num;
%set reg_num to reg_num + 1; %set ralr_num to reg_num;
%set reg_num to reg_num + 1; %set fault_num to reg_num;
%set reg_num to reg_num + 1; %set ext_fault_num to reg_num;
%set reg_num to reg_num + 1; %set mode_num to reg_num;
%set reg_num to reg_num + 1; %set cache_num to reg_num;
%set reg_num to reg_num + 1; %set dbr_num to reg_num;
%set reg_num to reg_num + 1; %set bar_num to reg_num;
dcl  reg_lens			(reg_num) fixed bin static options (constant) init /* become default lengths for register display */
				(72, 72, 72, 72, 72, 72, 72, 72,
				18, 18, 18, 18, 18, 18, 18, 18,
				36, 36, 8, 27, 3, 36, 15, 36,
				36, 72, 36);
dcl  reg_modes			(reg_num) fixed bin init
				(Pointer, Pointer, Pointer, Pointer, Pointer, Pointer, Pointer, Pointer,
				Octal, Octal, Octal, Octal, Octal, Octal, Octal, Octal,
				Octal, Octal, Octal, Octal, Octal, Octal, Octal, Octal,
				Octal, Octal, Octal);
dcl  reg_names			(reg_num) char (9) static options (constant) init
				("pr0", "pr1", "pr2", "pr3", "pr4", "pr5", "pr6", "pr7",
				"x0", "x1", "x2", "x3", "x4", "x5", "x6", "x7",
				"a", "q", "e", "t", "ralr", "fault", "ext_fault", "mode",
				"cache", "dbr", "bar");
dcl  reg_ptrs			(reg_num) ptr;	/* start of reg */
dcl  req_index			fixed bin;	/* loop index on requests */
%set req_num to 0;
%set req_num to req_num + 1; %set b_req to req_num;
%set req_num to req_num + 1; %set before_req to req_num;
%set req_num to req_num + 1; %set c_req to req_num;
%set req_num to req_num + 1; %set continue_req to req_num;
%set req_num to req_num + 1; %set dbr_req to req_num;
%set req_num to req_num + 1; %set display_req to req_num;
%set req_num to req_num + 1; %set dot_req to req_num;
%set req_num to req_num + 1; %set ds_req to req_num;
%set req_num to req_num + 1; %set l_req to req_num;
%set req_num to req_num + 1; %set let_req to req_num;
%set req_num to req_num + 1; %set list_requests_req to req_num;
%set req_num to req_num + 1; %set lr_req to req_num;
%set req_num to req_num + 1; %set mc_req to req_num;
%set req_num to req_num + 1; %set name_req to req_num;
%set req_num to req_num + 1; %set proc_req to req_num;
%set req_num to req_num + 1; %set q_req to req_num;
%set req_num to req_num + 1; %set quit_req to req_num;
%set req_num to req_num + 1; %set r_req to req_num;
%set req_num to req_num + 1; %set reset_req to req_num;
%set req_num to req_num + 1; %set segno_req to req_num;
%set req_num to req_num + 1; %set sk_req to req_num;
%set req_num to req_num + 1; %set st_req to req_num;
%set req_num to req_num + 1; %set stack_req to req_num;
%set req_num to req_num + 1; %set status_req to req_num;
dcl  requests			(req_num) char (16) static options (constant) init
				("b", "before", "c", "continue", "dbr", "display", ".", "ds", "l", "let", "list_requests", "lr", "mc", "name", "proc", "q", "quit", "r", "reset", "segno", "sk", "st", "stack", "status");
dcl  search			builtin;
dcl  segno			builtin;
dcl  size				builtin;
dcl  slt$				external;
dcl  string			char (string_len) based (string_ptr); /* item in request line being examined */
dcl  string_len			fixed bin;
dcl  string_ptr			ptr;
dcl  sub_request_abort_		condition;
dcl  substr			builtin;
dcl  sys_boot_info$bce_dbr		bit (72) aligned external;
dcl  tc_data$			external;
dcl  1 toehold$			aligned like toe_hold external;
dcl  unspec			builtin;
dcl  1 value			aligned,		/* description of value in let request */
       2 type			fixed bin,
       2 length			fixed bin,	/* in bits */
       2 align			fixed bin (71),
       2 data			bit (256 * 9) aligned; /* max allowed */
dcl  verify			builtin;
dcl  1 work_area			aligned,
       2 left_from_before		bit (4 * 36),
       2 buffer			bit (1024 * 36);	/* for building data to write */
dcl  write_disk			entry (fixed bin, fixed bin (18), ptr, fixed bin (35));
dcl  wordno			builtin;
%page;
	ss_info_ptr = p_ss_info_ptr;
	fgbxp = addr (flagbox$);
	if fgbx.breakpoint then examine_mode = Break_mode;
	else if sys_info$collection_1_phase = CRASH_INITIALIZATION | sys_info$collection_1_phase = BCE_CRASH_INITIALIZATION then examine_mode = Crash_mode;
	else examine_mode = Bce_mode;
	if ss_info_ptr ^= null then do;
	     call cu_$arg_count_rel (arg_num, ss_info.arg_list_ptr, code);
	     if code = 0 then do arg_index = 1 to arg_num;
		call cu_$arg_ptr_rel (arg_index, arg_ptr, arg_len, code, ss_info.arg_list_ptr);
		if arg = "-crash" then examine_mode = Crash_mode;
		else if arg = "-bce" then examine_mode = Bce_mode;
		else if arg = "-break" then examine_mode = Break_mode;
		else do;
		     call com_err_ (error_table_$bad_arg, me, "^a", arg);
		     return;
		end;
	     end;
	end;
	call ioa_ ("Using ^[breakpoint info^;Multics image^;bce^].", examine_mode);

	if examine_mode = Crash_mode then do;
	     reg_ptrs (pr0_num) = addr (toehold$.mc_.prs (0));
	     reg_ptrs (pr1_num) = addr (toehold$.mc_.prs (1));
	     reg_ptrs (pr2_num) = addr (toehold$.mc_.prs (2));
	     reg_ptrs (pr3_num) = addr (toehold$.mc_.prs (3));
	     reg_ptrs (pr4_num) = addr (toehold$.mc_.prs (4));
	     reg_ptrs (pr5_num) = addr (toehold$.mc_.prs (5));
	     reg_ptrs (pr6_num) = addr (toehold$.mc_.prs (6));
	     reg_ptrs (pr7_num) = addr (toehold$.mc_.prs (7));
	     reg_ptrs (x0_num) = addr (toehold$.mc_.x (0));
	     reg_ptrs (x1_num) = addr (toehold$.mc_.x (1));
	     reg_ptrs (x2_num) = addr (toehold$.mc_.x (2));
	     reg_ptrs (x3_num) = addr (toehold$.mc_.x (3));
	     reg_ptrs (x4_num) = addr (toehold$.mc_.x (4));
	     reg_ptrs (x5_num) = addr (toehold$.mc_.x (5));
	     reg_ptrs (x6_num) = addr (toehold$.mc_.x (6));
	     reg_ptrs (x7_num) = addr (toehold$.mc_.x (7));
	     reg_ptrs (a_num) = addr (toehold$.mc_.a);
	     reg_ptrs (q_num) = addr (toehold$.mc_.q);
	     reg_ptrs (e_num) = addr (toehold$.mc_.e);
	     reg_ptrs (t_num) = addr (toehold$.mc_.t);
	     reg_ptrs (ralr_num) = addr (toehold$.mc_.ralr);
	     reg_ptrs (fault_num) = addr (toehold$.mc_.fault_reg);
	     reg_ptrs (ext_fault_num) = addr (toehold$.mc_.ext_fault_reg);
	     reg_ptrs (mode_num) = addr (toehold$.mode_reg);
	     reg_ptrs (cache_num) = addr (toehold$.cache_mode_reg);
	     reg_ptrs (dbr_num) = addr (toehold$.multics_state.dbr);
	     reg_ptrs (bar_num) = addr (toehold$.bar);
	end;
	else do;
	     reg_ptrs (pr0_num) = addr (breakpoint_page_buffer.mc_.prs (0));
	     reg_ptrs (pr1_num) = addr (breakpoint_page_buffer.mc_.prs (1));
	     reg_ptrs (pr2_num) = addr (breakpoint_page_buffer.mc_.prs (2));
	     reg_ptrs (pr3_num) = addr (breakpoint_page_buffer.mc_.prs (3));
	     reg_ptrs (pr4_num) = addr (breakpoint_page_buffer.mc_.prs (4));
	     reg_ptrs (pr5_num) = addr (breakpoint_page_buffer.mc_.prs (5));
	     reg_ptrs (pr6_num) = addr (breakpoint_page_buffer.mc_.prs (6));
	     reg_ptrs (pr7_num) = addr (breakpoint_page_buffer.mc_.prs (7));
	     reg_ptrs (x0_num) = addr (breakpoint_page_buffer.mc_.x (0));
	     reg_ptrs (x1_num) = addr (breakpoint_page_buffer.mc_.x (1));
	     reg_ptrs (x2_num) = addr (breakpoint_page_buffer.mc_.x (2));
	     reg_ptrs (x3_num) = addr (breakpoint_page_buffer.mc_.x (3));
	     reg_ptrs (x4_num) = addr (breakpoint_page_buffer.mc_.x (4));
	     reg_ptrs (x5_num) = addr (breakpoint_page_buffer.mc_.x (5));
	     reg_ptrs (x6_num) = addr (breakpoint_page_buffer.mc_.x (6));
	     reg_ptrs (x7_num) = addr (breakpoint_page_buffer.mc_.x (7));
	     reg_ptrs (a_num) = addr (breakpoint_page_buffer.mc_.a);
	     reg_ptrs (q_num) = addr (breakpoint_page_buffer.mc_.q);
	     reg_ptrs (e_num) = addr (breakpoint_page_buffer.mc_.e);
	     reg_ptrs (t_num) = addr (breakpoint_page_buffer.mc_.t);
	     reg_ptrs (ralr_num) = addr (breakpoint_page_buffer.mc_.ralr);
	     reg_ptrs (fault_num) = addr (breakpoint_page_buffer.mc_.fault_reg);
	     reg_ptrs (ext_fault_num) = addr (breakpoint_page_buffer.mc_.ext_fault_reg);
	     reg_ptrs (mode_num) = addr (breakpoint_page_buffer.mode_reg);
	     reg_ptrs (cache_num) = addr (breakpoint_page_buffer.cache_mode_reg);
	     reg_ptrs (dbr_num) = addr (breakpoint_page_buffer.dbr);
	     reg_ptrs (bar_num) = addr (breakpoint_page_buffer.bar);
	end;
%page;
	bce_probe_data.my_seg_info_ptr = addr (my_seg_info);
	sltp = addr (slt$);
	bce_probe_data.address.type = 0;
	do arg_index = 1 to dimension (arg_str_ptrs, 1);
	     arg_list.arg_ptrs (arg_index * 2 - 1) = addr (arg_str_ptrs (arg_index));
	     arg_list.arg_ptrs (arg_index * 2) = addr (arg_str_lens (arg_index));
	end;

	call bce_appending_simulation$init (examine_mode ^= Bce_mode, code);
	if examine_mode ^= Bce_mode then my_dbr = toehold$.multics_state.dbr;
	else my_dbr = sys_boot_info$bce_dbr;
	my_initial_dbr = my_dbr;
	call new_dbr (my_dbr);

	breakpoint_absadr = absadr (addr (breakpoint_page$), (0));
	breakpoint_at = null;
	if examine_mode = Break_mode then do;
	     call bce_appending_simulation$get_absolute (breakpoint_absadr, size (breakpoint_page_buffer), addr (breakpoint_page_buffer), code);
	     if code ^= 0 then do;
		call com_err_ (code, me, "Cannot process break info.");
		return;
	     end;
	     scup = addr (breakpoint_page_buffer.mc_.scu);
	     breakpoint_at = addrel (baseptr (bin (scu.ppr.psr, 15)), bin (scu.ilc, 18) - 1); /* the drl - start of breakpoint info */
	     call bce_appending_simulation$new_segment (segno (breakpoint_at), bce_probe_data.my_seg_info_ptr, code);
	     if code = 0 then do;
		breakpoint_ptr = addr (buffer);
		call bce_appending_simulation$get_virtual (bce_probe_data.my_seg_info_ptr, wordno (breakpoint_at), size (breakpoint), breakpoint_ptr, code);
		if code = 0 then do;
		     breakpoint_at = breakpoint.original_instr_ptr;
		     call ioa_ ("Break before ^a.", bce_segptr_to_name_ (breakpoint_at));
		end;
		else breakpoint_at = null;
	     end;
	     else breakpoint_at = null;
	end;

	line_len = 0;
	on sub_request_abort_ begin;
	     line_len = 0;
	     go to request_done;
	end;
	do while ("1"b);
	     string_len = 0;
	     do while (string_len = 0);		/* find a command name */
		do while (line_len = 0);		/* get a line */
		     line_ptr = addr (line_buffer);
		     code = 1;
		     do while (code ^= 0);
			call bce_data$get_line (addr (bce_data$get_line), addr (line_buffer), length (line_buffer), line_len, code);
			if code ^= 0 then call line_error_code (code, Reading_a_line);
		     end;
		end;

/* extract command name */

		call get_string;
		if string_len = 0 then do;		/* we have found a delimiter */
		     if substr (line, 1, 1) = ";" | substr (line, 1, 1) = "
" /* NL */ then do;
			line_len = line_len - 1;	/* pass ; or NL */
			line_ptr = addcharno (line_ptr, 1);
		     end;
		     else call line_error (Improper_syntax_in_line);
		end;
	     end;

	     do req_index = 1 to dimension (requests, 1) while (requests (req_index) ^= string);
	     end;
	     if req_index > dimension (requests, 1) then call line_error (Unrecognizable_request);
	     else go to do_request (req_index);
%page;
do_request (b_req /* b_req */):

	     go to do_request (before_req /* before_req */);
%page;
do_request (before_req /* before_req */): begin;

dcl  bkpt_num			fixed bin;	/* loop counter */
dcl  1 bkpt_tra_instr		aligned based (addr (old_instr_buffer)),
       2 offset			fixed bin (18) uns unal, /* tra instruction that the breakpoint becomes */
       2 op			bit (18) unal;
dcl  eis_len			fixed bin;	/* num of eis descrs */
dcl  instr_delta			fixed bin (18);	/* amt to reloacte instr being broken at */
dcl  instr_len			fixed bin;	/* of instr being reloacted */
dcl  instr_num			fixed bin;	/* loop counter */
dcl  instr_ptr			ptr;		/* to instruction to set break at */

		call pass_white;
		if line_len > 0 then
		     if substr (line, 1, 1) ^= ";" & substr (line, 1, 1) ^= "
" /* nl */ then call get_address;
		if bce_probe_data.address.type ^= Virtual then call line_error (Address_type_must_be_virtual);
		call check_no_more_args;

		sltp = addr (crash_slt$);
		sltep = addr (slt.seg (bce_probe_data.address.segnum));
		bce_probe_data.address.error_name = bce_segnum_to_name_ (bce_probe_data.address.segnum);
		if ^slte.breakpointable then call line_error_arg (Segment_not_breakpointable, bce_probe_data.address.error_name);

		call bce_appending_simulation$new_segment (bce_probe_data.address.segnum, bce_probe_data.my_seg_info_ptr, code);
		if code ^= 0 then go to before_bad_access;
		bkpt_page_ptr = addr (buffer);
		call bce_appending_simulation$get_virtual (bce_probe_data.my_seg_info_ptr, my_seg_info.size - 1024, 1024, bkpt_page_ptr, code);
		if code ^= 0 then go to before_bad_access;
		instr_ptr = addrel (baseptr (bce_probe_data.address.segnum), bce_probe_data.address.wordnum);
		do bkpt_num = 1 to dimension (bkpt_page.bkpts, 1);
		     if bkpt_page.bkpts (bkpt_num).original_instr_ptr = instr_ptr then call line_error (Break_already_set);
		end;
		do bkpt_num = 1 to dimension (bkpt_page.bkpts, 1) while (unspec (bkpt_page.bkpts (bkpt_num)) ^= "0"b);
		end;
		if bkpt_num > dimension (bkpt_page.bkpts, 1) then call line_error_arg (Too_many_breakpoints_in_segment, bce_probe_data.address.error_name);
		breakpoint_ptr = addr (bkpt_page.bkpts (bkpt_num));
		instr_delta = my_seg_info.size - 1024 + wordno (addr (breakpoint.instructions)) - wordno (bkpt_page_ptr) - bce_probe_data.address.wordnum;
		call bce_appending_simulation$get_virtual (bce_probe_data.my_seg_info_ptr, bce_probe_data.address.wordnum, size (old_instr_buffer), addr (old_instr_buffer), code);
		if code ^= 0 then go to before_bad_access;
		do instr_num = 1 to dimension (breakpoint.instructions, 1);
		     breakpoint.instructions (instr_num) = NOP;
		end;

		instr_len = bce_inst_length_ (addr (old_instr_buffer), eis_len);
		if instr_len = 0 then go to bad_instr_error;
		call bce_relocate_instruction_ (addr (old_instr_buffer), addr (breakpoint.instructions), -instr_delta, instr_len, eis_len, code);
		if code ^= 0 then
bad_instr_error:	     call line_error (Instruction_cannot_be_breakpointed);
		breakpoint.breakpoint_drl = DRL_1;
		breakpoint.tra_back = TRA;
		breakpoint.tra_back_offset = instr_len + bce_probe_data.address.wordnum;
		breakpoint.original_instr_ptr = instr_ptr;
		breakpoint.original_instr = old_instr_buffer (1);

		call bce_appending_simulation$put_virtual (bce_probe_data.my_seg_info_ptr,
		     my_seg_info.size - 1024 + wordno (breakpoint_ptr) - wordno (bkpt_page_ptr),
		     size (breakpoint), breakpoint_ptr, code);
		if code ^= 0 then go to before_bad_access;
		bkpt_tra_instr.op = TRA;
		bkpt_tra_instr.offset = instr_delta - 1 + bce_probe_data.address.wordnum;
		call bce_appending_simulation$put_virtual (bce_probe_data.my_seg_info_ptr, bce_probe_data.address.wordnum, 1, addr (old_instr_buffer), code);
		if code ^= 0 then
before_bad_access:	     call line_error_arg_code (code, Accessing_segment, bce_probe_data.address.error_name);
		call ioa_ ("Break set before ^a.", bce_segptr_to_name_ (instr_ptr));
		go to request_done;
	     end;
%page;
do_request (c_req /* c_req */):
	     go to do_request (continue_req /* continue_req */);
%page;
do_request (continue_req /* continue_req */):
	     call check_no_more_args;
	     if ^(sys_info$collection_1_phase = CRASH_INITIALIZATION | sys_info$collection_1_phase = BCE_CRASH_INITIALIZATION) then call line_error (No_image_to_restart);
	     call bce_continue;
	     go to request_done;
%page;
do_request (dbr_req /* dbr_req */): begin;

dcl  dbr_value			bit (72) aligned;	/* new value being built */
dcl  dbr_word			fixed bin (35);	/* single part of new value */

		call get_string;
		if string_len = 0 then do;
		     call check_no_more_args;
		     my_dbr = my_initial_dbr;
		     call new_dbr (my_dbr);
		     call ioa_ ("dbr = ^24.3b", my_dbr);
		     goto request_done;
		end;
		dbr_word = cv_integer_string_check_ (string, Base8, code);
		if code ^= 0 then go to bad_octal;
		dbr_value = my_dbr;
		substr (dbr_value, 1, 36) = unspec (dbr_word);
		call get_string;
		if string_len > 0 then do;
		     dbr_word = cv_integer_string_check_ (string, Base8, code);
		     if code ^= 0 then
bad_octal:		call line_error (Bad_octal_value);
		     substr (dbr_value, 37, 36) = unspec (dbr_word);
		end;
		call check_no_more_args;
		call new_dbr (dbr_value);
		go to request_done;
	     end;
%page;
do_request (display_req /* display_req */): begin;

dcl  bits_left_over			fixed bin;	/* amt of previous buffer we couldn't display */
dcl  buffer_data_ptr		ptr;		/* where in buffer data starts */
dcl  data_address			fixed bin (26);	/* relative to address type */
dcl  data_bits_done			fixed bin (24);	/* normally for instruction mode - => how many bits not done because of chance that instr wrapped onto next buffer */
dcl  data_label			fixed bin (26);	/* for display */
dcl  data_length			fixed bin (24);	/* in bits */
dcl  data_part_bits			fixed bin (24);	/* number of bits in this bunch to dump */
dcl  data_part_words		fixed bin (18);	/* number of words in this bunch to dump */
dcl  display_buffer_ptr		ptr;		/* start of bits to display taking into account amount scrolled from previous buffer */
dcl  mode				fixed bin;	/* display mode */

		call get_address;
		mode = bce_probe_data.address.default_mode;
		data_length = bce_probe_data.address.default_len;
		call get_string;
		if string_len > 0 then do;
		     if string = "a" then do;
			mode = Ascii;
			data_length = 9;
		     end;
		     else if string = "d" then mode = Decimal;
		     else if string = "i" then mode = Instruction;
		     else if string = "o" then mode = Octal;
		     else if string = "p" then do;
			mode = Pointer;
			data_length = 72;
		     end;
		     else call line_error (Unknown_mode);
		     call get_string;
		     if string_len > 0 then
			if string = "*" & bce_probe_data.address.type = Virtual then
			     data_length = 36 * (my_seg_info.size - bce_probe_data.address.wordnum);
			else do;
			     data_length = cv_integer_string_check_ (string, Base10, code);
			     if code ^= 0 then call line_error (Bad_decimal_value);
			     if mode = Ascii then data_length = data_length * 9;
			     else if mode = Pointer then data_length = data_length * 72;
			     else data_length = data_length * 36;
			end;
		end;
		call check_no_more_args;
		if bce_probe_data.address.type = Register then do;
		     data_length = min (data_length, bce_probe_data.address.default_len);
		     call display (bce_probe_data.address.reg_ptr, data_length, -1, mode, data_bits_done, "0"b);
		end;
		else do;
		     data_address = bce_probe_data.address.wordnum;
		     data_label = data_address;
		     bits_left_over = 0;
		     do while (data_length > 0);	/* do a page at a time */
			data_part_words = 1024 - mod (data_address, 1024);
			buffer_data_ptr = addrel (addr (buffer), mod (data_address, 1024));
			data_part_bits = min (36 * data_part_words, data_length);
			data_part_words = divide (data_part_bits + 35, 36, 18);
			call fetch_ (buffer_data_ptr, data_part_words, data_address - bce_probe_data.address.wordnum, code);
			if code ^= 0 then call line_error_arg_code (code, Accessing_segment, bce_probe_data.address.error_name);
			display_buffer_ptr = addwordno (buffer_data_ptr, -divide (bits_left_over, 36, 17));
			call display (display_buffer_ptr, data_part_bits + bits_left_over, data_label, mode, data_bits_done, data_part_bits < data_length);
			data_length = data_length - data_part_bits;
			data_address = data_address + data_part_words;
			bits_left_over = data_part_bits - data_bits_done;
			data_label = data_label + data_part_words - divide (bits_left_over, 36, 17);
			if bits_left_over > 0 then substr (left_from_before, length (left_from_before) - bits_left_over + 1) = substr (buffer, length (buffer) - bits_left_over + 1); /* scroll bits */
		     end;
		end;
		go to request_done;
	     end;
%page;
do_request (dot_req /* dot_req */):
	     call check_no_more_args;
	     call ioa_ ("probe: Using ^[breakpoint info^;Multics image^;bce^], dbr = ^24.3b", examine_mode, my_dbr);
	     go to request_done;
%page;
do_request (ds_req /* ds_req */):
	     go to do_request (display_req /* display_req */);
%page;
do_request (l_req /* l_req */):
	     go to do_request (let_req /* let_req */);
%page;
do_request (let_req /* let_req */): begin;
dcl  data_length			fixed bin (24);	/* in bits */
dcl  register			bit (data_length) based (bce_probe_data.address.reg_ptr); /* overlay to overwrite register */
dcl  starting_bit			fixed bin;	/* first bit in buffer containing data to move into patch area */

		call get_address;
		starting_bit = 1;
		if bce_probe_data.address.type = Disk then do;
		     if bce_probe_data.address.wordnum < 0 | bce_probe_data.address.wordnum > 1023 then call line_error (Bad_page_offset);
		     call read_disk (bce_probe_data.address.pvtx, bce_probe_data.address.record_num, addr (buffer), code);
		     if code ^= 0 then call line_error_arg_code (code, Reading_disk, bce_probe_data.address.error_name);
		     starting_bit = bce_probe_data.address.wordnum * 36 + 1;
		end;
		call pass_white;
		data_length = 0;
		if substr (line, 1, 1) ^= "=" then call line_error (Missing_equals);
		line_len = line_len - 1;
		line_ptr = addcharno (line_ptr, 1);
		call get_value;
		if starting_bit + data_length > length (buffer) then go to let_values_too_long;
		substr (buffer, starting_bit + data_length, value.length) = substr (value.data, 1, value.length);
		data_length = data_length + value.length;
		call pass_white;
		do while (substr (line, 1, 1) ^= ";" & substr (line, 1, 1) ^= "
" /* NL */);
		     call get_value;
		     if starting_bit + data_length > length (buffer) then
let_values_too_long:	call line_error (Values_being_let_too_long);
		     substr (buffer, starting_bit + data_length, value.length) = substr (value.data, 1, value.length);
		     data_length = data_length + value.length;
		     call pass_white;
		end;
		if bce_probe_data.address.type = Virtual then do;
		     call bce_appending_simulation$put_virtual (bce_probe_data.my_seg_info_ptr, bce_probe_data.address.wordnum, divide (data_length, 36, 18), addr (buffer), code);
		     if code ^= 0 then go to let_bad_access;
		end;
		else if bce_probe_data.address.type = Absolute then do;
		     call bce_appending_simulation$put_absolute (bce_probe_data.address.wordnum, divide (data_length, 36, 18), addr (buffer), code);
		     if code ^= 0 then
let_bad_access:		call line_error_arg_code (code, Accessing_segment, bce_probe_data.address.error_name);
		end;
		else if bce_probe_data.address.type = Register then do;
		     data_length = min (data_length, bce_probe_data.address.default_len);
		     if bce_probe_data.address.default_len > 36 then starting_bit = 72 - mod (data_length - 1, 72);
		     else starting_bit = 36 - mod (data_length - 1, 36);
		     register = substr (buffer, starting_bit, data_length);
		     if examine_mode = Break_mode then do;
			call bce_appending_simulation$put_absolute (breakpoint_absadr, size (breakpoint_page_buffer), addr (breakpoint_page_buffer), code);
			if code ^= 0 then call line_error_code (code, Accessing_breakpoint_page);
		     end;
		end;
		else do;				/* Disk */
		     call write_disk (bce_probe_data.address.pvtx, bce_probe_data.address.record_num, addr (buffer), code);
		     if code ^= 0 then call line_error_arg_code (code, Writing_disk, bce_probe_data.address.error_name);
		end;
		go to request_done;
	     end;
%page;
do_request (list_requests_req /* list_requests_req */):
	     call check_no_more_args;
	     call ioa_ ("Requests are:");
	     call ioa_ ("before, b         continue, c       dbr");
	     call ioa_ ("display, ds       let, l            list_requests, lr");
	     call ioa_ ("mc                name              proc");
	     call ioa_ ("quit, q           reset, r          segno");
	     call ioa_ ("stack, sk         status, st");
	     go to request_done;
%page;
do_request (lr_req /* lr_req */):
	     go to do_request (list_requests_req /* list_requests_req */);
%page;
do_request (mc_req /* mc_req */): begin;

dcl  j				fixed bin;
dcl  long				bit (1) aligned;
dcl  ptr_from_mc			ptr;
dcl  time				char (32);

		call get_address;
		long = "0"b;
		call get_string;
		if string_len > 0 then
		     if string = "lg" | string = "long" then long = "1"b;
		     else call line_error (Unrecognizable_option);
		call check_no_more_args;
		mcp = addr (buffer);
		scup = addr (mcp -> mc.scu);

		call fetch_ (mcp, size (mc), 0, code);
		if code ^= 0 then call line_error_arg_code (code, Accessing_segment, bce_probe_data.address.error_name);
		if long then do;
		     do j = 0 to 7;
			ptr_from_mc = validate_ptr (unspec (mc.prs (j)));
			call ioa_ ("pr^d ^4a^2x^20p^a", j, prs (j), ptr_from_mc, bce_segptr_to_name_ (ptr_from_mc));
		     end;
		     call ioa_;
		     call ioa_ ("x0 ^6o^3xx1 ^6o^3xx2 ^6o^3xx3 ^6o", fixed (mc.x (0), 18), fixed (mc.x (1), 18),
			fixed (mc.x (2), 18), fixed (mc.x (3), 18));
		     call ioa_ ("x4 ^6o^3xx5 ^6o^3xx6 ^6o^3xx7 ^6o", fixed (mc.x (4), 18), fixed (mc.x (5), 18),
			fixed (mc.x (6), 18), fixed (mc.x (7), 18));
		     call ioa_ ("a ^w  q ^w  e ^o", fixed (mc.a, 35), fixed (mc.q, 35), fixed (mc.e, 8));
		     call ioa_ ("Timer reg - ^o, Ring alarm reg - ^1.3b", fixed (mc.regs.t, 27), mc.regs.ralr);
		     if mc.fault_reg ^= "0"b then	/* display fault reg if present */
			call ioa_ ("Fault reg - ^12.3b", mc.fault_reg);
		end;
		call ioa_ ("^/SCU Data:^/");
		call bce_display_scu_ (scup, bce_probe_data.address.wordnum + wordno (scup) - wordno (mcp), "0"b);
		if mc.fault_time then do;		/* print out time of day if available */
		     call date_time_ (fixed (mc.fault_time, 71), time);
		     call ioa_ ("Time stored: ^a (^18.3b)", time, mc.fault_time);
		end;
		call ioa_ ("Ring:^10x^o", fixed (scu.ppr.prr, 3));

		if substr (scu.even_inst, 28, 1) & long then do; /* if bit 27 of instruction on display spl data */
		     call ioa_ ("^/EIS Pointers and Lengths:^/");
		     call ioa_ ("^6x^-^w  ^w  ^w  ^w^/^-^w  ^w  ^w  ^w", mc.eis_info (0),
			mc.eis_info (1), mc.eis_info (2), mc.eis_info (3), mc.eis_info (4), mc.eis_info (5), mc.eis_info (6), mc.eis_info (7));
		end;
		go to request_done;
	     end;
%page;
do_request (name_req /* name_req */): begin;

dcl  segnum			fixed bin (15);	/* segnum supplied */

		call get_string;
		if string_len = 0 then call line_error (Segment_number_missing);
		segnum = cv_integer_string_check_ (string, Base8, code);
		if code ^= 0 then call line_error (Bad_octal_value);
		call check_no_more_args;
		call ioa_ ("^a", bce_segnum_to_name_ (segnum));
		go to request_done;
	     end;
%page;
do_request (proc_req /* proc_req */): begin;

dcl  apte_num			fixed bin;
dcl  1 my_apte			aligned like apte;

		call get_string;
		if string_len = 0 then call line_error (Apte_number_missing);
		apte_num = cv_integer_string_check_ (string, Base10, code);
		if apte_num < 1 | code ^= 0 then call line_error (Bad_decimal_value);
		call check_no_more_args;
		tcmp = addr (tc_data$);
		call bce_appending_simulation$new_segment (segno (tcmp), bce_probe_data.my_seg_info_ptr, code);
		if code ^= 0 then go to bad_apte;
		aptep = addr (my_apte);
		call bce_appending_simulation$get_virtual (bce_probe_data.my_seg_info_ptr, wordno (addr (tcm.apt)) + (apte_num - 1) * size (apte), size (apte), aptep, code);
		if code ^= 0 then go to bad_apte;
		if apte.state = Empty_apte then
bad_apte:		     call line_error (Bad_apte);
		call ioa_ ("dbr = ^24.3b", unspec (apte.dbr));
		call new_dbr (unspec (apte.dbr));
		go to request_done;
	     end;
%page;
do_request (q_req /* q_req */):
	     go to do_request (quit_req /* quit_req */);
%page;
do_request (quit_req /* quit_req */):
	     call check_no_more_args;
	     go to finish;
%page;
do_request (r_req /* r_req */):
	     go to do_request (reset_req /* reset_req */);
%page;
do_request (reset_req /* reset_req */): begin;

dcl  bkpt_num			fixed bin;	/* loop counter */
dcl  instr_ptr			ptr;		/* to instruction to set break at */

		call pass_white;
		instr_ptr = null;
		if line_len > 0 then
		     if substr (line, 1, 1) ^= ";" & substr (line, 1, 1) ^= "
" /* nl */ then do;
			call get_address;
			if bce_probe_data.address.type ^= Virtual then call line_error (Address_type_must_be_virtual);
			instr_ptr = addrel (baseptr (bce_probe_data.address.segnum), bce_probe_data.address.wordnum);
		     end;
		call check_no_more_args;

		if instr_ptr = null then do;
		     if breakpoint_at = null then call line_error (No_current_break);
		     instr_ptr = breakpoint_at;
		     bce_probe_data.address.segnum = segno (instr_ptr);
		     bce_probe_data.address.wordnum = wordno (instr_ptr);
		     bce_probe_data.address.type = Virtual;
		     call bce_appending_simulation$new_segment (bce_probe_data.address.segnum, bce_probe_data.my_seg_info_ptr, code);
		     if code ^= 0 then go to reset_bad_access;
		end;

		sltp = addr (crash_slt$);
		sltep = addr (slt.seg (bce_probe_data.address.segnum));
		if ^slte.breakpointable then call line_error_arg (Segment_not_breakpointable, bce_probe_data.address.error_name);

		bkpt_page_ptr = addr (buffer);
		call bce_appending_simulation$get_virtual (bce_probe_data.my_seg_info_ptr, my_seg_info.size - 1024, 1024, bkpt_page_ptr, code);
		if code ^= 0 then go to reset_bad_access;
		do bkpt_num = 1 to dimension (bkpt_page.bkpts, 1) while (bkpt_page.bkpts (bkpt_num).original_instr_ptr ^= instr_ptr);
		end;
		if bkpt_num > dimension (bkpt_page.bkpts, 1) then call line_error (No_break_set);
		breakpoint_ptr = addr (bkpt_page.bkpts (bkpt_num));
		if instr_ptr = breakpoint_at then do;	/* fix up scu data for breakpoint restart since we will move breakpoint code */
		     scup = addr (breakpoint_page_buffer.mc_.scu);
		     scu.ilc = bit (bin (bce_probe_data.address.wordnum, 18), 18); /* redo instr */
		     call bce_appending_simulation$put_absolute (breakpoint_absadr, size (breakpoint_page_buffer), addr (breakpoint_page_buffer), code);
		     if code ^= 0 then go to reset_bad_access;
		     breakpoint_at = null;
		end;
		call bce_appending_simulation$put_virtual (bce_probe_data.my_seg_info_ptr, bce_probe_data.address.wordnum, 1, addr (breakpoint.original_instr), code);
		if code ^= 0 then go to reset_bad_access;
		unspec (breakpoint) = "0"b;
		call bce_appending_simulation$put_virtual (bce_probe_data.my_seg_info_ptr,
		     my_seg_info.size - 1024 + wordno (breakpoint_ptr) - wordno (bkpt_page_ptr),
		     size (breakpoint), breakpoint_ptr, code);
		if code ^= 0 then
reset_bad_access:	     call line_error_arg_code (code, Accessing_segment, bce_probe_data.address.error_name);
		call ioa_ ("Break reset before ^a.", bce_segptr_to_name_ (instr_ptr));
		go to request_done;
	     end;
%page;
do_request (segno_req /* segno_req */): begin;

dcl  segname			char (32);
dcl  segnum			fixed bin (15);	/* segnum supplied */

		call get_string;
		if string_len = 0 then call line_error (Name_missing);
		segname = string;
		call check_no_more_args;
		call bce_name_to_segnum_ (segname, segnum, code);
		if code ^= 0 then call line_error_arg_code (code, Name, segname);
		call ioa_ ("^o", segnum);
		go to request_done;
	     end;
%page;
do_request (sk_req /* sk_req */):
	     go to do_request (stack_req /* stack_req */);
%page;
do_request (st_req /* st_req */):
	     go to do_request (status_req /* status_req */);
%page;
do_request (stack_req /* stack_req */): begin;

dcl  current_sp			ptr;
dcl  last_sp			ptr;
dcl  prev_sp			ptr;

		call get_address;
		if bce_probe_data.address.type ^= Virtual then call line_error (Address_type_must_be_virtual);
		call check_no_more_args;
		prev_sp = baseptr (bce_probe_data.address.segnum);
		current_sp = ptr (baseptr (bce_probe_data.address.segnum), bce_probe_data.address.wordnum);
		sb, sp = addr (buffer);
		call fetch_ (sb, size (stack_header), -bce_probe_data.address.wordnum, code);
		if code ^= 0 then go to stack_bad_access;
		last_sp = validate_ptr (unspec (stack_header.stack_end_ptr));
		if wordno (current_sp) = 0 then current_sp = validate_ptr (unspec (stack_header.stack_begin_ptr));
		do while ("1"b);
		     if wordno (current_sp) < wordno (prev_sp) + 16 |
			segno (current_sp) ^= segno (last_sp) |
			wordno (current_sp) >= wordno (last_sp) then do;
			call ioa_ ("Bad next stack frame ptr ^p", current_sp);
			go to request_done;
		     end;
		     call fetch_ (sp, size (stack_frame), wordno (current_sp) - bce_probe_data.address.wordnum, code);
		     if code ^= 0 then
stack_bad_access:		call line_error_arg_code (code, Accessing_segment, bce_probe_data.address.error_name);
		     call ioa_ ("frame ptr:  ^p", current_sp);
		     call ioa_ ("arg ptr:    ^p", validate_ptr (unspec (stack_frame.arg_ptr)));
		     call ioa_ ("return ptr: ^a", bce_segptr_to_name_ (validate_ptr (unspec (stack_frame.return_ptr))));
		     call ioa_ ("entry ptr:  ^a^/", bce_segptr_to_name_ (validate_ptr (unspec (stack_frame.entry_ptr))));
		     prev_sp = current_sp;
		     current_sp = validate_ptr (unspec (stack_frame.next_sp));
		end;
		go to request_done;
	     end;
%page;
do_request (status_req /* status_req */): begin;

dcl  any_breaks			bit (1) aligned;
dcl  segnum			fixed bin (15);

		call pass_white;
		segnum = -1;
		call get_string;
		if string_len > 0 then do;
		     segnum = cv_integer_string_check_ (string, Base8, code);
		     if code ^= 0 then do;		/* name? */
			call bce_name_to_segnum_ (string, segnum, code);
			if code ^= 0 then call line_error (Unrecognizable_address);
		     end;
		end;

		call check_no_more_args;

		any_breaks = "0"b;
		if segnum < 0 then do;
		     sltp = addr (crash_slt$);
		     do segnum = slt.first_sup_seg to slt.last_sup_seg, slt.first_init_seg to slt.last_init_seg;
			call status (segnum, "1"b, any_breaks);
		     end;
		end;
		else call status (segnum, "0"b, any_breaks);
		if ^any_breaks then call ioa_ ("No breaks set.");
		go to request_done;
	     end;
%page;
request_done:
	end;
finish:	return;
%page;
check_no_more_args: proc;

/* make sure that only white space follows */

	call pass_white;
	if line_len > 0 then
	     if substr (line, 1, 1) ^= ";" & substr (line, 1, 1) ^= "
" then call line_error (Unexpected_args_follow);
	string_len = 0;				/* don't confuse error messages */
	return;
     end;
%page;
display: proc (p_data_ptr, p_data_bit_lth, p_word_label, mode, data_bits_done, partial);

/* display a buffer in the current mode for the given bit length */

dcl  data_area			bit (4 * 36) aligned; /* area in whcih to place and nicely align data for display */
dcl  data_area_ptr			ptr;		/* ptr to place in data_area to move */
dcl  data_bits_done			fixed bin (24);
dcl  data_in_ascii			(item_num) char (1) unal based (addr (data_area));
dcl  data_in_decimal		(item_num) fixed bin (35) aligned based (addr (data_area));
dcl  data_in_octal			(item_num) bit (36) aligned based (addr (data_area));
dcl  data_in_pointer		(item_num) ptr aligned based (addr (data_area));
dcl  data_bit_lth			fixed bin (24);	/* to display this line */
dcl  data_ptr			ptr;		/* to user area to move and display for this line */
dcl  item_num			fixed bin;	/* how many display items on this line */
dcl  mode				fixed bin parameter;/* display mode */
dcl  p_data_bit_lth			fixed bin (24) parameter; /* total bits to display */
dcl  p_data_ptr			ptr parameter;	/* to user area to move and display */
dcl  p_word_label			fixed bin (26) parameter; /* address label for first word, auto incr, < 0 => no label */
dcl  partial			bit (1) aligned;	/* if we approach the end of data and we can not print a full line or instruction,
						stop and return how much done */
dcl  this_data_lth			fixed bin;	/* data to move for this line */
dcl  user_data			bit (this_data_lth) based (data_ptr); /* data being moved for this line */
dcl  word_label			fixed bin (26);	/* label for this line */

	data_bit_lth = p_data_bit_lth;
	data_bits_done = 0;
	data_ptr = p_data_ptr;
	word_label = p_word_label;
	do while (data_bit_lth > 0);
	     this_data_lth = min (4 * 36, data_bit_lth);
	     data_area = "0"b;
	     if mode = Ascii then data_area_ptr = addbitno (addr (data_area), 8 - mod (this_data_lth - 1, 9));
	     else if mode = Pointer then data_area_ptr = addbitno (addr (data_area), 71 - mod (this_data_lth - 1, 72));
	     else data_area_ptr = addbitno (addr (data_area), 35 - mod (this_data_lth - 1, 36));
	     data_area_ptr -> user_data = user_data;	/* copy user data right aligned into buffer */
	     if mode = Ascii then item_num = divide (this_data_lth + 8, 9, 17);
	     else if mode = Pointer then item_num = divide (this_data_lth + 71, 72, 17);
	     else item_num = divide (this_data_lth + 35, 36, 17);
	     if partial & this_data_lth < 4 * 36 then return; /* stop when we can't be sure all of data is present */
	     if mode = Ascii then call ioa_ ("^[^9o   ^;^s^]^v(^1a^)", word_label >= 0, word_label, item_num, data_in_ascii);
	     else if mode = Decimal then call ioa_ ("^[^9o   ^;^s^]^v(^12d   ^)", word_label >= 0, word_label, item_num, data_in_decimal);
	     else if mode = Octal then call ioa_ ("^[^9o   ^;^s^]^v(^w   ^)", word_label >= 0, word_label, item_num, data_in_octal);
	     else if mode = Pointer then call ioa_ ("^[^9o  ^;^s^]^v(^18p  ^)", word_label >= 0, word_label, item_num, data_in_pointer);
	     else if mode = Instruction then do;
		call bce_display_instruction_ (data_area_ptr, item_num, word_label);
		this_data_lth = item_num * 36;
	     end;
	     data_bit_lth = data_bit_lth - this_data_lth;
	     data_ptr = addbitno (data_ptr, this_data_lth);
	     if word_label >= 0 then word_label = word_label + divide (this_data_lth, 36, 17);
	     data_bits_done = data_bits_done + this_data_lth;
	end;
	return;
     end;
%page;
function: proc (entry_var, num_args);

/* extracts from the line num_args args.   A call is generated to the routine 
supplied with these char strings. */

dcl  arg_index			fixed bin;	/* loop var */
dcl  entry_var			entry variable;	/* routine to call */
dcl  num_args			fixed bin;	/* number of args that we must find */

	arg_list.twice_num_args = num_args * 4;		/* 2 * because its a rule; 2 * for ptr and len for each char str arg */
	call pass_white;
	if line_len = 0 then go to arg_list_missing;
	if substr (line, 1, 1) ^= "(" then
arg_list_missing:
	     call line_error (Function_arg_list_missing);
	do arg_index = 1 to num_args;
	     line_len = line_len - 1;			/* pass ( or , */
	     line_ptr = addcharno (line_ptr, 1);
	     call get_string;
	     if string_len = 0 then go to arg_missing;
	     arg_str_ptrs (arg_index) = string_ptr;
	     arg_str_lens (arg_index) = string_len;
	     call pass_white;
	     if line_len = 0 then go to arg_missing;
	     if arg_index = num_args then
		if substr (line, 1, 1) ^= ")" then call line_error (Improper_arg_list_end_for_function);
		else ;
	     else if substr (line, 1, 1) ^= "," then
arg_missing:
		call line_error (Function_argument_missing);
	end;
	line_len = line_len - 1;			/* pass ) */
	line_ptr = addcharno (line_ptr, 1);

	call cu_$generate_call (entry_var, addr (arg_list));
	return;
     end;
%page;
fetch_: proc (data_ptr, data_lth, address_offset, code);

dcl  address_offset			fixed bin (26) parameter;
dcl  buffer			(1024) bit (36) aligned;
dcl  code				fixed bin (35) parameter;
dcl  data_area			(data_lth) bit (36) aligned based;
dcl  data_lth			fixed bin (18);
dcl  data_ptr			ptr;
dcl  error_table_$boundviol		fixed bin (35) ext static;

	if bce_probe_data.address.type = Absolute then call bce_appending_simulation$get_absolute (bce_probe_data.address.wordnum + address_offset, data_lth, data_ptr, code);
	else if bce_probe_data.address.type = Virtual then call bce_appending_simulation$get_virtual (bce_probe_data.my_seg_info_ptr, bce_probe_data.address.wordnum + address_offset, data_lth, data_ptr, code);
	else if bce_probe_data.address.type = Disk then
	     if bce_probe_data.address.wordnum + address_offset < 0 | bce_probe_data.address.wordnum + address_offset + data_lth > 1024 then code = error_table_$boundviol;
	     else do;
		call read_disk (bce_probe_data.address.pvtx, bce_probe_data.address.record_num, addr (buffer), code);
		data_ptr -> data_area = addrel (addr (buffer), bce_probe_data.address.wordnum + address_offset) -> data_area;
	     end;
	else code = error_table_$bad_arg;
	return;
     end;

%page;
get_address: proc;

/* Find the desired address of an object. */

dcl  component			char (32);
dcl  component_delim_pos		fixed bin;	/* Position of "$". */
dcl  new_segnum			fixed bin (15);
dcl  new_wordnum			fixed bin (26);	/* after incrementing */
dcl  number			fixed bin (35);	/* result of ascii - numeric conversions */
dcl  offset			char (16);
dcl  offset_delim_pos		fixed bin;	/* Position of "|", "+", or "-". */
dcl  seg_id			char (32);

	call get_string;
	if string_len = 0 then call line_error (Address_missing);
	if substr (string, 1, 1) = "." then do;		/* relative address */
	     if bce_probe_data.address.type = 0 then call line_error (No_current_address);
	     if string_len = 1 then go to done;		/* same addr */
	     if bce_probe_data.address.type = Register then
		call line_error (No_offset_may_be_added_to_register_addresses);
	     if string_len < 3 then call line_error (Missing_offset);
	     if substr (string, 2, 1) ^= "+" & substr (string, 2, 1) ^= "-" then call line_error (Dot_must_be_followed_by_plus_or_minus);
	     number = cv_integer_string_check_ (substr (string, 3), Base8, code);
	     if code ^= 0 then call line_error (Bad_octal_value);
	     if substr (string, 2, 1) = "+" then new_wordnum = bce_probe_data.address.wordnum + number;
	     else new_wordnum = bce_probe_data.address.wordnum - number;
	     if new_wordnum < 0 then call line_error (Offset_makes_address_negative);
	     bce_probe_data.address.wordnum = new_wordnum;
	     go to done;
	end;

/* a new address is desired - wipe out old address */

	bce_probe_data.address.type = 0;
	bce_probe_data.address.default_mode = Octal;
	bce_probe_data.address.default_len = 36;

	component_delim_pos = index (string, "$");
	offset_delim_pos = search (string, "|+-");

	if component_delim_pos > 0 | offset_delim_pos > 0 then do; /* Virtual address */
	     if offset_delim_pos < component_delim_pos & offset_delim_pos > 0 then call line_error (Invalid_word_offset);
	     if component_delim_pos > 0 then do;
		if component_delim_pos = 1 then call line_error (Missing_seg_id);
		if offset_delim_pos > 0 then do;
		     if offset_delim_pos = string_len then call line_error (Missing_word_offset);
		     if offset_delim_pos = component_delim_pos + 1 then call line_error (Missing_component);
		     seg_id = substr (string, 1, component_delim_pos - 1);
		     component = substr (string, component_delim_pos + 1, offset_delim_pos - component_delim_pos - 1);
		     offset = substr (string, offset_delim_pos + 1);
		end;
		else do;
		     if component_delim_pos = string_len then call line_error (Missing_component);
		     seg_id = substr (string, 1, component_delim_pos - 1);
		     component = substr (string, component_delim_pos + 1);
		     offset = "0";
		end;
	     end;
	     else do;
		if substr (string, offset_delim_pos, 1) = "+" | substr (string, offset_delim_pos, 1) = "-" then call line_error (Plus_or_minus_allowed_only_with_an_entry_name);
		if offset_delim_pos = string_len then call line_error (Missing_word_offset);
		if offset_delim_pos = 1 then call line_error (Missing_seg_id);
		seg_id = substr (string, 1, offset_delim_pos - 1);
		component = "";
		offset = substr (string, offset_delim_pos + 1);
	     end;
	     if component = "" then bce_probe_data.address.error_name = seg_id;
	     else bce_probe_data.address.error_name = rtrim (seg_id) || "$" || rtrim (component);
	     number = cv_integer_string_check_ (seg_id, Base8, code);
	     if code = 0 then bce_probe_data.address.segnum = number;
	     else do;
		call bce_name_to_segnum_ (seg_id, bce_probe_data.address.segnum, code);
		if code ^= 0 then call line_error_code (code, Segment_name);
	     end;
	     if component ^= "" then do;
		call bce_component_to_wordnum_ (bce_probe_data.address.segnum, seg_id, component, new_segnum, new_wordnum, code);
		if code ^= 0 then call line_error_code (code, Bad_component_name);
		bce_probe_data.address.segnum = new_segnum;
		bce_probe_data.address.wordnum = new_wordnum;
	     end;
	     else bce_probe_data.address.wordnum = 0;
	     number = cv_integer_string_check_ (offset, Base8, code);
	     if code ^= 0 | number < 0 then call line_error (Bad_segment_offset);
	     else do;
		if substr (string, offset_delim_pos, 1) ^= "-" then bce_probe_data.address.wordnum = bce_probe_data.address.wordnum + number;
		else do;
		     if bce_probe_data.address.wordnum - number < 0 then call line_error (Offset_makes_address_negative);
		     else bce_probe_data.address.wordnum = bce_probe_data.address.wordnum - number;
		end;
		bce_probe_data.address.type = Virtual;
	     end;
	     goto done;
	end;


	if string = "reg" | string = "register" then do;
	     call function (reg_address, 1);
	     go to done;
	end;
	if string = "disk" then do;
	     call function (disk_address, 3);
	     go to done;
	end;
	number = cv_integer_string_check_ (string, Base8, code); /* must be just a number */
	if code = 0 then do;
	     bce_probe_data.address.type = Absolute;
	     bce_probe_data.address.wordnum = number;
	     bce_probe_data.address.error_name = string;
	     go to done;
	end;
	else call line_error (Unrecognizable_address);

done:	if bce_probe_data.address.type = Virtual then do;
	     call bce_appending_simulation$new_segment (bce_probe_data.address.segnum, bce_probe_data.my_seg_info_ptr, code);
	     if code ^= 0 then call line_error_code (code, Accessing_segment);
	end;
	return;
%page;
disk_address: proc (disk_name_ptr, disk_name_len, disk_record_str_ptr, disk_record_str_len, disk_offset_str_ptr, disk_offset_str_len);

dcl  disk_name			char (disk_name_len) based (disk_name_ptr);
dcl  disk_name_len			fixed bin;
dcl  disk_name_ptr			ptr;
dcl  disk_offset_str		char (disk_offset_str_len) based (disk_offset_str_ptr);
dcl  disk_offset_str_len		fixed bin;
dcl  disk_offset_str_ptr		ptr;
dcl  disk_record_str		char (disk_record_str_len) based (disk_record_str_ptr);
dcl  disk_record_str_len		fixed bin;
dcl  disk_record_str_ptr		ptr;

	     pvtp = addr (pvt$);
	     pvt_arrayp = addr (pvt.array);
	     call lookup_disk;
	     bce_probe_data.address.error_name = disk_name;
	     bce_probe_data.address.record_num = cv_integer_string_check_ (disk_record_str, Base8, code);
	     if code ^= 0 | bce_probe_data.address.record_num < first_rec_num (pvt_array (bce_probe_data.address.pvtx).device_type) | bce_probe_data.address.record_num > last_sv_rec_num (pvt_array (bce_probe_data.address.pvtx).device_type) then call line_error_arg (Bad_disk_record, disk_record_str);
	     bce_probe_data.address.wordnum = cv_integer_string_check_ (disk_offset_str, Base8, code);
	     if code ^= 0 | bce_probe_data.address.wordnum < 0 then call line_error_arg (Bad_page_offset, disk_offset_str);
	     bce_probe_data.address.type = Disk;
	     return;

lookup_disk:   proc;

/* find the disk in the pvt */

dcl  devname			char (8);

		devname = disk_name;
		call disk_name_pvtx (devname, bce_probe_data.address.pvtx, code);	
		if code ^= 0 then do;
bad_disk_name:
		     call line_error_arg_code (code, No_such_drive, disk_name);
		return;
		end;
	     end;
	end;
%page;
reg_address: proc (reg_name_ptr, reg_name_len);

dcl  reg_index			fixed bin;	/* loop var */
dcl  reg_name			char (reg_name_len) based (reg_name_ptr);
dcl  reg_name_len			fixed bin;
dcl  reg_name_ptr			ptr;

	     if examine_mode = Bce_mode then call line_error (Register_address_not_allowed);
	     bce_probe_data.address.error_name = reg_name;
	     do reg_index = 1 to dimension (reg_names, 1) while (reg_names (reg_index) ^= reg_name);
	     end;
	     if reg_index > dimension (reg_names, 1) then call line_error_arg (Unknown_register, reg_name);
	     bce_probe_data.address.reg_ptr = reg_ptrs (reg_index);
	     bce_probe_data.address.default_mode = reg_modes (reg_index);
	     bce_probe_data.address.default_len = reg_lens (reg_index);
	     bce_probe_data.address.type = Register;
	     return;
	end;
     end;
%page;
get_string: proc;

/* Set string_(ptr len) to indicate the next string of chars */

	call pass_white;
	string_ptr = line_ptr;
	string_len = search (line, "=,""();
 	");					/* ; NL (delimiters) FF SP VT HT (whitespace) */
	if string_len = 0 then string_len = line_len;
	else string_len = string_len - 1;
	line_len = line_len - string_len;
	line_ptr = addcharno (line_ptr, string_len);
	return;
     end;
%page;
get_value: proc;

/* Setup value given the next set of strings */

dcl  ascii_value			char (256) aligned based (addr (value.data));
dcl  decimal_value			fixed bin (35) based (addr (value.data));
dcl  number			fixed bin (35);	/* result of ascii to numeric conversions */
dcl  pointer_value			ptr based (addr (value.data));
dcl  seg_id_len			fixed bin;	/* length of segid portion of virtual pointer */
dcl  segnum			fixed bin (15);	/* for virtual pointer */
dcl  substr_len			fixed bin;	/* portion of ascii string being extracted */

	call pass_white;
	if substr (line, 1, 1) = ";" | substr (line, 1, 1) = "
" /* NL */ then call line_error (Missing_value);
	string_len = 0;				/* don't confuse error routines */
	if substr (line, 1, 1) = """" then do;		/* ascii string */
	     value.type = Ascii;
	     value.length = 0;
	     do while (substr (line, 1, 1) = """");
		line_ptr = addcharno (line_ptr, 1);
		line_len = line_len - 1;
		substr_len = index (line, """");
		if substr_len = 0 then call line_error (Unmatched_quotes);
		if substr (line, substr_len, 2) ^= """""" then do;
		     substr (ascii_value, value.length + 1, substr_len - 1) = substr (line, 1, substr_len - 1);
		     value.length = value.length + (substr_len - 1);
		end;
		else do;
		     substr (ascii_value, value.length + 1, substr_len) = substr (line, 1, substr_len); /* take one " */
		     value.length = value.length + substr_len;
		end;
		line_ptr = addcharno (line_ptr, substr_len);
		line_len = line_len - substr_len;
	     end;
	     substr (ascii_value, value.length + 1) = " ";
	     value.length = divide (value.length + 3, 4, 17) * 36; /* integral num of words */
	     return;
	end;
	call get_string;
	if string_len = 0 then call line_error (Missing_value);
	seg_id_len = index (string, "|");
	if seg_id_len > 0 then do;			/* pointer? */
	     if seg_id_len = 1 then call line_error (Missing_seg_id);
	     segnum = cv_integer_string_check_ (substr (string, 1, seg_id_len - 1), Base8, code);
	     if code ^= 0 then do;			/* segname? */
		call bce_name_to_segnum_ (substr (string, 1, seg_id_len - 1), segnum, code);
		if code ^= 0 then call line_error_code (code, Segment_name);

	     end;
	     if seg_id_len = string_len then call line_error (Missing_word_offset);
	     number = cv_integer_string_check_ (substr (string, seg_id_len + 1), Base8, code);
	     if code ^= 0 | number < 0 | number >= 256 * 1024 then call line_error (Bad_segment_offset);
	     value.type = Pointer;
	     value.length = 72;
	     pointer_value = ptr (baseptr (segnum), number);
	     return;
	end;
	number = cv_integer_string_check_ (string, Base10, code);
	if code = 0 then do;			/* just a number */
	     value.type = Decimal;
	     value.length = 36;
	     decimal_value = number;
	     return;
	end;
	else call line_error (Unrecognizable_value);
     end;
%page;
line_error: proc (message);

/* Report syntax error in line */

dcl  arg				char (*) parameter; /* argument of function to print */
dcl  code				fixed bin (35) parameter;
dcl  int_code			fixed bin (35);	/* internal version of sometimes supplied parameter */
dcl  message			char (*) parameter; /* message text for error message */

	int_code = 0;
	go to error;

line_error_code: entry (code, message);

	int_code = code;
error:
	call com_err_ (int_code, me, "^a^[: ^a^;^s^]", message, string_len > 0, string);
	line_len = 0;				/* abort */
	go to request_done;

line_error_arg: entry (message, arg);

	int_code = 0;
	go to arg_error;

line_error_arg_code: entry (code, message, arg);

	int_code = code;
arg_error:
	call com_err_ (int_code, me, "^a: ^a", message, arg);
	line_len = 0;
	go to request_done;
     end;
%page;
new_dbr: proc (dbr_value);

/* Change the dbr_value for simulation.  Also, set up various segments. */

dcl  dbr_value			bit (72) aligned parameter;

	call bce_appending_simulation$new_dbr (dbr_value, bce_probe_data.last_segnum, code);
	if code = 0 then do;
	     call pc$nullify (get_ptrs_$given_segno (segno (addr (crash_slt$)))); /* free previous contents */
	     call bce_appending_simulation$new_segment (segno (addr (slt$)), bce_probe_data.my_seg_info_ptr, code);
	     if code ^= 0 then call com_err_ (code, me, "no slt");
	     else do;
		call bce_appending_simulation$get_virtual (bce_probe_data.my_seg_info_ptr, 0, (my_seg_info.sdwi.size), addr (crash_slt$), code);
		if code ^= 0 then call com_err_ (code, me, "cannot copy slt");
	     end;

	     call pc$nullify (get_ptrs_$given_segno (segno (addr (crash_name_table$)))); /* free previous contents */
	     call bce_appending_simulation$new_segment (segno (addr (name_table$)), bce_probe_data.my_seg_info_ptr, code);
	     if code ^= 0 then call com_err_ (code, me, "no name_table");
	     else do;
		call bce_appending_simulation$get_virtual (bce_probe_data.my_seg_info_ptr, 0, (my_seg_info.sdwi.size), addr (crash_name_table$), code);
		if code ^= 0 then call com_err_ (code, me, "cannot copy name_table");
	     end;

	     call pc$nullify (get_ptrs_$given_segno (segno (addr (crash_definitions_$)))); /* free previous contents */
	     call bce_appending_simulation$new_segment (segno (addr (definitions_$)), bce_probe_data.my_seg_info_ptr, code);
	     if code ^= 0 then call com_err_ (code, me, "no definitions_");
	     else do;
		call bce_appending_simulation$get_virtual (bce_probe_data.my_seg_info_ptr, 0, (my_seg_info.sdwi.size), addr (crash_definitions_$), code);
		if code ^= 0 then call com_err_ (code, me, "cannot copy definitions_");
	     end;

	     call pc$nullify (get_ptrs_$given_segno (segno (addr (crash_lot$)))); /* free previous contents */
	     call bce_appending_simulation$new_segment (segno (addr (lot$)), bce_probe_data.my_seg_info_ptr, code);
	     if code ^= 0 then call com_err_ (code, me, "no lot");
	     else do;
		call bce_appending_simulation$get_virtual (bce_probe_data.my_seg_info_ptr, 0, (my_seg_info.sdwi.size), addr (crash_lot$), code);
		if code ^= 0 then call com_err_ (code, me, "cannot copy lot");
	     end;
	end;
	else call com_err_ (code, me, "No virtual addresses will be allowed because of error initting appending simulation.");
	bce_probe_data.address.type = 0;		/* no current */
	return;
     end;
%page;
pass_white: proc;

/* pass by whitespace in request line */

dcl  white_len			fixed bin;

	white_len = verify (line, " 	");					/* FF SP VT HT */
	if white_len = 0 then line_len = 0;
	else if white_len > 1 then do;
	     line_len = line_len - (white_len - 1);
	     line_ptr = addcharno (line_ptr, white_len - 1);
	end;
	return;
     end;
%page;
status: proc (segnum, brief, any_breaks);

dcl  any_breaks			bit (1) aligned;
dcl  bkpt_num			fixed bin;
dcl  brief			bit (1) aligned parameter;
dcl  1 packed_ptr			aligned,
       2 bitnum			fixed bin (6) uns unal,
       2 segnum			fixed bin (12) uns unal,
       2 wordnum			fixed bin (18) uns unal;
dcl  segnum			fixed bin (15) parameter;

	sltp = addr (crash_slt$);
	sltep = addr (slt.seg (segnum));
	if ^slte.breakpointable then
	     if brief then return;
	     else call line_error_arg (Segment_not_breakpointable, bce_probe_data.address.error_name);
	call bce_appending_simulation$new_segment (segnum, bce_probe_data.my_seg_info_ptr, code);
	if code ^= 0 then
	     if brief then return;
	     else go to status_bad_access;
	bkpt_page_ptr = addr (buffer);
	call bce_appending_simulation$get_virtual (bce_probe_data.my_seg_info_ptr, my_seg_info.size - 1024, 1024, bkpt_page_ptr, code);
	if code ^= 0 then
	     if brief then return;
	     else
status_bad_access:	call line_error_arg_code (code, Accessing_segment, bce_probe_data.address.error_name);
	do bkpt_num = 1 to dimension (bkpt_page.bkpts, 1);
	     unspec (packed_ptr) = unspec (bkpt_page.bkpts (bkpt_num).original_instr_ptr);
	     if packed_ptr.segnum = segnum & packed_ptr.bitnum = 0 then do;
		any_breaks = "1"b;
		if brief then do;
		     call ioa_ ("Breaks set in ^a.", bce_segnum_to_name_ (segnum));
		     return;
		end;
		else call ioa_ ("Break before ^a.", bce_segptr_to_name_ ((bkpt_page.bkpts (bkpt_num).original_instr_ptr)));
	     end;
	end;
	return;
     end;
%page;
validate_ptr: proc (ptr_bits) returns (ptr);

/* See if dump ptr is good, or make null */

dcl  my_ptr			ptr;
dcl  1 my_ptr_bits			aligned like its based (addr (ptr_bits));
dcl  ptr_bits			bit (72) aligned parameter;

	if my_ptr_bits.its_mod = ITS_MODIFIER & my_ptr_bits.pad1 = "0"b & my_ptr_bits.pad2 = "0"b & my_ptr_bits.mod = "0"b then unspec (my_ptr) = ptr_bits;
	else my_ptr = null;
	return (my_ptr);
     end;
%page; %include apte;
%page; %include bce_appending_seg_info;
%page; %include bce_breakpoint_page;
%page; %include bce_subsystem_info_;
%page; %include collection_1_phases;
%page; %include flagbox;
%page; %include fs_dev_types;
%page; %include hc_lock;
%page; %include its;
%page; %include pvt;
%page; %include pvte;
%page; %include slt;
%page; %include slte;
%page; %include stack_frame;
%page; %include stack_header;
%page; %include state_equs;
%page; %include tcm;
%page; %include toe_hold;
     end;



		    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
