<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">



		    binoct_tv_.alm                  11/04/82  1959.8rew 11/04/82  1633.7        5373



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

"  Transfer vector for binoct in lang_util
"
	entry 	binoct
binoct:	tra	&lt;lang_util_&gt;|[binoct]

	end
���



		    comp_8_to_ascii_.alm            11/04/82  1959.8rew 11/04/82  1633.7       13527



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

"  This procedure returns a character string representing the input
"  bit string as comp-8 format.
"
"	dcl comp_8_to_ascii_ entry (bit (*), char (*));
"	call comp_8_to_ascii_ (bit_string, char_string);
"
"	     bit_string	bit string of comp-8 (INPUT)
"	     char_string	ASCII representation of comp-8 (OUTPUT)
"
	name	comp_8_to_ascii_
	segdef	comp_8_to_ascii_


comp_8_to_ascii_:
	epp2	ap|2,*		pr2 = address of bit string
	epp3	ap|4,*		pr3 = address of character string
	ldx3	0,du		compute address of descriptors
	lxl2	ap|0		  get arg list header word
	canx2	=o4,du		
	tnz	*+2		  no display ptr
	ldx3	2,du		  add 2 word offset if display ptr
	ldq	ap|6,x3*		q = length of bit string
	anq	=o000077777777	  get size portion
	qls	1		  convert bits to digits
	div	9,dl		  length*2/9
	lda	ap|8,x3*		a = length of character string
	ana	=o000077777777	  get size portion of descriptor

	mvt	(pr,rl),(pr,rl),fill(17)
	desc4a	pr2|0,ql
	desc9a	pr3|0,al
	arg	table

	short_return

table:	aci	"0123456789x+x-xx"

	end
�



		    db_assign.pl1                   11/04/82  1959.8rew 11/04/82  1628.2      186984



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


db_assign: proc (il, lin, ill, data_ptr, sntp, db_mc_ptr, old_type, a_cur_size, a_old_size, print_mode, dec_default);

%include db_ext_stat_;

dcl  db_mc_ptr ptr;
dcl  il char (132) aligned,
    (lin, ill) fixed bin,
     print_mode fixed bin,
     data_ptr ptr;

dcl  a_cur_size fixed bin;
dcl  cur_size fixed bin;
dcl  a_old_size fixed bin;
dcl  old_type fixed bin;
dcl  old_size fixed bin;
dcl  new_size fixed bin;
dcl  last_char fixed bin;				/* ill -1 (line ends with new_line) */

dcl
     com_err_ entry options (variable),
     cu_$level_get entry returns (fixed bin),
     db_get_count ext entry (char (132) aligned, fixed bin, fixed bin) returns (fixed bin),
     db_get_count$dec ext entry (char (132) aligned, fixed bin, fixed bin) returns (fixed bin),
     db_regs$get ext entry (ptr, char (4), bit (72), fixed bin),
     db_sym ext entry (char (72) var, ptr, ptr, fixed bin, fixed bin, char (1) aligned,
     char (*) aligned, fixed bin, fixed bin, fixed bin),
     print_text_$format ext entry (ptr, char (*) var),
     hcs_$add_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35)),
     hcs_$delete_acl_entries entry (char (*)aligned, char (*)aligned, ptr, fixed, fixed bin (35)),
     get_group_id_ entry returns (char (32) aligned),
     hcs_$fs_get_mode ext entry (ptr, fixed bin (5), fixed bin (35)),
     ioa_$ioa_stream ext entry options (variable),
     db_parse_arg ext entry (char (132) aligned, fixed bin, fixed bin, ptr, fixed bin, fixed bin);

dcl  fix_bit entry (bit (*) aligned, fixed bin) returns (fixed bin);
dcl  fix_bit$double entry (bit (*) aligned, fixed bin) returns (fixed bin (71));

dcl
     access_ok fixed bin (1),
     base fixed bin,
     code fixed bin,
     code35 fixed bin (35),
     emode fixed bin (5),
     off fixed bin,
     offset fixed bin,
     op fixed bin,
     rb (0:2) fixed bin,
     rep_count fixed bin,
     size fixed bin,
     max_size fixed bin,
     tag fixed bin,
     type fixed bin,
    (i, j, k) fixed bin;
dcl  index_start_no fixed bin;			/* index in il of the beginning of a type 1 no. string */

dcl 1 delete_acl aligned,
    2 access_name char (32),
    2 status_code fixed bin (35);
dcl 1 segment_acl aligned,
    2 access_name char (32),
    2 modes bit (36) init ("111000000000000000000000000000000000"b),
    2 zero_pad bit (36) init ("0"b),
    2 status_code fixed bin (35);

dcl (old_sign, new_sign) fixed bin;

dcl  pad_bits fixed bin;
dcl  off_inc fixed bin;
dcl (old_bit_off, new_bit_off) fixed bin;

dcl  fword fixed bin based;

dcl  flword float bin based;

dcl  two_words bit (72) based;

dcl  words (2) bit (36) aligned based;

dcl  tw_flag fixed bin init (0);

dcl  reg_name char (4);

dcl  len_ptr ptr;

dcl  dp ptr,
     tp ptr,
     tem (17) ptr,
     temp ptr,

     bptr ptr based;
dcl  packed_ptr ptr unal based;

dcl (old_ptr, new_ptr) ptr;
dcl  ones bit (72) int static init ((72)"1"b);

dcl  TOO_BIG fixed bin int static init(1);
dcl  BAD_SYNTAX fixed bin int static init(2);
dcl  MISS_PAREN fixed bin int static init(3);
dcl  BAD_PR fixed bin int static init(4);
dcl  NO_REG fixed bin int static init(5);
dcl  NO_SYM fixed bin int static init(6);
dcl  OPCODE fixed bin int static init(7);
dcl  TAG fixed bin int static init(8);
dcl  SYNTAX fixed bin int static init(9);
dcl  BAD_REP fixed bin int static init(10);
dcl  mess (10) char(40) var int static init (
	"Value too large",				/* TOO_BIG */
	"Bad syntax in instruction input",
	"Missing "")""",
	"Invalid pointer register",
	"Register name missing",
	"Variable not defined",
	"Bad opcode",
	"Bad tag",
	"Syntax error scanning input",
	"Illegal repetition factor");
dcl  sign_bit bit (1) unal based;
dcl  dec_default bit (1) unal;			/* 1 = decimal default
						   0 = octal default ( registers, temporaries ) */

dcl (old_word, new_word) bit (36) aligned;
dcl (old_double, new_double) fixed bin (71);

dcl  control char (8) aligned;			/* variable ioa_ control string */

dcl  mode char (1) aligned,
     old_str char (old_size) based (dp),
     str char (size) based (tp),
     repstr char (size*rep_count) based,
     old_bits bit (old_size) based (dp),
     new_bits bit (size) based (tp),
     chars (0:10000) char (1) unal based,
     bitarr (0:10000) bit (1) unal based,
     sym_name char (72) aligned,
     opcode6 char (6) aligned,
     c2 char (2) aligned,
     c4 char (4) aligned,
    (name1, name2) char (72) var,
     db_sym_name char (72) var,
    (type_char, mode_char) char (1) aligned;

/*	The following declaration is included(temporarily) to allow
   *	the use of the old-style names of the pointer registers.
*/

dcl  old_pr_names (0:7) char (2) int static init
    ("ap", "ab", "bp", "bb", "lp", "lb", "sp", "sb");

dcl  conversion condition;
dcl  underflow condition;


dcl  ffdouble fixed bin (71) based;			/* used for printing double words in ^d */
dcl 1 ff aligned based,
    2 (w0, w1, w2, w3, w4, w5, w6, w7) fixed bin;

dcl (addr, addrel, bit, char, fixed, index, max, min, mod, null, substr, unspec, rel) builtin;
dcl (abs, binary, divide, search, verify) builtin;
						/*  */
%include db_snt;
/*  */
%include db_inst;
/*  */
%include its;
/*  */


dcl 1 op_mnemonic_$op_mnemonic (0:1023) ext static aligned,
    2 opcode char (6) unal,
    2 dtype fixed bin (2) unal,			/* 0 - desc9a, 1 - descb, 2 - decimal */

    2 num_desc fixed bin (5) unal,
    2 num_words fixed bin (8) unal;

%include db_data_map;
/*  */

	temp = addr (tem);				/* get pointer to temporary storage */
	dp = data_ptr;				/* get pointer to first word to change */
	cur_size = a_cur_size;
	old_size = a_old_size;


/*  If the user does not have w access on the segment, try to add w user.proj.tag  */

	call hcs_$fs_get_mode (dp, emode, code35);	/* see if the user has write permit on the segment */
	if code35 = 0 then do;
	     if bit (emode, 5) &amp; "00010"b then access_ok = 1; /* if write permit is there, OK */
	     else do;
		access_ok = 0;			/* hasn't got write permit, change the access */
		segment_acl.access_name = get_group_id_ ();
		call hcs_$add_acl_entries (snt.dir_name, snt.ent_name, addr (segment_acl), 1, code35);
	     end;
	end;
	if code35 ^= 0 then do;			/* Can't get write access on segment */
	     call com_err_ (code35, "debug", "Cannot change ^p", dp);
	     return;
	end;

	if print_mode ^= 0 then
	     call ioa_$ioa_stream (debug_output, "Changing ^p", dp); /* print out location changings */

	last_char = ill -1;
	do while (get_char (lin));

	     rep_count = 1;

	     if mode = "(" then call get_rep_count (rep_count);
	     if mode = "(" then call get_instruction;	/* instruction format  (opcode) */
	     else if mode = "$" then do;		/* register being used as value */
		dec_default = "0"b;
		i = search (substr (il, lin, ill-lin+1), " ;");
		if i = 0 then i = ill;
		else i = lin + i -1;
		if i-lin-1 &lt; 1 then call error (NO_REG, "");
		sym_name = substr (il, lin+1, i-lin-1); /* copy register name into temporary */
		lin = i;
		reg_name = substr (sym_name, 1, 4);
		type = 1;
		size = 36;
		call db_regs$get (db_mc_ptr, reg_name, temp -&gt; two_words, print_mode);
		if reg_name = "aq" then size = 72;
		do i = 0 to 7;
		     if reg_name = db_data$names (i) then do;
			size = 72;
			type = 13;
		     end;
		end;
		if size ^= 72 then tp = addrel (temp, 1);
		else tp = temp;

		call store_value;

	     end;

	     else do;				/* call db_parse_arg to pick off the other types */
		index_start_no = lin;		/* patch for octal default */
		type = 0;
		if ^dec_default then do;
		     temp -&gt; fword = db_get_count (il, lin, i);
		     if i &gt; lin then if index (", ;
", substr (il, i, 1)) ^= 0 then do;
			     type = 1;
			     lin = i;
			end;
		end;

		if type = 0 then call db_parse_arg (il, lin, ill, temp, type, size); /* scan for next item */
		tp = temp;

		if type = -1 then goto reset;		/* goto reset if ";", etc. */

		if type = 1 | type = 3 then size = 36;	/* arithmetic type s go in fullword */
		if type = 13 then size = 72;		/* pointer on double-word */

		if type = 0 then do;		/* a variable as input parameter */
		     db_sym_name = str;		/* copy variable name into temporary */
		     call db_sym (db_sym_name, sntp, tp, offset, type, type_char, mode_char, size, max_size, code);
		     if code ^= 0 then call error (NO_SYM, (name1));
		end;

		call store_value;

	     end;
	end;

reset:
	if access_ok = 0 then call hcs_$delete_acl_entries (snt.dir_name, snt.ent_name, addr (segment_acl), 1, code35);
	return;


/*  */
bump:	proc;

/*	This internal procedure is used to bump the data pointer
   *	to the next item after the one just assigned to.
*/

	     off_inc = divide (old_size, 36, 17, 0);
	     old_bit_off = fixed  (addr (dp) -&gt; its.bit_offset, 6);

	     new_bit_off = old_bit_off + mod (old_size, 36);
	     if new_bit_off &gt; 36 then do;		/* into next word */
		new_bit_off = new_bit_off - 36;
		off_inc = off_inc + 1;		/* must bump word offset */
	     end;

	     dp = addrel (dp, off_inc);		/* this will set bit offset */
						/* to zero, so we may have  */
	     if new_bit_off ^= 0 then			/* to set it again */
		addr (dp) -&gt; its.bit_offset = bit (fixed (new_bit_off, 6), 6);

	     rep_count = rep_count - 1;
	     return;
	end bump;





/*  This procedure is an error exit from db_assign.  It prints an error message and goes to reset. */

error:	proc (mess_code, illegal_string);

dcl  mess_code fixed bin;				/* error codes for db_assign */
dcl  illegal_string char (*) aligned;			/* offending character or string */

	     call ioa_$ioa_stream (debug_output, "^a  ^a", mess (mess_code), illegal_string);
	     goto reset;

	end error;



/*  This procedure looks for a non_blank character and sets mode to it.  If mode is ";" or there
    are no more characters left in the line, then get_char returns "0"b.  Otherwise
   it returns "1"b (for found next character).
*/

get_char:	proc (index) returns (bit (1));

dcl  index fixed bin;
dcl  i fixed;

	     lin = index;
	     if lin &lt;= last_char then do;
		i = verify (substr (il, lin, last_char - lin + 1), " ");
		if i &gt; 0 then do;
		     lin = lin + i -1;
		     mode = substr (il, lin, 1);
		     if mode ^= ";" then return ("1"b);
		end;
		else lin = last_char + 1;
	     end;

	     return ("0"b);

	end get_char;

	

/*  This procedure attempts to parse an instruction of the form:

	( opcode base|offset,tag )

*/

get_instruction: proc;

	     if ^get_char (lin + 1) then call error (MISS_PAREN,  "");
	     j = search (substr (il, lin, last_char - lin + 1), " )"); /* blank or ) follows opcode */
	     if j = 0 then call error (MISS_PAREN,  "");
	     opcode6 = substr (il, lin, j -1);		/* copy opcode name */
	     lin = lin + j -1;
	     op = -1;
	     do i = 0 to 1023 while (op = -1);		/* search for the opcode */
		if opcode6 = op_mnemonic_$op_mnemonic (i).opcode then op = i;
	     end;
	     if op = -1 then call error (OPCODE, opcode6);

	     if ^get_char (lin) then call error (SYNTAX, "");
	     base = -1;				/* -1 indicates no pr specified */

	     if substr (il, lin+3, 1) = "|" then do;	/* standard pointer register prN|NN */
		if substr (il, lin, 2) ^= "pr" then call error (BAD_PR, "");
		lin = lin + 2;
		base = index ("01234567", substr (il, lin, 1)) -1;
		if base = -1 then call error (BAD_PR, "");
		lin = lin + 2;
	     end;

	     else if substr (il, lin+2, 1) = "|" then do; /*  old-style pointer pp|NN */
		c2 = substr (il, lin, 2);		/* copy it for compare */
		lin = lin + 3;			/* increment index */
		base = -1;
		do i = 0 to 7 while (base = -1);	/* search for the base name */
		     if c2 = old_pr_names (i) then base = i;
		end;
		if base = -1 then call error (BAD_PR, "");
	     end;

	     j = lin;				/* check for number */
	     off = db_get_count (il, lin, lin);		/* pick up the offset specified by the user */
	     if j = lin then if substr (il, lin, 1) = ")" then off = 0; /* not a number */
		else call error (SYNTAX, "");
	     tag = 0;				/* indicates tag not yet specified */
	     if substr (il, lin, 1) = "," then do;	/* a tag was specified */
		j = index (substr (il, lin+1, 4), ")"); /* find location of the ")" */
		if j = 0 then call error (MISS_PAREN,  "");	/* error condition */
		c4 = substr (il, lin, j);		/* pick up the tag field */
		lin = lin+j+1;			/* skip over rest of instruction input */

		tag = -1;
		do i = 0 to 63 while (tag = -1);
		     if db_data$tags (i) = c4 then tag = i;
		end;
		if tag = -1 then call error (TAG, c4);
	     end;
	     else do;
		if ^get_char (lin) then call error (MISS_PAREN, "");
		if mode ^= ")" then call error (SYNTAX, "");
		lin = lin + 1;
	     end;

	     do rep_count = rep_count to 1 by -1;
		if print_mode ^= 0 then
		     call print_text_$format (dp, name1);
		k = dp -&gt; ff.w0;			/* save the old value */
		if base = -1 then do;		/* a base was never spec ified */
		     dp -&gt; instr.offset = off;	/* copy full offset into instruction */
		     dp -&gt; instr.pr_bit = "0"b;	/* make sure don't use base */
		end;
		else do;
		     dp -&gt; instr_pr.pr = bit (fixed (base, 3)); /* copy base into instruction */
		     dp -&gt; instr_pr.offset = off;	/* copy offset */
		     dp -&gt; instr.pr_bit = "1"b;	/* turn on bit 29 */
		end;
		dp -&gt; instr.opcode = bit (fixed (op, 10)); /* fill in opcode */
		dp -&gt; instr.tag = bit (fixed (tag, 6)); /* fill in tag */
		dp -&gt; instr.inhibit = "0"b;
		i = dp -&gt; ff.w0;			/* get new value */
		if print_mode ^= 0 then do;
		     call print_text_$format (dp, name2);
		     call ioa_$ioa_stream (debug_output, "^a^/to^/^a", name1, name2);
		end;
		dp = addrel (dp, 1);
	     end;

	     return;

	end get_instruction;





/*  This procedure has a value and stores it at the location given with dp.  Rep_count  is the number of
    times to repeat a given value.
*/

store_value: proc;

	     len_ptr = null;
	     if old_type = 0 then cur_size, old_size = size;
	     else if cur_size &lt; old_size then len_ptr = addrel (dp, -1);
	     if type &lt;= 4 then do;

						/* for arithmetic values, if not a variable specified on left, just fill in rest of word */
		if old_type = 0 then old_size = 36 - fixed (addr (dp) -&gt; its.bit_offset, 6);
	     end;

	     if type = 21 then do;			/* character string */
		if old_type ^= 21 &amp; old_type ^= 0 then do;
		     old_size = divide (old_size, 9, 17, 0); /* convert size from bits to chars */
		     cur_size = divide (cur_size, 9, 17, 0);
		end;
		if old_size &lt;= 0 then call error (TOO_BIG, "");
		size = min (old_size, size);
		new_size = rep_count*size;
		if print_mode ^= 0 then do;
		     if rep_count &gt; 1 then call ioa_$ioa_stream (debug_output, """^a"" to (^d)""^a""", substr (dp -&gt; repstr, 1, new_size), rep_count, str);
		     else call ioa_$ioa_stream (debug_output, """^a"" to ""^a""", substr (dp -&gt; old_str, 1, cur_size), str);
		end;
		do rep_count = rep_count to 1 by -1;
		     old_str = str;
		     dp = addr (dp -&gt; chars (size));
		end;
		if len_ptr ^= null then do;		/* if a varying string, update length */
		     len_ptr -&gt; fword = min (new_size, old_size);
		     cur_size = old_size;		/* so we won't do it again */
		end;
		rep_count = 1;
	     end;

	     else if type = 19 then do;		/* bit string */
		if old_type = 21 then do;		/* if char string, convert size to bits */
		     old_size = 9*old_size;
		     cur_size = 9*cur_size;
		end;
		size = min (old_size, size);		/* bit string */
		new_size = rep_count*size;

		do rep_count = rep_count to 1 by -1;
		     if print_mode ^= 0 then
			call ioa_$ioa_stream (debug_output, """^a""b to ""^a""b", char (substr (dp -&gt; old_bits, 1, cur_size)),
			char (tp -&gt; new_bits));
		     dp -&gt; old_bits = new_bits;
		     dp = addr (dp -&gt; bitarr (size));
		end;
		if len_ptr ^= null then do;
		     len_ptr -&gt; fword = min (new_size, old_size);
		     cur_size = old_size;
		end;
	     end;

	     else if type = 13 then do while (rep_count &gt; 0); /* pointer */
		if old_type = 0 then dp = addrel (dp, 0); /* eliminate bit offset if not var. */
		if old_size &lt; 36 then call error (TOO_BIG, "");
		if old_size &lt; 72 then do;		/* into packed ptr */
		     unspec (old_ptr) = unspec (dp -&gt; packed_ptr);
		     if size = 36 then
			unspec (new_ptr), unspec (dp -&gt; packed_ptr) = unspec (tp -&gt; packed_ptr);
		     else unspec (new_ptr), unspec (dp -&gt; packed_ptr) = unspec (tp -&gt; bptr);
		end;
		else do;
		     unspec (old_ptr) = unspec (dp -&gt; bptr);
		     if size = 36 then
			unspec (new_ptr), unspec (dp -&gt; bptr) = unspec (tp -&gt; packed_ptr);
		     else unspec (new_ptr), unspec (dp -&gt; bptr) = unspec (tp -&gt; bptr);
		end;

		if print_mode ^= 0 then
		     call ioa_$ioa_stream (debug_output, "^p to ^p", old_ptr, new_ptr);
		call bump;
	     end;

	     else if type = 14 then do while (rep_count &gt; 0); /* offset variable */
		if old_size &lt; 36 then call error (TOO_BIG, "");
		if print_mode ^= 0 then do;
		     old_word = old_bits;
		     new_word = new_bits;
		     call ioa_$ioa_stream (debug_output, "^w to ^w", old_word, new_word);
		end;

		old_bits = new_bits;
		call bump;
	     end;


	     else if type = 1 | type = 2 then do;	/* fixed bin */
		if ^dec_default then do;
		     if substr (il, index_start_no, 2) = "&amp;d" then control = "^d to ^d";
		     else if old_size = 36 then control = "^w to ^w";
		     else control = "^o to ^o";
		end;
		else do;				/* decimal default assumed unles &amp;o was used */
		     if substr (il, index_start_no, 2) = "&amp;o" then control = "^o to ^o";
		     else control = "^d to ^d";
		end;
		do while (rep_count &gt; 0);
		     if abs (fix_bit$double ((new_bits), size)) &gt;= binary (2)** (old_size) then call error (TOO_BIG, "");
		     if dp -&gt; sign_bit then old_sign = -1;
		     else old_sign = 1;

		     if tp -&gt; sign_bit then new_sign = -1;
		     else new_sign = 1;

		     if print_mode ^= 0 then do;
			if old_size &lt;= 36 then do;
			     old_word = old_bits;
			     new_word = new_bits;
			     call ioa_$ioa_stream (debug_output, control, fix_bit (old_word, old_size),
				fix_bit (new_word, size));
			end;

			else do;
			     old_double = fix_bit$double ((old_bits), old_size);
			     new_double = fix_bit$double ((new_bits), size);
			     if dec_default then call ioa_$ioa_stream (debug_output, control,
				addr (old_double) -&gt; ffdouble, addr (new_double) -&gt; ffdouble);
			     else call ioa_$ioa_stream (debug_output, "^w^w to ^w^w", addr (old_double) -&gt; ff.w0,
				addr (old_double) -&gt; ff.w1,
				addr (new_double) -&gt; ff.w0, addr (new_double) -&gt; ff.w1);
			end;
		     end;

		     if size &gt;= old_size then
			old_bits = substr (new_bits, size-old_size+1);
		     else do;
			pad_bits = old_size - size;
			if new_sign &lt; 0 then substr (old_bits, 1, pad_bits) = ones;
			else substr (old_bits, 1, pad_bits) = "0"b;

			substr (old_bits, pad_bits+1) = new_bits;
		     end;

		     call bump;
		end;
	     end;

	     else if type = 3 | type = 4 then do;
		do while (rep_count &gt; 0);
		     if old_size &lt; 9 then call error (TOO_BIG, "");

		     if print_mode ^= 0 then do;
			on underflow begin;		/* maybe some value wasn't really */
						/* floating, so print it out octal */
			     call ioa_$ioa_stream (debug_output, "^w to ^w", dp -&gt; fword, tp -&gt; fword);
			     goto rev_under;
			end;

			call ioa_$ioa_stream (debug_output, "^12.4f to ^12.4f", addr (old_bits) -&gt; flword,
			     addr (new_bits) -&gt; flword);
rev_under:		revert underflow;
		     end;

		     old_bits = substr (new_bits, 1, min (old_size, size));
		     call bump;
		end;
	     end;


	     else call error (SYNTAX, "");
	     return;


	end store_value;

	

/*  This procedure attempts to get a repetition count.  It assumes a format:

	[blank(s)]  [decimal digit(s)]  [blank(s)]

    If the string is not a repetion count, lin and mode are restored.  The main procedure  will then
    try to parse an instruction
*/

get_rep_count: proc (rep);

dcl  rep fixed bin;

	     rep = 1;
	     i = lin;				/* save in  case this is not repetition */
	     if get_char (lin + 1) then do;
		k = lin;
		j = db_get_count$dec (il, lin, lin);

		if lin = k then do;
		     lin = i;
		     mode = "(";
		     return;
		end;

		if get_char (lin) then if mode = ")" then do;
			if j &lt; 1 then call error (BAD_REP, "");
			if ^get_char (lin + 1) then call error (SYNTAX, "");
			rep = j;
			return;
		     end;
	     end;

	     call error (MISS_PAREN,  "");

	end get_rep_count;

     end db_assign;




		    db_break.pl1                    11/04/82  1959.8rew 11/04/82  1628.3      383508



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


db_break: proc;

/*	This procedure is part of the  debug package.   All of the mechanism required to
   *  handle break points is contained in this procedure.   This procedure alone,
   *  maintains the user's  break segment  found in his home directory.   This
   *  procedure, along with  db_break_map,  maintains the  break map  needed in each
   *  segment which has breaks.  Note, what this procedure does NOT know about
   *  is the semantics of the debug language.
   *  Rewritten  Dec 72  for the  6180  by  Bill Silver.
   *
   *  db_break  has the following entry points:
   *
   *  check_break:	Returns info about a break, especially whether or not a
   *  		condition has been met.
   *
   *  global:		Performs a specified action on all the breaks known to the
   *  		user in all segments.
   *
   *  print_bseg:	Prints the number of breaks in all the segments which the user
   *  		has breaks.  Cleans up this break segment.
   *
   *  print_default:	Prints the path name of the current default segment.
   *
   *  restart:		Restarts a break - executes the instruction replaced by
   *  		the  mme2.
   *
   *  set_break:	Sets up a break.
   *
   *  set_default:	Establishes a segment as the default segment.
   *
   *  set_skips:	Sets a number of skips in a specified break.
   *
   *  single:		Performs a specified action on  ONE  specified break.
   *
   *  sub_global:	Performs a specified action on all the breaks in the
   *  		default segment.
*/


/*		PARAMETER  DATA		*/

dcl  arg_action_code fixed bin,			/* (INPUT)  Implies action to perform on break.
						   *  A_C_T_I_O_N_		C_O_D_E_
						   *  list		  1
						   *  reset		  2
						   *  disable	  3
						   *  enable		  4
						   *  set command	  5
						   *  set condition	  6  */
     arg_break_num fixed bin,				/* (INPUT)  The number of a break in the
						   *  default segment.  */
     arg_break_ptr ptr,				/* (INPUT)  A pointer to the word where
						   *  the break will be set.  */
     arg_cond_flag fixed bin,				/* (OUTPUT) A flag indicating whether or not the
						   *  condition of a conditional break has been met.
						   *  0  =&gt;  No condition  or  condition not met.
						   *  1  =&gt;  Condition not met - skip break.  */

     arg_comd_len fixed bin,				/* (OUTPUT) The length of the command line
						   *  found in a break.  0 =&gt; no command.  */
     arg_comd_ptr ptr,				/* (OUTPUT) A pointer to the command line
						   *  found in a break.  */
     arg_line char (236),				/* (INPUT)  A string that can be either a
						   *  command line or condition data.  */
     arg_line_len fixed bin,				/* (INPUT)  The length of the above string.  */
     arg_line_no fixed bin,				/* (OUTPUT) Source line number. */
     arg_num_skips fixed bin,				/* (INPUT/OUTPUT) The number of  skips
						   *  ( to set/that are set )  in a break.  */
     arg_print_mode fixed bin,			/* (INPUT)  0 =&gt; SHORT, 1 =&gt; LONG. */
     arg_scu_ptr ptr,				/* (INPUT)  Points to the  SCU  data
						   *  generated by a  mme2 fault.  */
     arg_seg_ptr ptr,				/* (INPUT)  Pointer to a segment that is
						   *  to become the default segment.  */
     arg_snt_ptr ptr,				/* (INPUT)  Pointer to debug's arg_snt data.  */
     arg_type fixed bin;				/* (INPUT)  The type of break.
						   *  0 =&gt; regular,
						   *  1 =&gt; temporary,
						   *  2 =&gt; disabled.  */


/*		INTERNAL  STATIC  DATA	*/

/*	Note, since the following variables must be preserved from one call to another
   *  they are static.  Any procedures which need this information therefore must be
   *  part of db_break or called by  db_break.  */


/*	Pointer to the user's  break segment.  */

dcl  break_seg_ptr ptr internal static init (null);



/*	The following variables are used to define the  default segment.
   *  def_seg  is the number of the break segment array entry which corresponds
   *  to the default segment.    def_break_map_ptr  points to the break map in
   *  the default segment.
*/
dcl  def_segx fixed bin internal static init (0),
     def_break_map_ptr ptr internal static;

/*	Below is the  mme2  instruction that is put into a break word.  */

dcl 1 mme2 aligned internal static,
    2 break_num fixed bin (17) unaligned,
    2 op_code bit (36) unaligned init ("000000100000000000"b);

/*	An array used to print the type of a break.  */

dcl  break_type_name (0:3) char (24) internal static aligned
     init ("Break          ", "Temporary break", "Disabled  break",
     "Temporary disabled break");


%include db_ext_stat_;

/*		AUTOMATIC  DATA		*/

dcl  action_code fixed bin,				/* These variables are used to copy arguments. */
     break_num fixed bin,
     break_ptr ptr,
     line_len fixed bin,
     print_mode fixed bin,
     snt_ptr ptr,
     type fixed bin;

dcl  break_word_ptr ptr,				/* Pointer to the word where the break is. */
     break_offset fixed bin (18);			/* Word offset of the break word. */

dcl  dir_name char (168),				/* Directory name of a segment. */
     ent_name char (32);				/* Entry name of a segment. */

/*	This is the array of data returned by the calls to  hcs_$status_long.  */

dcl 1 branch aligned,
    (2 type bit (2),
    2 nnames bit (16),
    2 nrp bit (18),
    2 dtm bit (36),
    2 dtu bit (36),
    2 mode bit (5),
    2 padding bit (13),
    2 records bit (18),
    2 dtd bit (36),
    2 dtem bit (36),
    2 acct bit (36),
    2 curlen bit (12),
    2 bitcnt bit (24),
    2 did bit (4),
    2 mdid bit (4),
    2 copysw bit (1),
    2 pad2 bit (9),
    2 rbs (0:2) bit (6),
    2 uid bit (36)) unaligned;

dcl  action_flag bit (1),				/* Used to denote if an action has been
						   *  performed for any breaks.  */
     cond_flag fixed bin,				/* Used to determine condition state. */
     delete_seg_entry_flag bit (1),			/* Denotes whether a segment entry in the break
						   *  segment array has been deleted. */
     inst_ptr ptr,					/* Pointer to instruction after break. */
     new_bnum fixed bin,				/* Temporary break number. */
     seg_ptr ptr,					/* Temporary segment pointer. */
     segx fixed bin;				/* Index into break segment array. */

dcl  print_num_breaks char (6),			/* A word string for printing, */
     source_string char (72) var;			/* Used to get  info back from other procs. */

dcl  bit_count fixed bin (24),			/* Returned from  hcs_$initiate count. */
     code fixed bin (35),				/* Error return code. */
    (i, j) fixed bin;				/* Work variables. */


/*		BASED  DATA		*/

/*	This is a map of the user's  break segment.  */

dcl 1 bseg based (break_seg_ptr) aligned,
    2 num_segs fixed bin,				/* Number of segments in seg array. */
    2 seg (1),					/* Array of segment entries.  Each entry
						   *  corresponds to one segment which should
						   *  have a break map.  */
      3 uid bit (36),				/* UID of segment.  This field remains
						   *  constant for the life of the entry.  */
      3 dir_name char (168) unal,			/* Directory name of segment. */
      3 ent_name char (32) unal;			/* Entry name of the segment.  Note, these
						   *  two fields may change since the segment
						   *  may be moved, renamed, or referenced
						   *  via a link.  */

/*	This is an overlay  of the  break segment  used to move whole entries around.  */

dcl 1 bseg_map based (break_seg_ptr) aligned,
    2 num_segs fixed bin,
    2 array (1),
      3 entry char (204);


/*	This is a map of the  mme2  word that is moved into the break word.  */

dcl 1 mme2_map based aligned,
    2 break_num fixed bin (17) unaligned,
    2 op_code bit (18) unaligned;

/*	This is used to reference one word.  */

dcl  based_word bit (36) based aligned;


/*		EXTERNAL  ENTRIES		*/

dcl (addr, addrel, divide, fixed, index, max, null, ptr, rel, size, substr) builtin;

dcl  com_err_ external entry options (variable),
     db_break_map$check external entry (ptr, fixed bin (24), ptr),
     db_break_map$delete external entry (ptr),
     db_break_map$get_slots external entry (ptr),
     db_break_map$init external entry (ptr, fixed bin (24), ptr),
     db_line_no external entry (ptr, fixed bin (18),
     fixed bin, fixed bin, fixed bin),
     db_parse_condition$check external entry (ptr, ptr, ptr, fixed bin),
     db_parse_condition$print_line external entry (ptr, char (72) var),
     hcs_$fs_get_path_name external entry (ptr, char (*), fixed bin, char (*), fixed bin (35)),
     hcs_$initiate_count external entry (char (*), char (*), char (*), fixed bin (24),
     fixed bin (2), ptr, fixed bin (35)),
     hcs_$make_seg external entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)),
     hcs_$set_bc_seg external entry (ptr, fixed bin (24), fixed bin (35)),
     hcs_$status_long external entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)),
     hcs_$truncate_seg external entry (ptr, fixed bin (18), fixed bin (35)),
     ioa_$ioa_stream external entry options (variable),
     ioa_$rsnnl external entry options (variable),
     user_info_ external entry (char (*)),
     print_text_$real_offset external entry (ptr, char (*) var, fixed bin (18)),
     user_info_$homedir external entry (char (*));
						/* 	*/
%include db_break_map_map;
/* 	*/
dcl 1 op_mnemonic_$op_mnemonic (0:1023) ext static aligned,

    2 opcode char (6) unal,
    2 dtype fixed bin (2) unal,
    2 num_desc fixed bin (5) unal,
    2 num_words fixed bin (8) unal;

/* 	*/
%include db_inst;
/* 	*/
%include mc;
/* 	*/
print_bseg: entry (arg_print_mode);


/*	This entry is called to print the contents of the users break segment.  It will
   *  print the number of breaks that are set for each segment referenced in the break
   *  segment.   It will also clean up the break segment.  This involves deleting any
   *  entries which are no longer valid  or  whose segments have no breaks set.
*/

	print_mode = arg_print_mode;			/* Copy argument. */

	if break_seg_ptr = null ()			/* Make sure we have a break segment.  */
	then call INIT_BREAK_SEG;

	do segx = 1 to bseg.num_segs;			/* Process each entry in break segment. */
	     call CHECK_SEGMENT;			/* This will return the segment's break
						   *  map pointer if the segment entry was  OK
						   *  and wasn't deleted.  */

/*	Was the segment entry deleted.  If so, segx  now refers to the last segment entry.
   *  It just replaced the one we were working on.  Thus segx  must be decremented
   *  so it can reference this same entry again on the next iteration.   However,
   *  if this is the last entry in the array, we must not decrement segx because we want
   *  to get out of the loop since  bseg.num_segs was also decremented when the
   *  segment entry was deleted.
*/
	     if delete_seg_entry_flag			/* Was segment entry deleted?  */
	     then do;				/* YES, thus there were no breaks.  */
		if segx &lt;= bseg.num_segs		/* But is it last entry. */
		then segx = segx -1;		/* NO, decrement segment index.  */
		else;				/* YES, lets get out of the loop.  */
	     end;
	     else do;				/* No, there are breaks. */
		if bmap.num_set = 1
		then print_num_breaks = "break ";
		else print_num_breaks = "breaks";
		call ioa_$ioa_stream (debug_output, "^d  ^a  set in  ^a&gt;^a", bmap.num_set, print_num_breaks,
		     bseg.seg (segx).dir_name, bseg.seg (segx).ent_name);
	     end;
	end;					/* We have just processed one segment entry.  */

/*	The only segment entries left in the break segment array will be those of segments
   *  which have breaks set.  If there are no entries left, then there were no breaks set.
*/
	if bseg.num_segs = 0
	then call ioa_$ioa_stream (debug_output, "No breaks set.");

	return;
						/* 	*/
set_default: entry (arg_seg_ptr);


/*	This entry will establish the specified segment as the default segment.  */

	break_ptr = arg_seg_ptr;			/* Not really a break pointer. */
	call SET_DEFAULTS;

	return;






print_default: entry;


/*	This entry is called to print the name of the default segment.
*/

	break_num = 1;				/* Set dummy break number. */
	call CHECK_DEFAULT;

	call ioa_$ioa_stream (debug_output, "Default segment is  ^a&gt;^a",
	     bseg.seg (segx).dir_name, bseg.seg (segx).ent_name);

	return;
						/* 	*/
check_break: entry (arg_break_ptr, arg_break_num, arg_snt_ptr, arg_cond_flag, arg_num_skips,
	     arg_comd_len, arg_comd_ptr, arg_line_no);


/*	This entry returns data about the specified break.  Especially important is the
   *  condition flag which tells whether or not a conditional break has been satisfied
   *  0  =&gt; either this is not a conditional break or condition has been satisfied,
   *  1  =&gt; conditional break and condition has not been satisfied.
*/

	break_ptr = arg_break_ptr;			/* Copy arguments. */
	break_num = arg_break_num;
	snt_ptr = arg_snt_ptr;

	call SET_DEFAULTS;				/* Establish this segment as the default segment. */

	call CHECK_BREAK_NUM;			/* Validate the break number. */

/*	Now set the condition flag.  If the length of the condition data is zero, then we
   *  know that this is not a conditional break and we can set the condition flag to
   *  zero.  If this is a conditional break, then we must call out to a procedure that
   *  understands the condition data semantics so it can determaine if the condition
   *  has been met.
*/
	arg_num_skips = break_slot.skip_count;		/* no. of times to skip this break */

	if arg_num_skips &gt; 0
	then do;
	     cond_flag = 0;				/* Ignore condition because break will be skiped */
	     break_slot.skip_count = break_slot.skip_count - 1;
	end;

	else if break_slot.cond_len = 0		/* Is this a conditional break? */
	then cond_flag = 0;				/* NO. */
	else call db_parse_condition$check (break_map_ptr, addr (break_slot.cond_data),
	     snt_ptr, cond_flag);

	arg_cond_flag = cond_flag;			/* Return info about break. */
	arg_comd_len = break_slot.comd_len;
	arg_comd_ptr = addr (break_slot.comd_line);
	arg_line_no = break_slot.line_no;

	return;					/* The end of the  check_break  entry.  */
						/* 	*/
set_break: entry (arg_break_ptr, arg_type, arg_snt_ptr, arg_print_mode);


/*	This entry is called to set a break.  Unless it is a  disabled  break, the word
   *  referenced by  break_ptr will be set up to take a fault when executed.
*/

	break_ptr = arg_break_ptr;			/* Copy arguments. */
	type = arg_type;
	snt_ptr = arg_snt_ptr;
	print_mode = arg_print_mode;

	call SET_DEFAULTS;				/* Set up this segment as the default segment. */

/*	Now we know that we have pointers to the break map of the default segment and
   *  to the user's break segment.  Next, we will look for a free slot in the break map
   *  where we can put this new break.  If no slots are available, we will try to allocate
   *  some.
*/
	break_offset = fixed (rel (break_ptr));		/* Get word offset of where the break is to go.
						   *  This is used to identify the break. */

	new_bnum = -1;				/* Initialize the new break number to indicate that
						   *  we don't have a slot for the break yet. */

	do break_num = 1 to bmap.num_slots;		/* Search through all the break slots in
						   *  this break map.  */
	     call GET_BREAK_SLOT_PTR;			/* Get pointer to this slot. */
	     if break_slot.type = -1			/* Is this break slot free? */
	     then if new_bnum = -1			/* YES, but is it the first free slot? */
		then new_bnum = break_num;		/* YES, this is the slot we will use.  */
		else;

/*	NO, this slot is not free.  There is a break set in it.  See if it is the break
   *  we are trying to set now.   If it is a temporary break, we still want to set it.
*/
	     else if break_slot.offset = break_offset
	     then do;				/* This is the break we are trying to set. */
		if (break_slot.type ^= 1) &amp;
		(break_slot.type ^= 3)
		then do;				/* This is not a temporary break. */
		     call ioa_$ioa_stream (debug_output, "Break ^d already set at ^p", break_num, break_ptr);
		     return;
		end;
		new_bnum = break_num;		/* Temp break. Use this slot. Restore inst. */
		break_ptr -&gt; based_word = break_slot.old_word;
	     end;
	end;					/* We have just checked one break slot in the map. */

	if new_bnum = -1				/* Did we find a free break slot? */
	then do;					/* No, try to allocate more slots. */
	     call db_break_map$get_slots (break_map_ptr);
	     if break_map_ptr = null ()		/* Did we get more slots? */
	     then do;				/* NO. */
		call ioa_$ioa_stream (debug_output, "Unable to allocate more break slots in  ^a&gt;^a",
		     bseg.seg (segx).dir_name, bseg.seg (segx).ent_name);
		return;
	     end;
	     new_bnum = bmap.num_set + 1;		/* Get number of first new slot. */
	end;

/*	Now we have an index to the break slot we will use for this new break.   We
   *  must increment the count of breaks that are set and we must initialize the
   *  break itself.
*/
	break_num = new_bnum;			/* Use new break number. */
	bmap.num_set = bmap.num_set + 1;		/* One more break is being set. */
	call GET_BREAK_SLOT_PTR;			/* Get pointer to new break slot. */

	break_slot.type = type;			/* Now fill in the break slot. */
	break_slot.offset = break_offset;
	break_slot.old_word = break_ptr -&gt; based_word;

/*	Get the line number associated with the location (if possible). */

	call db_line_no (snt_ptr, fixed (rel (break_ptr), 18), i, j, break_slot.line_no);

/*	Get the number of words used by this instruction.  If there are more
   *  than  one, this is an EIS instruction.
*/
	break_slot.num_words = op_mnemonic_$op_mnemonic (fixed (break_ptr -&gt; instr.opcode, 17)).num_words;

/*	Initially there are no skips set, there is no command to execute, and there is
   *  no condition set.
*/
	break_slot.reserved (*),
	     break_slot.skip_count,
	     break_slot.comd_len,
	     break_slot.cond_len = 0;

	call LIST;				/* Tell user that break is set. */

	if type &lt; 2				/* Is break a disabled type? */
	then do;					/* No, set break. */
	     mme2.break_num = break_num;		/* Connect mme2 to break slot via break index. */
	     break_ptr -&gt; mme2_map = mme2;		/* Move mme2 into break location. */
	end;

	return;					/* This is the end of the  set_break  entry.  */
						/* 	*/
set_skips: entry (arg_break_num, arg_num_skips);


/*	This entry is called to set the skip count in the specified break of the
   *  default segment.
*/

	break_num = arg_break_num;			/* Copy argument. */

	call CHECK_DEFAULT;				/* Make sure default segment set up
						   *  and break number valid.  */
	break_slot.skip_count = arg_num_skips;

	return;
						/* 	*/
restart:	entry (arg_break_ptr, arg_break_num, arg_num_skips, arg_scu_ptr, arg_print_mode);

/*	This entry is called to restart a break.  To do this we must modify the SCU
   *  data in the stack frame of the debug break handler.  When the break handler
   *  returns, the instruction that was replaced by the  mme2  will be executed.
*/

	break_ptr = arg_break_ptr;			/* Copy some arguments. */
	break_num = arg_break_num;
	scup = arg_scu_ptr;
	print_mode = arg_print_mode;

	if break_ptr -&gt; mme2_map.op_code ^= mme2.op_code /* Break has alredy been reset */
	then scup -&gt; scu.even_inst = break_ptr -&gt; based_word;

	else do;					/* Break is still set. */
	     call SET_DEFAULTS;
	     call CHECK_BREAK_NUM;			/* Make sure it is still valid. */
	     scup -&gt; scu.even_inst = break_slot.old_word;

	     if break_slot.type = 1			/* Is this a temporary break? */

	     then call RESET;			/* Temporary break */
	     else do;				/* Regular break */

		if arg_num_skips &gt;= 0 then break_slot.skip_count = arg_num_skips - 1;
		if break_slot.num_words &gt; 1		/* EIS instruction */
		&amp; bmap.version = "ver3"

		then do;
		     inst_ptr = addrel (break_ptr, break_slot.num_words);
		     bmap.eis.mme2_indw = rel (break_ptr);
		     bmap.eis.inst_indw = rel (inst_ptr);
		     bmap.eis.mme2 = break_ptr -&gt; based_word;
		     bmap.eis.inst = inst_ptr -&gt; based_word;
		     break_ptr -&gt; based_word = break_slot.old_word;
		     inst_ptr -&gt; based_word = bmap.eis.tra;
		end;
	     end;
	end;

	scup -&gt; scu.apu.xsf = "0"b;			/* These fields must be zero. */
	addr (scup -&gt; scu.word3) -&gt; based_word = "0"b;
	scup -&gt; scu.cu.its = "0"b;

/*  If a break has just been set in the following word (.ct request or by the &lt; request), the
   odd instruction will have to be set since it has already been fetched.
*/

	break_ptr = addrel (break_ptr, 1);
	if break_ptr -&gt; mme2_map.op_code = mme2.op_code
	then scup -&gt; scu.odd_inst = break_ptr -&gt; based_word;

	return;					/* This is the end of the  restart  entry.  */
						/* 	*/
single:	entry (arg_break_num, arg_action_code, arg_line_len, arg_line, arg_print_mode);


/*	This entry is called to perform an action on ONE break that is assumed to
   *  be in the default segment.
*/

	break_num = arg_break_num;			/* Copy arguments. */
	action_code = arg_action_code;
	line_len = arg_line_len;
	print_mode = arg_print_mode;

	call CHECK_DEFAULT;				/* Make sure everything is OK.  */

	if break_slot.type ^= -1			/* Is break really set? */
	then call DO_ACTION;			/* YES, go perform action on this break. */
	else call ioa_$ioa_stream (debug_output, "Break  ^d  not set.", break_num);

	return;
						/* 	*/
sub_global: entry (arg_action_code, arg_line_len, arg_line, arg_print_mode);


/*	This entry is called to perform an action on all of the breaks set in the
   *  DEFAULT SEGMENT.
*/
	action_flag = "0"b;				/* Initialize flag. */
	action_code = arg_action_code;		/* Copy arguments. */
	line_len = arg_line_len;
	print_mode = arg_print_mode;
	break_num = 1;				/* Set up dummy break number. */
	call CHECK_DEFAULT;

/*	If there are no breaks set in this segment, we will delete its break map.
   *  This will also delete this segment's entry in the break segment array.
*/
	if bmap.num_set = 0				/* Any breaks set? */
	then do;					/* NO. */
	     call DELETE_BMAP;
	     call ioa_$ioa_stream (debug_output, "No breaks set.");
	     return;
	end;

/*	There are breaks set in the default segment.  We have to look at all of the slots
   *  in this segments break map.  We will perform the specified action on all of the
   *  breaks that are found.
*/
	do break_num = 1 to bmap.num_slots while (break_map_ptr ^= null ());
	     call GET_BREAK_SLOT_PTR;
	     if break_slot.type ^= -1			/* Is there a break in this slot? */
	     then call DO_ACTION;			/* YES. */
	end;

	if ^action_flag
	then call ioa_$ioa_stream (debug_output, "No breaks set.");

	return;					/* End of  sub_global  entry.  */
						/* 	*/
global:	entry (arg_action_code, arg_line_len, arg_line, arg_print_mode);


/*	This entry is called to perform a specified action an all of the breaks the user
   *  has in  ALL  of the segments referenced by his break segment.
*/

	action_flag = "0"b;				/* Initialize flag. */
	action_code = arg_action_code;		/* Copy arguments. */
	line_len = arg_line_len;
	print_mode = arg_print_mode;

	if break_seg_ptr = null ()			/* Make sure we have a break segment. */
	then call INIT_BREAK_SEG;			/* We don't care about any default segment. */

	if bseg.num_segs &gt; 0 then do;			/* Breaks are set */
	     segx = 1;
	     do while (segx &lt;= bseg.num_segs);		/* Process all segments in user's break segment.
						   *  If not, the segment entry will be deleted
						   *  and  delete_seg_entry_flag  will be ON.  */
		call CHECK_SEGMENT;

		if ^ delete_seg_entry_flag then do;	/*  Segment not deleted;  at least one break */

		     do break_num = 1 to bmap.num_slots while (break_map_ptr ^= null ());
			call GET_BREAK_SLOT_PTR;
			if break_slot.type ^= -1 then call DO_ACTION;
		     end;
		     if ^delete_seg_entry_flag then segx = segx + 1;
		end;
	     end;
	end;

	if ^action_flag then call ioa_$ioa_stream (debug_output, "No breaks set.");

	return;					/* The end of the  global  entry.  */
						/* 	*/
SET_DEFAULTS: procedure;


/*	This procedure establishes the segment with the break as the default segment.
   *  It also makes sure that we have a break segment to work with - it sets up  the
   *  pointer to the break segment.  The default segment index references this segment's
   *  entry in the user's break segment and the default break map pointer references the
   *  break map in this segment.  The entry for this segment in the user's break segment
   *  is initialized.  If none exists, one will be created.
*/

	     if break_seg_ptr = null ()		/* Has the break segment been set up? */
	     then call INIT_BREAK_SEG;		/* No, do it now. */

/*	Get the name of the new default segment.  */

	     call hcs_$fs_get_path_name (break_ptr, dir_name, (0), ent_name, code);
	     if code ^= 0
	     then goto SET_DEF_ERR;


/*	Get the bit count and the  uid  of this segment.  Note, if the path name is for
   *  a link, then we will chase the link, and get the status of the branch itself.
*/
	     call hcs_$status_long (dir_name, ent_name, 1b, addr (branch), null (), code);
	     if code ^= 0
	     then goto SET_DEF_ERR;


/*	Now get the pointer to the break map for this segment.  If no break map exists, it
   *  will be created.
*/
	     call db_break_map$init (break_ptr, fixed (branch.bitcnt, 24), break_map_ptr);
	     if break_map_ptr = null () | break_ptr = null then do;
		arg_break_ptr = null;
		goto RETURN_FROM_DB_BREAK;
	     end;

/*	Now we must find the entry in the break segment which corresponds to the new
   *  default segment.  If there is no entry for this segment, then one will be created.
   *  Note, the search through the break segment entries is done for  uid's  and not
   *  for path names since they may have been changed.
*/
	     do segx = 1 to bseg.num_segs;
		if bseg.seg (segx).uid = branch.uid
		then goto SET_DEF_SEG_FOUND;
	     end;


/*	This break segment doesn't contain an entry for the dafault segment.  Thus we
   *  will create one.
*/
	     call set_break_seg_bc (segx, "0"b);

	     bseg.num_segs = segx;			/* Up count of segments. */
	     bseg.seg (segx).uid = branch.uid;		/* This relates the entry to the segment.  */


/*	Now that we know the index of the break segment entry for the default segment we
   *  can fill in the names of the segment.  These must be reset each time the segment
   *  is established as the default segment.
*/

SET_DEF_SEG_FOUND:

	     bseg.seg (segx).dir_name = dir_name;
	     bseg.seg (segx).ent_name = ent_name;

	     def_break_map_ptr = break_map_ptr;		/* Set up default break map pointer. */
	     def_segx = segx;			/* Set up default segment index. */

	     return;


SET_DEF_ERR:

	     call com_err_ (code, "debug", "Cannot make  ^p  the default break segment.", break_ptr);
	     goto RETURN_FROM_DB_BREAK;		/* Transfer out of this internal procedure and
						   *  return directly to the caller of db_break. */

	end SET_DEFAULTS;
						/* 	*/
CHECK_DEFAULT: procedure;


/*	This internal procedure checks to see if there is a default segment established.
   *  If not, there is an error.  It will also check to see if the break number passed
   *  as an argument is valid for this segment.  If everything is OK, it will copy the
   *  default variables, which are in internal static, and the break number, which is an
   *  argument, into automatic variables.
*/

	     if def_segx = 0			/* Has default segment been established?  */
	     then do;				/* NO, error.  */
		call ioa_$ioa_stream (debug_output, "No default break segment.");
		goto RETURN_FROM_DB_BREAK;
	     end;

	     break_map_ptr = def_break_map_ptr;		/* Copy default variables. */
	     segx = def_segx;

	     call VALIDATE_BREAK_NUM;			/* Check boonds of break number. */
	     call GET_BREAK_SLOT_PTR;			/* Get pointer to its break slot. */


	end CHECK_DEFAULT;
						/* 	*/
CHECK_BREAK_NUM: procedure;


/*	This internal procedure is called to perform special validation on the break number.
   *  It checks to see if the break number is within valid bounds and it also checks to
   *  see that the specified breakis enabled.  If the break number is valid,
   *  it sets up the break slot pointer to point to the break slot associated
   *  with this break number.
*/

	     call VALIDATE_BREAK_NUM;			/* Check bounds of break number. */

	     call GET_BREAK_SLOT_PTR;			/* Get pointer to this break's slot. */
	     if (break_slot.type = -1) |		/* Is break not set? */
	     (break_slot.type &gt; 1)			/* Or is break disabled? */
	     then do;				/* Yes, break not enabled. */
		call ioa_$ioa_stream (debug_output, "Break  ^d  should be enabled but isn't.  Segment must be recompiled.", break_num);
		arg_break_ptr = null;
		goto RETURN_FROM_DB_BREAK;
	     end;


	end CHECK_BREAK_NUM;
						/* 	*/
VALIDATE_BREAK_NUM: procedure;


/*	This procedure is called to check that the current break number is
   *  within valid bounds for the current default segment.
*/

	     if (break_num &lt;= 0) |			/* Is break number within bounds. */
	     (break_num &gt; bmap.num_slots)
	     then do;				/* No, outside bounds of break map. */
		call ioa_$ioa_stream (debug_output, "Illegal break number  ^d  for segment  ^a&gt;^a",
		     break_num, bseg.seg (segx).dir_name, bseg.seg (segx).ent_name);
		goto RETURN_FROM_DB_BREAK;
	     end;

	end VALIDATE_BREAK_NUM;
						/* 	*/
CHECK_SEGMENT: procedure;


/*	This procedure is called to get the break map of a segment and to validate the
   *  fact that the segment has breaks set.  The first thing that we must do is to
   *  initiate this segment so we can get a pointer to it and get its bit count.
   *  If any of the following four conditions occur, we will delete this entry in
   *  the break segment:
   *  1.  The segment does not exist.
   *  2.  The uid of the segment doesn't match the uid in the break segment entry.
   *      This implies that the name of the segment was changed and a new
   *      segment was created with its old name.
   *  3.  There is no break map for this segment; =&gt; it has no breaks.
   *  4.  There is a break map, but there are no breaks set.
   *  If the segment entry is deleted and there is a break map, the break map will
   *  also be deleted.  If for any of the above reasons the segment entry is deleted
   *  the  delete_seg_entry_flag  will be turned  ON.
*/
	     delete_seg_entry_flag = "0"b;		/* Assume seg entry OK. */

	     call hcs_$initiate_count (bseg.seg (segx).dir_name, bseg.seg (segx).ent_name,
		"", bit_count, 0, seg_ptr, code);
	     if seg_ptr = null ()			/* Does segment exist? */
	     then do;				/* NO. */
		call DELETE_SEG_ENTRY;
		return;
	     end;

	     call hcs_$status_long (bseg.seg (segx).dir_name, bseg.seg (segx).ent_name, 1b,
		addr (branch), null (), code);
	     if bseg.seg (segx).uid ^= branch.uid	/* Is it realy the same segment?  */
	     then do;				/* NO. */
		call ioa_$ioa_stream (debug_output, "Path name  ^a&gt;^a  now references new segment.",
		     bseg.seg (segx).dir_name, bseg.seg (segx).ent_name);
		call DELETE_SEG_ENTRY;
		return;
	     end;

	     call db_break_map$check (seg_ptr, bit_count, break_map_ptr);
	     if seg_ptr = null then return;		/* error return for illegal break format */

	     if break_map_ptr = null ()		/* Does it have a break map?  */
	     then do;				/* NO. */
		if print_mode = 1			/* Only print this message in LONG mode. */
		then call ioa_$ioa_stream (debug_output, "^a&gt;^a has no break map.", bseg.seg (segx).dir_name,
		     bseg.seg (segx).ent_name);
		call DELETE_SEG_ENTRY;
		return;
	     end;

/*	This segment has a break map.  Does it have any breaks set?  If not, we will
   *  delete its break map.  This will also result in deleteing its segment entry.
*/
	     if bmap.num_set = 0			/* Does it have any breaks set? */
	     then do;				/* NO. */
		call DELETE_BMAP;
		return;
	     end;

	end CHECK_SEGMENT;
						/* 	*/
GET_BREAK_SLOT_PTR: procedure;


/*	This internal procedure is called to get a pointer to the break slot
   *  referenced by "break_num".  Temporarily, there are two versionb of
   *  the break_map_header.  This procedure must decide which version is being used.
*/

	     break_slot_ptr = addr (bmap.breaks (break_num));


	end GET_BREAK_SLOT_PTR;
						/* 	*/
INIT_BREAK_SEG: procedure;


/*	This procedure is called to get a pointer to the user's break segment in his
   *  home directory.  The pointer is set in  "break_seg_ptr" which is in internal
   *  static.  If no break segment exists for this user, then one will be created.
*/

	     call user_info_$homedir (dir_name);	/* Get the name of the user's
						   *  home directory.  */

	     call user_info_ (ent_name);		/* Get the user's login name.
						   *  Note, it is a max of 24 chars.  */

	     i = index (ent_name, " ");		/* Get index of first blank. */
	     substr (ent_name, i, 7) = ".breaks";	/* Add debug suffix.  */


/*	The following call will get a pointer to the segment.  If none exists, it will
   *  create the segment.  In any case, there is an error only if we don't get a
   *  valid pointer back.  We don't use a reference name and we want RWA access to
   *  the segment.
*/
	     call hcs_$make_seg (dir_name, ent_name, "", 01011b, break_seg_ptr, code);
	     if break_seg_ptr = null ()
	     then do;
		call com_err_ (code, "debug", "^a&gt;^a", dir_name, ent_name);
		goto RETURN_FROM_DB_BREAK;
	     end;


	end INIT_BREAK_SEG;
						/* 	*/
DO_ACTION: procedure;


/*	This internal procedure acts as a transfer vector.  It calls the  db_break
   *  procedure which will perform the specified action.  The action code
   *  indicates the type of action.  The action flag is turned on in order to
   *  indicate that the action has been performed for at least one break.
*/

	     action_flag = "1"b;

	     goto ACTION_LABEL (action_code);		/* Go to specified call.  */


ACTION_LABEL (1):					/* LIST a break. */
	     call LIST;
	     return;



ACTION_LABEL (2):					/* RESET a break. */
	     call RESET;
	     return;


ACTION_LABEL (3):					/* DISABLE a break. */
	     call DISABLE;
	     return;


ACTION_LABEL (4):					/* ENABLE a break. */
	     call ENABLE;
	     return;


ACTION_LABEL (5):					/* Set a COMMAND in a break. */
	     call SET_COMMAND;
	     return;


ACTION_LABEL (6):					/* Set a CONDITION in a break. */
	     call SET_CONDITION;


	end DO_ACTION;
						/* 	*/
LIST:	procedure;


/*	This procedure is called to print the contents of one break.  The print_mode flag
   *  determines the mode of printing.  There are two modes:
   *  SHORT	(print_mode = 0)	Print as little as possible.
   *  LONG	(print_mode = 1)	Print as  much  as possible.
*/

dcl  line_info char (14) aligned;			/* Char representation of line num. (if available) */


	     if break_slot.line_no &gt; 0
	     then call ioa_$rsnnl (" (line ^d)", line_info, j, break_slot.line_no);
	     else line_info = "";

/*	Print  short mode  information first.  */

	     call ioa_$ioa_stream (debug_output, "^a   ^d  set at  ^a|^o^a",
		break_type_name (break_slot.type), break_num,
		bseg.seg (segx).ent_name, break_slot.offset, line_info);

	     if print_mode = 0			/* If short mode, that's all. */
	     then return;

/*	Now we must print the long mode data.  First print the instruction where the
   *  break is.
*/
	     call print_text_$real_offset (addr (break_slot.old_word), source_string, break_slot.offset);
	     call ioa_$ioa_stream (debug_output, "^-At instruction:  ^a", source_string);

/*	Now print the command line and the condition line if they exist.  */

	     if break_slot.comd_len ^= 0
	     then call ioa_$ioa_stream (debug_output, "Command  =  ^a", substr (break_slot.comd_line, 1, break_slot.comd_len));

	     if break_slot.cond_len ^= 0		/* Is there a condition line? */
	     then do;				/* Yes, call routine that knows condition format. */
		call db_parse_condition$print_line (addr (break_slot.cond_data), source_string);
		call ioa_$ioa_stream (debug_output, "Condition = ^a", source_string);
	     end;


	end LIST;
						/* 	*/
RESET:	procedure;


/*	This procedure is called to reset a break.  Resetting a break involves
   *  removing the  mme2  instruction from the break word and freeing the break slot
   *  used by the break.  When the last break in a segment is reset, its
   *  break map will be deleted.  Also, its entry in the break segment array will
   *  be deleted.
*/

	     call DISABLE;				/* First disable the  mme2.  */

	     break_slot.type = -1;			/* Now free the break slot.  */
	     bmap.num_set = bmap.num_set -1;		/* Segment has one less break set.  */

	     if print_mode ^= 0
	     then call ioa_$ioa_stream (debug_output, "Break ^d at ^a|^o reset.",
		break_num, bseg.seg (segx).ent_name, break_slot.offset);

/*	Now that the break has been reset, we must check to see if there are any breaks left
   *  in the segment.  If not, we will delete its break map.
*/
	     if bmap.num_set = 0			/* Any breaks left in segment? */
	     then call DELETE_BMAP;			/* NO. */


	end RESET;
						/* 	*/
DISABLE:	procedure;

/*	This procedure is called to disable a break.   Disabling a break involves
   *  putting the word that was originally in the break word back into the break word.
   *  This overlays the  mme2  that is there while the break is enabled.
*/

	     if break_slot.type &gt; 1			/* Is break already disabled? */
	     then return;				/* YES. */

/*	Get a pointer to the break and set up our own  mme2  word to look like what should
   *  be in the break word now.
*/
	     break_word_ptr = ptr (break_map_ptr, break_slot.offset);
	     mme2.break_num = break_num;


/*	Now check to see that this is a valid break.  The break word should contain a
   *  mme2  instruction with an address equal to this break number.
*/
	     if break_word_ptr -&gt; based_word ^= addr (mme2) -&gt; based_word
	     then do;
		call ioa_$ioa_stream (debug_output, "Break  ^d  at  ^a|^o  is invalid.",
		     break_num, bseg.seg (segx).ent_name, break_slot.offset);
		return;
	     end;

/*	It is a valid break so we disable it now.  */

	     break_word_ptr -&gt; based_word = break_slot.old_word;


/*	Now set the type to indicate that this is a disabled break.  Regular breaks
   *  are now type  2  and temporary breaks are now type 3.
*/
	     break_slot.type = break_slot.type + 2;


	end DISABLE;
						/* 	*/
ENABLE:	procedure;


/*	This procedure is called to enable a break.  Enabling a break involves simply
   *  putting a  mme2  instruction the the break word.
*/

	     if break_slot.type &lt; 2			/* Is break already enabled */
	     then return;				/* YES, don't bother.  */

	     mme2.break_num = break_num;		/* Addr field of mme2 = break num. */
	     ptr (break_map_ptr, break_slot.offset) -&gt; mme2_map = mme2;


/*	Now set the type to indicate that the break is enabled.  If it is a regular
   *  break it will go from  2 -&gt; 0  and if it is a temporary break if will go from
   *  3 -&gt; 1.
*/
	     break_slot.type = break_slot.type - 2;


	end ENABLE;
						/* 	*/
SET_COMMAND: procedure;


/*	This procedure sets up a command in the specified break.
*/

	     break_slot.comd_len = line_len;

	     if line_len ^= 0			/* Is there really a command line?  */
	     then substr (break_slot.comd_line, 1, line_len) = substr (arg_line, 1, line_len);


	end SET_COMMAND;






SET_CONDITION: procedure;


/*	This procedure is called to set or to reset a condition in a break.  The type of
   *  break is not considered and is not changed.  Only the condition information
   *  in the break slot is changed.  We must determine if we are to set the condition
   *  or reset the condition.  If the condition length is zero, we must reset.
*/

	     if line_len = 0			/* Are we to SET or RESET? */
	     then break_slot.cond_len = 0;		/* RESET - this implies no condition. */
	     else do;				/* SET condition, there is data.  */
		break_slot.cond_len = line_len;
		substr (break_slot.cond_data, 1, line_len) = substr (arg_line, 1, line_len);
	     end;


	end SET_CONDITION;
						/* 	*/
DELETE_BMAP: procedure;


/*	This procedure is called to delete a beak map from a segment.  This is done
   *  whenever a segment is referenced which has a break map but does not have any
   *  breaks set.  This will also result in deleting the segment's entry in
   *  the break segment array.
*/

	     call db_break_map$delete (break_map_ptr);
	     break_map_ptr = null;			/* Make sure no attempt is made
						   *  look at this break map again */

	     call DELETE_SEG_ENTRY;

/*	If this segment is the default segment, we must reset the default segment
   *  variables to indicate that there is no default segment.
*/
	     if def_segx = segx			/* Is this the default segment?  */
	     then def_segx = 0;			/* YES, but no longer.  */


	end DELETE_BMAP;
						/* 	*/
DELETE_SEG_ENTRY: procedure;


/*	This procedure is called to delete an entry in the user's break segment.
   *  We will move the last entry in the break segment array into the entry
   *  that is being deleted.  Then we will clear the last entry and decrement
   *  the count of entries.
*/

/*	Move last entry into the one being deleted.  */

	     break_seg_ptr -&gt; bseg_map.array (segx).entry =
		break_seg_ptr -&gt; bseg_map.array (bseg.num_segs).entry;

	     bseg.num_segs = bseg.num_segs - 1;		/* Decrement the count of entries. */
	     delete_seg_entry_flag = "1"b;
	     call set_break_seg_bc (bseg.num_segs, "1"b);

	end DELETE_SEG_ENTRY;

/*  */
/*  This procedure sets the bit count on the user's break segment.  It is called when a new segment
   slot is added or deleted.
*/
set_break_seg_bc: proc (num_slots, truncate);

dcl  num_slots fixed bin;				/* size the break map will become  */
dcl  truncate bit (1) unal;				/* truncate the break segment */

dcl 1 break_slot aligned like bseg.seg based;
dcl  word_count fixed bin (18);
dcl  size builtin;

	     word_count = size (break_slot) * num_slots + 1;
	     call hcs_$truncate_seg (break_seg_ptr, word_count, code);
	     if code = 0 then call hcs_$set_bc_seg (break_seg_ptr, 36 * word_count, code);
	     if code ^= 0 then call com_err_ (code, "break segment");

	     return;

	end set_break_seg_bc;

/* 	*/
/*	This statement is part of the main  db_break  block.  It is provided so that
   *  internal procedures may return directly to the caller of db_break.   Thus the
   *  db_break  entry which called the internal procedure doesn't have to check for
   *  error conditions.
*/

RETURN_FROM_DB_BREAK:

	return;


     end db_break;




		    db_break_map.pl1                11/04/82  1959.8rew 11/04/82  1609.4      198666



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



db_break_map:	procedure;

/*	This procedure is called to manipulate break maps.  It is called by  db_break
*	to perform the following tasks:
*
*	init:		Returns a pointer to the break map in  a specified segment.
*			If no break map exists then one will be created.
*
*	check:		Returns a pointer to the break map in a specified segment.
*			However, if no break map exists it will not create one.
*
*	get_slots:	It will add anothere page full of break slots to an existing
*			break map.
*
*	delete:		It deletes the break map from the specified segment.
*
*	Rewritten  Dec 72  for the  6180  by  Bill Silver.
*/




/*		PARAMETERS		*/

dcl	arg_seg_ptr	ptr,		/* (I) Pointer to segment that contains
					*   or will contain a break map.  */
	arg_bit_count	fixed bin(24),	/* (I) Bit count of this segment. */
	arg_break_map_ptr	ptr;		/* (I/O) Pointer to break map of a segment.
					*  If there is any ERROR it is returned null. */



/*		AUTOMATIC  DATA		*/

dcl	access_mode	fixed bin(5),	/* Access mode of the segment.  */
	bit_count		fixed bin(24),	/* The total number of bits in a segment. */
	bits_left		fixed bin,	/* The number of bits left unused in the
					*  last page of the segment.  */
	code		fixed bin(35),	/* Error return code.  */
	dir_name		char(168) aligned,	/* Directory name of the segment. */
	ent_name		char(32)  aligned,	/* Entry name of the segment.  */
	end_ptr		ptr,		/* Pointer to the last word in the segment or
					*  where the last word in the segment will be. */
	i		fixed bin,	/* A work index. */
	mapp		ptr,		/* Just declared to get rid of warning.  */
	max_length	fixed bin(19),	/* The max number of words in the object segment. */
	max_num_pages	fixed bin,	/* Number of pages in object segment. */
	new_bits		fixed bin(24),	/* Number of new bits being added to a segment. */
	new_slots		fixed bin,	/* Number of new break slots being added
					*  to the break map. */
	new_words		fixed bin(18),	/* Number of new words being added to a segment. */
	new_slots_ptr	ptr,		/* Pointer to where new break slots will be added. */
	obj_map_ptr	ptr,		/* Pointer to the object map in the segment
					*  or where the object map will go.  */
	page_bits		fixed bin,	/* The number of bits in a page. */
	page_num		fixed bin,	/* The number of the last page in the segment -
					*  starting with page  1.  */
	page_words	fixed bin,	/* The number of words in a page. */
	seg_ptr		ptr,		/* Pointer to the base of the object segment. */
	word_count	fixed bin(19);	/* Total number of words in segment. */

dcl    1	seg_acl		aligned,		/* Structure used to add an ACL entry to the object segment. */
	2 user_id char(32),
	2 access bit(36),
	2 pad bit(36),
	2 status fixed bin(35);

dcl     1	delete_acl	aligned,		/* Used to delete an ACL. */
	2  user_id	char(32),
	2  status		fixed bin(35);
dcl 1 oi like object_info;



/*		BASED  DATA		*/

/*	This is an overlay of an instruction.  We only want to reference the  offset
*	field of the instruction.
*/
dcl    1	based_inst    based    aligned,
        (	2  offset     bit(18),
	2  pad        bit(18)) unaligned;


/*	These are the two formats of the object map offset found at the end of an object segment. */

dcl	ns_obj_map_off	fixed bin(18)	based	aligned,
	stand_obj_map_off	bit(18)		based 	aligned;


dcl 1 map_ver_1 aligned based (obj_map_ptr),	/* version 1 object map */
	2 decl_vers fixed bin,		/* version number of current structure format */
	2 identifier char(8) aligned,		/* must be the constant "obj_map" */
	2 text_offset bit(18) unaligned,	/* offset rel to base of object segment of base of text section */
	2 text_length bit(18) unaligned,	/* length in words of text section */
	2 def_offset bit(18) unaligned,	/* offset rel to base of object seg of base of definition section */
	2 def_length bit(18) unaligned,	/* length in words of definition section */
	2 link_offset bit(18) unaligned,	/* offset rel to base of object seg of base of linkage section */
	2 link_length bit(18) unaligned,	/* length in words of linkage section */
	2 symb_offset bit(18) unaligned,	/* offset rel to base of object seg of base of symbol section */
	2 symb_length bit(18) unaligned,	/* length in words of symbol section */
	2 bmap_offset bit(18) unaligned,	/* offset rel to base of object seg of base of break map */
	2 bmap_length bit(18) unaligned;	/* length in words of break map */



/*		INTERNAL  STATIC  DATA	*/

/*	The following constants are used to restart a break that was set on an EIS type
*	instruction.  The transfer constant is a "tra" instruction which temporarily replaces
*	the instruction which follows the EIS instruction.  This "tra" transfers to the
*	first instruction in the break map header.  When  the break map header is created
*	the "tra" is saved in the break map header and its offset is relocated.
*	The following seven instructions in the break map header put the mme2 back into
*	the break location, replace the tra with the instruction that originally followed
*	the eis instruction, and returns control to the instruction after the eis instruction.
*/
dcl	tra_con	bit(36)	internal static
	init  (	"000000000000000000111001000000000000"b); /* 000000710000 tra eis.instructions */





/*		EXTERNAL ENTRIES		*/

dcl     (	addr, addrel, bit, divide, fixed, null, ptr, rel, size )  builtin;

dcl	sys_info$page_size  fixed bin  external;
%include db_ext_stat_;

dcl	com_err_		     entry  options(variable),
	get_group_id_	     entry  returns (char(32) aligned),
	hcs_$add_acl_entries     entry  (char(*) aligned, char(*) aligned, ptr, fixed bin, fixed bin(35)),
	hcs_$delete_acl_entries  entry  (char(*) aligned, char(*) aligned, ptr, fixed bin, fixed bin(35)),
	hcs_$fs_get_mode	     entry  (ptr, fixed bin (5), fixed bin(35)),
	hcs_$fs_get_path_name    entry  (ptr, char(*) aligned, fixed bin, char(*) aligned, fixed bin(35)),
	hcs_$get_max_length_seg  entry (ptr, fixed bin(19), fixed bin(35)),
	hcs_$set_bc_seg	     entry  (ptr, fixed bin(24), fixed bin(35)),
	hcs_$truncate_seg	     entry  (ptr, fixed bin(19), fixed bin(35)),
	ioa_$ioa_stream	     entry options (variable),
	object_info_$brief	     entry  (ptr, fixed bin(24), ptr, fixed bin(35));
/**/
%include	object_info;
%include  object_map;
/**/
%include	obj_map_old_1_;
/**/
%include	db_break_map_map;
/**/
init:	entry  (arg_seg_ptr, arg_bit_count, arg_break_map_ptr);


/*	This entry is called to return a pointer to the break map in the specified segment.
*	If this segment does not have a break map then one will be created.  Note, when
*	a break map is created we make sure that the user has write access to the
*	segment.   Also note that the number of break slots initially allocated to the
*	break map will vary from segment to segment.  Enough slots will be allocated
*	so that all of the last page of the segment will be used.  Only if there is no
*	room for at least one break slot will another page be used for the break map.
*	If the user needs more break slots he will get them - a page full at a time.
*/

	call CHECK_MAP;			/* See if there is a break map and copy args. */

	call CHECK_ACCESS;			/* Even if there is a break map already in ... */

	if arg_break_map_ptr ^= null then return;

/*	There is no break map.  Before we create one we have to see if there is room
*	in this segment for a break map with at least one break.  If not we can't make
*	the break map.  First get the number of pages in the segment.  
*/
	page_words = sys_info$page_size;
	page_bits  = page_words * 36;
	page_num  =  divide((bit_count + page_bits -1),page_bits, 17, 0);
	bits_left =  page_num * page_bits  -  bit_count;		/* Num unused bits in last page. */
	if   bits_left &lt; ((size(bmap)+size(break_slot)+2)*36)
	     then do;			/* Won't fit on last page, get max length of segment. */
		call hcs_$get_max_length_seg (seg_ptr, max_length, code) ;
		if   code ^= 0
		     then goto ERROR;
					/* Get num of pages in segment. */
		max_num_pages = divide (max_length+page_words-1, page_words, 17, 0) ;
		if   page_num = max_num_pages	/* Last page in seg? */
		     then do;		/* YES, can't create break map. */
			call ioa_$ioa_stream (debug_output, " No room for break map.");
			return;
		     end;
	     end;


/*	There is room for a break map.  We have to determine how may break slots we
*	can initially allocate.  First, we must see how many bits will be left in the last
*	page of the segment after the break map header has been allocated.  NOTE, we must
*	allow for two extra words that may be needed in the object map.
*/
	bits_left = bits_left - (size(bmap)*36) - (2*36);

/*	If we can't fit at least one break slot on this page we will add another page
*	to the segment.
*/
	if   bits_left  &lt;  (size(break_slot)*36)	/* Room on this page? */
	     then bits_left = bits_left + page_bits;	/* NO, add page. */


/*	Now we can get the number of full break slots we can allocate.  Then we can
*	determine the total number of words and bits in the break map.
*/
	new_slots  =  divide(bits_left , (size(break_slot)*36), 17, 0);
	new_words  =  (new_slots * size(break_slot)) + size(bmap);
	new_bits   =  new_words * 36;


/*	The last word of the segment will contain a relative word
*	offset to the beginning of the object map.
*/
	end_ptr = ptr(seg_ptr,divide((bit_count-35),36,24,0));/* Get pointer to last word in segment. */
/*	STANDARD  object map.  This new type of object map is easier to handle since:
*	1.  It does not have to be moved.  Only the obj_map_off has to be moved.
*	2.  The break map entries are already there.  They just have to be filled in.
*	The break map will start where the obj_map_off word is now.  The obj_map_off word
*	will be moved to the new last word in the segment.  Its value will not be changed.
*/

	break_map_ptr  =  end_ptr;
	obj_map_ptr  =  ptr(end_ptr, end_ptr -&gt; stand_obj_map_off);
	end_ptr  =  addrel(break_map_ptr, new_words);

/*	Now we will move the obj_map_off word.  The old one will get overlayed by the
*	break map header.  Break map length is in WORDS.
*/
	end_ptr -&gt; stand_obj_map_off  =  break_map_ptr -&gt; stand_obj_map_off;

	if obj_map_ptr -&gt; object_map.decl_vers = 1 then do;
	     map_ver_1.bmap_offset  =  rel(break_map_ptr);
	     map_ver_1.bmap_length  =  bit (fixed (new_words, 18), 18);
	end;
	else do;
	     obj_map_ptr -&gt; object_map.break_map_offset = rel (break_map_ptr);
	     obj_map_ptr -&gt; object_map.break_map_length = bit (fixed (new_words, 18), 18);
	end;

/*	Now that the break map has been inserted into the segment, we can set the bit count
*	of the segment and then initialize the header of the break map and the new break
*	slots.  We will also return a pointer to the new break map.
*/

	bit_count  =  bit_count  +  new_bits;
	call hcs_$set_bc_seg (seg_ptr, bit_count, code);
	if   code ^= 0
	     then goto ERROR;

	bmap.num_slots  =  new_slots;		/* Initialize break map header info. */
	bmap.num_set =  0;
	bmap.bit_count  =  bit_count;
	bmap.version = "ver3";

	bmap.eis.tra = tra_con;		/* Set up EIS restart instructions. */
	addr(bmap.eis.tra)-&gt;based_inst.offset = rel(addr(bmap.eis.instructions));
	bmap.eis.mme2_indw,
	bmap.eis.inst_indw = "0"b;
	do   i = 1 to 9;
	     bmap.eis.instructions(i) = db_ext_stat_$break_instructions (i);
	end;

	do   i  =  1  to  new_slots;		/* Initialize the new break slots. */
	     addr(bmap.breaks(i))-&gt;break_slot.type = -1;
	end;

	arg_break_map_ptr  =  break_map_ptr;	/* Return ptr to break map. */

	return;				/* This is the end of the  init  entry.  */
/**/
get_slots:	entry  (arg_break_map_ptr);


/*	This entry is called to add more break slots to the break map.  We know that
*	this segment  does not have room for even one more break slot on its last
*	page.  Thus, if this is the last page in the segment, we will not be
*	able to add more break slots.  If there are free pages left in the segment,
*	we will allocate one full page of break slots.
*/

	break_map_ptr  =  arg_break_map_ptr;	/* Copy argument. */
	bit_count  =  bmap.bit_count;		/* Bit count of segment is saved in break map. */
	page_words =  sys_info$page_size;	/* Set up some constants we need. */
	page_bits  =  page_words * 36;

/*	Get number of pages in this  segment.  */

	page_num  =  divide((bit_count + page_bits -1),  page_bits, 17, 0);

	seg_ptr  =  ptr(break_map_ptr, 0);	/* Get pointer to base of segment. */
					/* Get max length of segment. */
	call hcs_$get_max_length_seg (seg_ptr, max_length, code) ;
	if   code ^= 0
	     then goto ERROR;

	max_num_pages = divide (max_length+page_words-1, page_words, 17, 0) ;
	if   page_num  =  max_num_pages	/* Is this the last page? */
	     then do;			/* YES, can't add more slots. */
		arg_break_map_ptr  =  null();	/* Denote ERROR by returning null pointer. */
		return;
	     end;


/*	We do have room for another page of break slots.  We must get some info about
*	this segment and we must get the number of bits that are left unused on
*	the last page of the segment.  This will always be less than the number of
*	bits needed for one break slot so we will add a page to the segment.
*/
	oi.version_number = object_info_version_2;
	call object_info_$brief (seg_ptr, bit_count, addr(oi), code);
	if   code ^= 0
	     then goto ERROR;

	if oi.old_format then goto ERROR_OLD_FORMAT;

	bits_left  =  page_num * page_bits - bit_count  +  page_bits;

/*	We can now figure out how many new break slots to add.  From this we can
*	directly get the number of word and bits that are being added to the segment.
*/
	new_slots  =  divide(bits_left, (size(break_slot)*36), 17, 0);
	new_words  =  new_slots * size(break_slot);
	new_bits   =  new_words * 36;
	end_ptr  =  ptr(seg_ptr, divide((bit_count-35),  36, 24, 0));


/*	Now that we are all set up and have a pointer to the last word in the segment -
*	where the obj_map_off word is - we can insert the new break slots.
*/
/*	STANDARD type object map.  All we have to do is update the length of the break
*	map in the object map and then move the obj_map_off word down to the new end of
*	the segment.
*/

	obj_map_ptr  =  ptr(end_ptr, end_ptr -&gt; stand_obj_map_off);
	if obj_map_ptr -&gt; object_map.decl_vers = 1
	     then map_ver_1.bmap_length  =
		bit(fixed((fixed (map_ver_1.bmap_length, 18) + new_words), 18), 18);

	else obj_map_ptr -&gt; object_map.break_map_length  =
		bit(fixed((fixed (obj_map_ptr -&gt; object_map.break_map_length, 18) + new_words), 18), 18);

	addrel(end_ptr, new_words) -&gt; stand_obj_map_off  =  end_ptr-&gt;stand_obj_map_off;


/*	Now that we have made room for the new break slots, we must update the  bit count
*	and update the break map header info.  We must also initialize the new break
*	slots. 
*/

	bit_count  =  bit_count  +  new_bits;
	call hcs_$set_bc_seg(seg_ptr, bit_count, code);
	if   code ^= 0
	     then goto ERROR;
	bmap.bit_count  =  bit_count;

	do   i  =  (bmap.num_slots + 1)  to  (bmap.num_slots + new_slots);
	     if   bmap.version = "ver3"
		then break_slot_ptr = addr(bmap.breaks(i));
	     break_slot.type = -1;
	end;

	bmap.num_slots  =  bmap.num_slots  +  new_slots;

	return;				/* This is the end of the  get_slots  entry.  */
/**/
check:	entry (arg_seg_ptr, arg_bit_count, arg_break_map_ptr);


/*	This entry is called to return a pointer to the break map of the specified segment.
*	If no break map exists, we will return a null pointer and we will not try
*	to create a break map.  Note, if there is a break map, we will check the user's
*	access to this segment to ensure that he has write access.
*/

	call CHECK_MAP;			/* Get break map pointer. */
	if   code ^= 0
	     then goto ERROR;

	if   arg_break_map_ptr  =  null()	/* Is there a break map? */
	     then  return;			/* NO. */

	call CHECK_ACCESS;			/* YES, make sure access is OK. */
	if   code ^= 0
	     then goto ERROR;


	return;				/* This is the end of the  check  entry. */
/**/
delete:	entry (arg_break_map_ptr);


/*	This entry is called to delete an existing break map from a segment.  The
*	break map will be deleted and the object map will be updated to denote this
*	fact.  We will reset the bit count to what its original value was before the
*	break map was added to the segment.  Also, we will truncate the segment so that it
*	will actually be its former size.
*	First we will copy the argument and get some info about the segment.
*/

	break_map_ptr  =  arg_break_map_ptr;
	bit_count  =  bmap.bit_count;
	seg_ptr  =  ptr(break_map_ptr, 0);	/* Get pointer to base of segment.  */

	oi.version_number = object_info_version_2;
	call object_info_$brief (seg_ptr, bit_count, addr(oi), code);
	if   code ^= 0
	     then goto ERROR;

	if oi.old_format then goto ERROR_OLD_FORMAT;

/*	Now we will get a pointer to the end of the segment where the object map offset
*	word is.  We will also get the number of bits in the break map.   This is the
*	number of words that must be deleted from the segment.
*/
	end_ptr  =  ptr(seg_ptr, divide((bit_count - 35),  36, 24, 0));
	new_bits  =  oi.blng * 36;		/* Num of bits in break map. */

/*	STANDARD object map.  All we have to do is zero out the break map entries in
*	the object map (they stay there) and to move the object map offset word to
*	to the new end of the segment.  It will go where the first word of the break
*	map is now.
*/

	obj_map_ptr  =  ptr(seg_ptr, end_ptr -&gt; stand_obj_map_off);
	if obj_map_ptr -&gt; object_map.decl_vers = 1 then do;
	     map_ver_1.bmap_offset,
	     map_ver_1.bmap_length  =  "0"b;
	end;

	else do;
	     obj_map_ptr -&gt; object_map.break_map_offset = "0"b;
	     obj_map_ptr -&gt; object_map.break_map_length = "0"b;
	end;

	break_map_ptr -&gt; stand_obj_map_off  =  end_ptr -&gt; stand_obj_map_off;


/*	Now that we have correctly rearrainged the segment we can reset the bit count
*	and truncate the unused portion of the segment.
*/
	bit_count  =  bit_count  -  new_bits;
	call hcs_$set_bc_seg (seg_ptr, bit_count, code);
	if   code ^= 0
	     then goto ERROR;

	word_count=  divide(bit_count+35, 36, 17, 0);
	call hcs_$truncate_seg(seg_ptr, word_count, code);
	if   code ^= 0
	     then goto ERROR;


/*	Now all we have to do is reset that  ACL  entry that we added (possibly)
*	when the beak map was created.
*/
	call hcs_$fs_get_path_name (seg_ptr, dir_name, (0), ent_name, code);
	if   code ^= 0
	     then goto ERROR;

	delete_acl.user_id  =  get_group_id_();
	call hcs_$delete_acl_entries (dir_name, ent_name, addr(delete_acl), 1, code);


	return;			/* End of the  delete  entry.  */
/**/
CHECK_MAP:	procedure;

dcl  probe (3) char(4) based (arg_break_map_ptr);		/* (2,3) = "breakmap" in a probe break map  */


/*  This procedure initializes some variables and then checks to see if we have a
*  break map in this segment.  The break map pointer (either valid or null) will
*  br put in  arg_break_map_ptr.
*/

	seg_ptr  =  ptr(arg_seg_ptr, 0);		/* Get pointer to the base of segment. */
	bit_count  =  arg_bit_count;			/* Copy argument. */


/*  Get some info about this segment.  This will tell us whether there is a
*  break map or not.  
*/
	oi.version_number = object_info_version_2;
	call object_info_$brief (seg_ptr, bit_count, addr(oi), code);
	if   code ^= 0
	     then goto ERROR;

	if oi.old_format then goto ERROR_OLD_FORMAT;

	arg_break_map_ptr  =  oi.bmapp;		/* Get break map pointer. */

/*  The 2-3 words of a probe break map are "breakmap".  The probe and debug break maps are not compatible */

	if arg_break_map_ptr ^= null then if probe (2) = "brea" then do;
	     call ioa_$ioa_stream (debug_output, "probe breaks are still set in this segment");
	     arg_break_map_ptr = null();
	     goto ERROR;
	end;

/* Convert from version 2 to version 3 break map */

	if   arg_break_map_ptr ^= null() then do;
	     break_map_ptr = arg_break_map_ptr;
	     if bmap.version = "ver2" then do;
		bmap.version = "ver3";
		do i = 1 to 9;
		     bmap.instructions (i) = db_ext_stat_$break_instructions (i);
		end;
	     end;
	     return;
	end;

	end  CHECK_MAP;
/**/
CHECK_ACCESS:	procedure;


/*	This procedure is called to check that this segment has write access.  Since
*	we must write into the break map this is necessary.  If we don't have  W  access
*	we will try to add ourselves to the  ACL of the segment and thus give ourselves
*	W  access.
*/

	call hcs_$fs_get_mode (seg_ptr, access_mode, code);
	if   code ^= 0
	     then goto ERROR;

	if   (bit(access_mode,5) &amp; ("00010"b))  ^=  "00000"b
	     then return;			/* YES, we do have  W  access.  */


/*	NO, we don't have write access.  The  W  bit is off.  We will get the path name
*	of the segment and the validation level and we will try to add ourselves to the
*	ACL of the segment.  Note we will be added under the  group_id  name  and with
*	REWA access.  
*/
	call hcs_$fs_get_path_name (seg_ptr, dir_name, (0), ent_name, code);
	if   code ^= 0
	     then goto ERROR;

	seg_acl.user_id = get_group_id_();
	seg_acl.access = "1111"b;
	seg_acl.pad = "0"b;

	call hcs_$add_acl_entries (dir_name, ent_name, addr(seg_acl), 1, code);
	if   code ^= 0
	     then goto ERROR;


	end  CHECK_ACCESS;
/**/
/*	This is the location transfered to when any error occurs due to a call to one
*	of the system procedures.  This is part of the main block of  db_break_map  so
*	when it is called by an internal procedure control will be returned directly
*	to the caller of  db_break_map.  Note, regardless of the error,  we will
*	return a null  break map pointer.
*/

ERROR:
	arg_break_map_ptr  =  null();

	call com_err_(code, "debug", "Error in  db_break_map.  ");
	return;

ERROR_OLD_FORMAT:

	call com_err_ (0, "debug", "Version 1 object segments are not supported by debug");
	arg_seg_ptr = null;

	return;


	end  db_break_map;
��



		    db_data.alm                     11/04/82  1959.8rew 11/04/82  1633.7       53001



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

	name	db_data



	segdef	names

	segdef	tags

	segdef	fault_names

	segdef	acv_names

	segdef	ipr_names


	segdef	n_regs





" This procedure is used as a constant data base for the MULTICS on-line debug
" programs.  It is written in  ALM  so that it can be part of the text section of the
" bound debug program.  This allows it to be shared by all processes without any copying.
"
" Rewritten  Nov 72  for the  6180  by  Bill Silver.
"
" This table contains the names of the  debug defined data items.   They correspond to
" the data fields found in the machine conditions.   Each name must be four (4) characters
" long.   If this table is changed the  db_regs  program must also be changed.



names:

	aci	"pr0 "		The eight pointer registers
	aci	"pr1 "
	aci	"pr2 "
	aci	"pr3 "
	aci	"pr4 "
	aci	"pr5 "
	aci	"pr6 "
	aci	"pr7 "

	aci	"x0  "		The eight index registers
	aci	"x1  "
	aci	"x2  "
	aci	"x3  "
	aci	"x4  "
	aci	"x5  "
	aci	"x6  "
	aci	"x7  "

	aci	"aq  "		The combined A and Q registers
	aci	"all "		Used to print all debug data.
	aci	"prs "		Used to print all eight pointer regs.
	aci	"regs"		Used to print index regs, a,q,exp,tr, and ralr.
	aci	"scu "		Used to print all the SCU data.
	aci	"user"		Used to print all of the user registers.

	aci	"a   "		A  register
	aci	"q   "		Q  register
	aci	"exp "		Exponent  register
	aci	"tr  "		Timer  register
	aci	"ralr"		Ring Alarm Register
	aci	"ppr "		Procedure Pointer Register
	aci	"tpr "		Temporary Pointer Register
	aci	"even"		Even instruction at fault time
	aci	"odd "		Odd  instruction at fault time
	aci	"ind "		Indicators
	aci	"eaq "		Floating point accumulator

n_regs:	vfd	36/*-names-1	Number of names (-1 becuse array is (0:n))
"
tags:

          aci	"    "		Register Modification  (R )
          aci	",au "
          aci	",qu "
          aci	",du "
          aci	",ic "
          aci	",al "
          aci	",ql "
          aci	",dl "
          aci	",0  "
          aci	",1  "
          aci	",2  "
          aci	",3  "
          aci	",4  "
          aci	",5  "
          aci	",6  "
          aci	",7  "

          aci	",*  "		Register then Indirect  (RI)
          aci	",au*"
          aci	",qu*"
          aci	"    "
          aci	",ic*"
          aci	",al*"
          aci	",ql*"
          aci	"    "
          aci	",0* "
          aci	",1* "
          aci	",2* "
          aci	",3* "
          aci	",4* "
          aci	",5* "
          aci	",6* "
          aci	",7* "

          aci	",f1 "		Indirect then Tally  (IT)
          aci	",itp"
          aci	"    "
          aci	",its"
          aci	",sd "
          aci	",scr"
          aci	",f2 "
          aci	",f3 "
          aci	",ci "
          aci	",i  "
          aci	",sc "
          aci	",ad "
          aci	",di "
          aci	",dic"
          aci	",id "
          aci	",idc"

          aci	",*n "		Indirect then Register  (IR)
          aci	",*au"
          aci	",*qu"
          aci	"    "
          aci	",*ic"
          aci	",*al"
          aci	",*ql"
          aci	"    "
          aci	",*0 "
          aci	",*1 "
          aci	",*2 "
          aci	",*3 "
          aci	",*4 "
          aci	",*5 "
          aci	",*6 "
          aci	",*7 "
"
fault_names:

          aci	"shutdown            "

          aci	"store               "

          aci	"mme1                "

          aci	"fault_tag_1         "

          aci	"timer_runout        "

          aci	"command             "

          aci	"derail              "

          aci	"lockup              "

          aci	"connect             "

          aci	"parity              "

          aci	"IPR:                "

          aci	"ONC:                "

          aci	"startup             "

          aci	"overflow            "

          aci	"zerodivide          "

          aci	"execute             "

	aci	"directed_fault_0    "

          aci	"seg_fault_error     "

          aci	"page_fault_error    "

          aci	"gate_error          "


          aci       "ACV:                "

          aci	"mme2                "

          aci	"mme3                "

          aci	"mme4                "

          aci	"linkage_error       "

          aci	"fault_tag_3         "

	aci	"undefined_fault     "

          aci	"undefined_fault     "

          aci	"undefined_fault     "

          aci	"undefined_fault     "

          aci	"undefined_fault     "

          aci	"trouble             "
"
acv_names:

          aci	"illegal_ring_order      "

          aci	"out_of_execute_bracket  "

          aci	"no_execute_permission   "

          aci	"out_of_read_bracket     "

          aci	"no_read_permission      "

          aci	"out_of_write_bracket    "

          aci	"no_write_permission     "

          aci	"not_a_gate              "

          aci	"out_of_call_bracket     "

          aci	"outward_call            "

          aci	"bad_outward_call        "

          aci	"inward_return           "

          aci	"cross_ring_transfer     "

          aci	"ring_alarm_register     "

          aci	"associative_memory      "

          aci	"out_of_segment_bounds   "
"
ipr_names:

          aci	"illegal_segment_number  "

	aci	"illegal_opcode          "

          aci	"illegal_modifier        "

          aci	"illegal_slave_procedure "

          aci	"other_illegal           "

          aci	"nonexistent_address     "

          aci	"out_of_bounds           "
"


	end
�����



		    db_ext_stat_.alm                11/04/82  1959.8rew 11/04/82  1633.7       26856



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

"     db_ext_stat_.alm contains the external static data for debug.
"
"     Modified 7/75 by S.E. Barr to add instructions to restart an EIS break.
"
"     dcl  1 db_ext_stat_$db_ext_stat_ ext static aligned,
"
"       2 debug_input char(32) aligned,		/* Input switch name.  Initially 'user_input' */
"       2 debug_output char(32) aligned,	/* output switch name.  Initially 'user_output' */
"       2 return_label label,			/* The label used to do a non local goto out of debug when
"					  it was entered via a fault.  It will go to debug in
"					  another frame.  */
"
"       2 debug_io_ptr(2) ptr,		/* pointers to iocb for i/o 
"					  1 = input switch iocb ptr
"					  2 = output switch iocb ptr      */
"       2 flags aligned,
"         3 debug_io_attach(2) bit(1) unaligned, 	/* 1= debug made the attachment */
"         3 debug_io_open(2) bit(1) unaligned,	/* 1 = debug opened the switch */
"         3 in_debug bit(1) unaligned,		/* Switch for the any_other condition.  0 = send the
"					  condition on.  1 = use the debug condition handler */
"	3 static_handler_call bit (1) unal,	/* ON if static handler */
"         3 pad bit(30) unaligned,		/* Reserved for future use */
"       2 instructions (9) bit (36) aligned	/* Instructions to restart EIS breaks */
"
"
	name      db_ext_stat_
	segdef     db_ext_stat_
	segdef	break_instructions
"
"  These instructions are used to restart a break at an EIS instruction.  The EIS instruction must be restored
"  because the hardware may restart an EIS instruction in certain cases.  The break restart code restores the EIS
"  instruction and places a transfer in the word following the EIS instruction.  The transfer is to these instructions
"  which have been copied into the break map header in the object segment.  The instructions put the mme2 back
"  into the text and restore the word following the eis instruction.
"
break_instructions:

	sti	ind_save-*,ic
	sta	a_reg-*,ic
	lda	mme2-*,ic
	sta	mme2_indw-*,ic*
	lda	inst-*,ic
	sta	inst_indw-*,ic*
	lda	a_reg-*,ic
	ldi	ind_save-*,ic
	tra	inst_indw-*,ic*

mme2_indw:	arg	0		"  Offset of EIS break
inst_indw:	arg	0		"  Offset of instruction following EIS break
a_reg:		arg	0		"  Contents of a reg.
mme2:		arg	0		"  Used to save mme2
inst:		arg	0		"  Used to save instruction following EIS break
ind_save:		arg	0		"  Used to save indicators

	use	linkc
	join	/link/linkc
db_ext_stat_:
	aci	"user_input                      "
	aci	"user_output                     "
	bss	,9

	end




		    db_fill_snt.pl1                 11/05/86  1217.3r w 11/04/86  1033.9       52956



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


db_fill_snt:	procedure( arg_sp, arg_snt_ptr );


/*	This procedure fills in the  SNT  table with data from the specified stack frame.  */




/*		PARAMETER  DATA		*/


dcl	arg_sp		ptr,		/* Pointer to the stack frame where we
					*  will get our data.  */

	arg_snt_ptr	ptr;		/* Pointer to the  SNT  table.  */





/*		AUTOMATIC  DATA		*/


dcl	code		fixed bin,	/* Return code. */

	dummy		fixed bin;	/* Dummy argument. */


dcl	lot_ptr		ptr,		/* Pointer to the  LOT  table.  */
	isot_ptr		ptr,		/* Pointer to the ISOT  table.  */

	proc_segno	fixed bin;	/* Segment number of the procedure which
					*  owns the stack frame.  */


dcl	procedure_ptr	ptr,		/* Pointer to the procedure which owns
					*  the stack frame.  */

	dum_string	char (32) aligned;	/* dummy string used as argument */


dcl	1 situation 	aligned,
	  2 bad_frame bit (1) unal,
	  2 pad1 bit (4) unal,
	  2 entry_ptr_bad bit (1) unal,
	  2 pad2 bit (30) unal;


dcl 1 cond_info aligned,
%include cond_info;





/*		BASED  DATA		*/


dcl    1	lot_array ( 0:1023 )  aligned  based,	/* Map of  LOT table. Used to reference
					*  specific entries in the LOT.  */

	2 segno	bit(18)	unaligned,

	2 offset	bit(18)	unaligned;


dcl	based_name_string    char(ent_pt_name_len)    based;




/*		EXTERNAL  DATA		*/


dcl	db_stack_util$procedure_ptr	ext  entry  ( ptr, ptr, fixed bin ),

	hcs_$fs_get_path_name	ext  entry  ( ptr, char(*) aligned, fixed bin, char(*) aligned, fixed bin ),

	find_condition_info_ 	ext  entry  ( ptr, ptr, fixed bin );

dcl	stack_frame_exit_		ext entry  ( ptr, ptr, ptr,
					 bit (1) aligned, ptr, char(32) aligned,
					 ptr );

dcl	get_entry_name_		ext entry  (ptr, char (*) aligned, fixed bin,
					 char (*) aligned, fixed bin );




dcl     (	addr,
	baseno,
	baseptr,
	fixed,
	null,
	ptr,
	rel  )	builtin;
/**/
%include db_snt;
/**/
%include its;
/**/
%include stack_header;
/**/
%include stack_frame;
/**/
	sp  =  arg_sp;			/* Copy arguments. */

	sntp  =  arg_snt_ptr;


	snt.sp  =  sp;			/* Save pointer to this stack frame.  */


	call	get_proc_ptr;		/* get a pointer to the point */
					/* where the frame was exited */

	if    procedure_ptr  =  null()

/*	Pointer is either invalid or is null.  Set up null SNT  data.  */

			then  do;
bad_proc_ptr:		snt.ent_pt_name,
			snt.ent_name  =  "(unknown procedure)";
			snt.dir_name  =  " ";
			snt.pp,
			snt.lp,
			snt.symp  =  null();
			snt.symflag  =  "0"b;
			return;
			end;



/*	Procedure pointer is  OK.  Fill with what should be  good  data.   */

	snt.symflag  =  "1"b;		/* Indicate that we don't have a symbol
					*  table pointer yet.  */

	snt.symp  =  null();


/*	We will get the  lot  pointer for this procedure from the actual entry in the
*	lot for this procedure.  We can get a pointer to the beginning of the lot from
*	the stack header.
*/

	lot_ptr  =  ptr( sp, 0 ) -&gt; stack_header.lot_ptr;

	proc_segno  =  fixed ( baseno( procedure_ptr ));

	snt.lp  =  ptr( baseptr( lot_ptr -&gt; lot_array(proc_segno).segno),
		      lot_ptr -&gt; lot_array(proc_segno).offset );

	isot_ptr = ptr (sp, 0) -&gt; stack_header.isot_ptr;
	snt.static_ptr  =  ptr( baseptr( isot_ptr -&gt; lot_array(proc_segno).segno),
		      isot_ptr -&gt; lot_array(proc_segno).offset );


	snt.pp  =  procedure_ptr;


/*	For crawl-out frame don't try to get pathname, just stuff it in */

	if fixed( sp -&gt; stack_frame.translator_id, 18) = 3
		then do;

		snt.ent_pt_name, snt.ent_name = "signal_caller";

		snt.dir_name = "signal_caller_directory";

		return;
	end;

/*	Get the path name of the procedure.  If we can't get the path name then see
*	if the frame belongs to the signaller.  If it doesn't then we don't know who
*	it belongs to.
*/

	call	hcs_$fs_get_path_name( procedure_ptr, snt.dir_name, dummy, snt.ent_name, code );

	if	code  ^=  0		/* Did we get a path name. */

		then  do;			/* NO, check for signaller. */

		if  fixed (sp -&gt; stack_frame.translator_id, 18) = 4


			then  do;		/* It is the signaller. */

			snt.ent_pt_name, snt.ent_name  =  "return_to_ring_0_";

			snt.dir_name  =  "signaller_directory";

			return;
			end;


		else  do;		/* It isn't the signaller.  */

			snt.ent_name  =  "(unknown procedure)";

			snt.dir_name  =  " ";

			end;

		end;


/*	Now try to get the entry point name of the procedure.  If we can't
*	get it, we'll just use the entry name of the segment.
*/

	if ^situation.entry_ptr_bad then do;	/* don't bother if we don't have entry ptr */

	     call get_entry_name_ (sp -&gt; stack_frame.entry_ptr,
				snt.ent_pt_name, proc_segno,
				dum_string, code );

	     if code = 0 then return;
	end;

	snt.ent_pt_name = snt.ent_name;	/* couldn't get entry name */

	return;


proc_ptr:	entry (arg_sp, arg_pp);

	/* entry to get just a procedure pointer */

dcl  arg_pp ptr;

	sp = arg_sp;

	call get_proc_ptr;

	arg_pp = procedure_ptr;
	return;


get_proc_ptr:	proc;

/* internal procedure to figure out where a stack frame comes from */

	call find_condition_info_ ( sp, addr(cond_info), code);
				/* get stuff that stack_frame_exit_ wants */

	/* now let stack_frae_exit_ do the real work */

	call stack_frame_exit_ (sp, cond_info.mcptr, cond_info.wcptr,
			  (cond_info.crawlout), procedure_ptr, dum_string,
			  addr(situation));

	if situation.bad_frame | addr (procedure_ptr) -&gt; its.its_mod ^= "100011"b
			/* no good */
	then procedure_ptr = null;

	return;
	end;

	end	db_fill_snt;




		    db_find_mc.pl1                  11/04/82  1959.8rew 11/04/82  1627.5       15066



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


db_find_mc:	procedure (a_sp, co_flag, ret_mcp);

/* 	This procedure is used by other debug subroutines to
	obtain a pointer to the latest set of machine
	conditions relative to the frame pointed to by a_sp.
	If co_flag is "1"b, then the caller desires machine conditions
	associated with the latest crawlout.
*/


/*	Coded by Robert S. Coren 07/23/73	*/


dcl a_sp ptr;
dcl co_flag bit(1) aligned;
dcl ret_mcp ptr;

dcl sp ptr;
dcl pp ptr;

dcl code fixed bin(35);

dcl (addr, null) builtin;

dcl find_condition_frame_ entry (ptr) returns (ptr);
dcl find_condition_info_ entry (ptr, ptr, fixed bin(35));

dcl 1 cond_info aligned,
%include cond_info;


	sp = a_sp;
	ret_mcp = null;		/* all set in case we don't find it */

find_it:
	pp = find_condition_frame_ (sp);
	if pp = null then return;	/* okay, there aren't any */

	sp = pp;
	call find_condition_info_ (pp, addr(cond_info), code);
	if cond_info.mcptr = null then go to find_it;	/* software condition, no mc */

	if co_flag
	then if ^cond_info.crawlout
	     then go to find_it;		/* not crawlout, keep looking */

	ret_mcp = cond_info.mcptr;		/* if we got here we have the stuff we want */
	return;
     end;
��



		    db_get_count.pl1                11/04/82  1959.8rew 11/04/82  1609.4       40257



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


db_get_count:  proc(line,start_index,next_index,number);

/*	db_get_count	Parses the string "line" beginning at "start_index" and returns a fixed binary number.
			using an octal default.

	db_get_count$double	Returns a double word and uses an octal default.

	db_get_count$dec	Returns a fixed binary number, but assumes a decimal default.

	Escape strings must immediately preceed the number.

		&amp;o	Change the default to octal.
		&amp;d	Change the default to decimal.
*/




dcl  line char(132);			/* character string to convert to a number */
dcl (start_index,				/* index of start of string */
     next_index) fixed;			/* index of character following the number */
dcl  number fixed bin(35);			/* number returned */

dcl  no fixed bin(71)  init(0);
dcl  data_type fixed bin;
dcl  data_len fixed bin;
dcl (i,j,st,end) fixed bin;
dcl  data bit(1) init("0"b);
dcl  dec_default bit(1) init("0"b);		/* 1 =  assume decimal init("0");  0 = assume  octal init("0"); */
dcl  assign_ ext entry (ptr,fixed bin,fixed bin,ptr,fixed bin,fixed bin);
dcl  signal_ ext entry (char(*));
dcl (addr, fixed, index, length, substr, verify, unspec) builtin;
dcl  data_ptr ptr;				/* ptr to number */


	number = 0;
	call initial;
	if ^dec_default then number = no;
	else call decimal;
	return;

ERROR:	next_index = start_index;

RETURN:	return;


db_get_count$double: entry (line,start_index,next_index,double_no);

dcl  double_no fixed bin(71);

	data = "1"b;
	call initial;
	if ^dec_default then double_no = no;
	else do;
	     data_ptr = addr(double_no);
	     data_type = 4;
	     data_len = 71;
	     call decimal;
	end;

	return;

db_get_count$dec: entry (line,start_index,next_index,number);

	dec_default = "1"b;
	call initial;
	if dec_default then call decimal;
	else number = no;
	return;

db_get_count$data: entry(line,start_index,next_index,arg_ptr,arg_type,arg_len);

dcl (arg_type,				/* 2*arg type */
     arg_len) fixed bin;			/* precesion */
dcl  arg_ptr ptr;				/* pointer to location of number */

	data = "1"b;
	dec_default = "1"b;
	call initial;
	if ^dec_default then call assign_(arg_ptr,arg_type,arg_len,addr(no),4,71);
	else do;				/* decimal default */
	     i = verify (substr(line,st),"+-0123456789.e");
	     if i = 1 then go to ERROR;
	     else if i = 0 then i = end;
	     else i = st + i -2;
	     call assign_(arg_ptr, arg_type, arg_len,addr(substr(line,st)),43,i-st+1);
	     next_index = i + 1;
	end;

	return;

initial:	proc;

	st = start_index;
	end =length(line);
	if ^data then do;
	     data_ptr = addr(number);
	     data_type = 2;
	     data_len = 35;
	end;
	if substr(line,st,2) = "&amp;o" then do;
	     st = st +2;
	     dec_default = "0"b;
	end;
	else if substr(line,st,2) = "&amp;d" then do;
	     st = st + 2;
	     dec_default = "1"b;
	end;

	if ^dec_default then call octal;
	return;
	end initial;

octal:	proc;

dcl  minus bit(1);

	minus = "0"b;
	if substr(line,st,1) = "-" then do;
	     st = st + 1;
	     minus = "1"b;
	end;
	else if substr (line,st,1) = "+" then st = st + 1;

	i = verify(substr(line,st,end-st+1),"01234567");
	if i = 1 then do;
	     if substr(line,st,1) = "8" | substr(line,st,1) = "9" then call signal_("db_conversion");
	     else go to ERROR;
	end;
	else if i = 0 then j = end;
	else do;
	     j = st + i - 2;
	     if substr(line,j+1,1) = "8" | substr(line,j+1,1) = "9" then call signal_ ("db_conversion");
	end;
	no = 0;
	do i = st to j;
	     no = no*8 + fixed (unspec(substr(line,i,1)),35) - 48;
	end;
	next_index = j + 1;
	if minus then no = -no;
	return;
	end octal;

decimal:	proc;

	if ^data then do;			/* default is fixed bin(35) */
	     data_ptr = addr(number);
	     data_type = 2;
	     data_len = 35;
	     number = 0;
	end;

	i = verify (substr(line,st,end-st+1),"+-0123456789");

	if i = 1 then go to ERROR;
	if i = 0 then j = end;
	else j = st + i - 2;

	call assign_(data_ptr, data_type, data_len, addr(substr(line,st)), 43, j-st+1);
	next_index = j + 1;
	return;

	end decimal;

	end db_get_count;
���



		    db_get_sym.pl1                  11/02/83  1337.3rew 11/02/83  1242.8       42876



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

db_get_sym:	 proc (a_sntp);


/*	This procedure is called to get a pointer to a  symbol table block.
*	The pointer passed as an argument points to the  segment name table
*	of the procedure whose symbol table block we are to find.
*
*	Rewritten on Nov. 7, 1972  for the  6180  by  Bill Silver.
*	Modified Nov. 1, 1983 by Melanie Weaver to remove call to stu_$get_runtime_block
*/

dcl  a_sntp ptr;		/* Pointer to the procedure's segment name table. */

dcl	hdr_ptr	ptr,	/* Pointer to the header of the symbol table. */

	bp	ptr,

	work_ptr	ptr;	/* Temporary pointer. */


dcl	offset	fixed bin(18),	/*  Offset of procedure within its segment. */

	len	fixed bin,	/*  Length of the entry name.  */

	root	bit(18);		/*  Offset of root. */




dcl  stu_$find_containing_block
			ext entry (ptr, fixed bin(18)) returns (ptr),
     stu_$find_header 	ext entry (ptr, char (32) aligned, fixed bin) returns (ptr),
     stu_$find_block 	ext entry(ptr,char(*)) returns (ptr);

%include db_ext_stat_;
dcl	ioa_$ioa_stream 	ext entry options(variable);


dcl  (binary,addrel,index,substr, rel, null) builtin;
/**/
% include  db_snt;
/**/
%include std_symbol_header;


%include stu_frame;
/**/
%include pl1_symbol_block;
/**/
% include symbol_header;
/**/
% include symbol_node;
/**/

	sntp = a_sntp;		/* Copy argument.  Set pointer to segment name 
				*  table overlay.  */



/*	If the symbol table pointer in the segment name table is not null then it
*	is allready pointing to a symbol table block.
*/

	if    snt.symp  ^=  null()    then  return;


/*	We have to look for the symbol table block.   Set the flag in the segment
*	name table so that we won't look again  unless someone else resets the
*	flag.
*/
	snt.symflag  =  "0"b;


/*	Now get the header of the symbol table.
*/

	snt.std = "0"b;
	hdr_ptr  =  stu_$find_header( snt.pp,  snt.ent_pt_name, 0);

/*	If we can't get the header to the symbol table  then we will return.  */

	snt.headp = hdr_ptr;
	if  hdr_ptr  =  null()  then  return;


/*	If there is a pointer to the stack then we can extract the pointer to the
*	symbol table block from the stack information if necessary.
*/
	if    snt.sp  ^=  null()

		then  do;

		if    snt.pp  =  null()
			then  offset  =  binary (rel (snt.sp -&gt; frame.entry), 18, 0);
						/* Use entry ptr if there is no procedure ptr. */
			else  offset  =  binary( rel(snt.pp), 18, 0);

		snt.symp = stu_$find_containing_block (hdr_ptr, offset);

		end;



/*	Now get the offset of the  root.  */

	if	hdr_ptr -&gt; std_symbol_header.identifier  ^=  "symbtree"


		then    root  =  hdr_ptr -&gt;symbol_header.root;


		else  do;

		snt.std = "1"b;
		if	hdr_ptr -&gt; std_symbol_header.area_pointer  =  (18)"0"b    then  return;

		bp  =  addrel( hdr_ptr, hdr_ptr -&gt; std_symbol_header.area_pointer );

		if	bp -&gt; pl1_symbol_block.identifier  ^=  "pl1info"
			then  return;

		root  =  bp -&gt; pl1_symbol_block.root;

		end;

/*	If we already got the symbol pointer from the stack frame we're done */

	if snt.sp ^= null() then return;


/*	If the root block of the symbol table is not present then we will have to return. */

	if	root  =  (18)"0"b    then    return;

/*	We have a valid symbol table.  We will search for the correct block as
*	identified by the entry name.  If no block is found for this entry name then
*	we will use the first block off of the root block.
*/
	len  =  index(snt.ent_pt_name," ") -1 ;		/* Get length of entry name. */
	if len = -1 then len = 32;

	work_ptr  =  stu_$find_block( hdr_ptr, substr(snt.ent_pt_name,1,len));

	if    work_ptr  =  null()			/* If no block found for this entry use
						*  the  first son off of the root.  */
		then  do;
		work_ptr  =  addrel(hdr_ptr, root);
		work_ptr  =  addrel(work_ptr, work_ptr-&gt;symbol_block.son);
		call  ioa_$ioa_stream (debug_output, "Using symbol table of ^A for ^a",
		      addrel(work_ptr,work_ptr-&gt;symbol_block.name), snt.ent_pt_name);
		end;

	snt.symp = work_ptr;		/* send back result */


	end	db_get_sym;




		    db_line_no.pl1                  11/04/82  1959.8rew 11/04/82  1628.5       17388



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


db_line_no:	proc(a_sntp, offset, first, number, line_no);

/*	Procedure to get the line number of the source statement associated
*	with a given offset in an object segment. Decides whether to call
*	get_line_no or get_runtime_line_no in stu_, according to whther
*	the symbol header is standard.
*
*	Coded March 1973 by Robert S&gt; Coren.
*/

dcl	a_sntp ptr;		/* pointer to snt structure(input) */
dcl	offset fixed bin(18);	/* offset in object segment(input) */
dcl	first fixed bin(18);	/* first location in line(output) */
dcl	number fixed bin(18);	/* number of locations in line(output) */
dcl	line_no fixed bin;		/* line number associated with offset(output) */

dcl	db_get_sym entry(ptr);
dcl	stu_$get_line_no entry(ptr, fixed bin(18), fixed bin(18), fixed bin(18),
				fixed bin);
dcl	stu_$get_runtime_line_no entry(ptr, fixed bin(18), fixed bin(18), fixed bin(18),
				fixed bin);

%include db_snt;




	sntp = a_sntp;
	first, line_no = -1;

	if snt.symflag then call db_get_sym(sntp);

	/* with standard header, we can use the top-level symbol block */

	if snt.std then do;
	     if snt.headp ^= null() then
	     call stu_$get_runtime_line_no(snt.headp, offset, first, number, line_no);

	     return;
	end;

	/* Not standard, we'll have to make do with symbol table for current procedure */

	if snt.symp ^= null() then
	call stu_$get_line_no(snt.symp, offset, first, number, line_no);

	return;

	end db_line_no;




		    db_parse.pl1                    11/05/86  1217.3r w 11/04/86  1034.0      428832



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


db_parse: procedure (input_buffer_ptr, input_line_len, arg_auto_ptr, arg_stat_ptr);


/* Modified 10/ by S. Barr to recognize COBOL data types and the size field with the print request. */
/* Modified 771116 by PG to add el &amp; fl output modes */
/* Changed "Version 1 symbol table" msg to say "this language not supported" 10/14/83 S. Herbst */

/*	Parameters	*/

dcl  input_buffer_ptr ptr,

     input_line_len fixed bin,

     arg_auto_ptr ptr,

     arg_stat_ptr ptr;


/*	Default  variables.  	*/

dcl (data_ptr ptr,
     offset fixed bin (18),
     stack_depth fixed bin,
     data_id char (1) aligned,			/* segment id corresponds to data_ptr (t, s, i, l) */
     input_type char (1) aligned,			/* type of input.  Used to decide what
						   *  default to use for db_assign.
						   *  v = variable
						   *  a = address
						   *  * = indirect
						   *  % = temporary
						   */
     data_format char (6) aligned) internal static;


dcl  continue bit (1) unal;
dcl  break_action_code fixed bin,
     break_data_len fixed bin,
     break_data_line char (236),
     break_return fixed bin,
     reg_val bit (72);

dcl  temp_reg_val fixed bin (71);

dcl  goto_label label;

dcl 1 label_map based aligned,
    2 pp ptr,
    2 sp ptr;

dcl  err_no_linkage fixed init (1);
dcl  err_no_stack fixed init (2);
dcl  err_no_sym_tab fixed init (3);
dcl  err_no_static fixed init (4);
dcl  err_mess (4) char (40) int static init (
     "no linkage section",				/* err_no_linkage */
     "no stack frame",				/* err_no_stack */
     "no symbol table",				/* err_no_sym_tab */
     "no internal static");				/* err_no_static */

dcl
     com_err_ ext entry options (variable),
     cu_$cp ext entry (ptr, fixed bin, fixed bin),
     cu_$gen_call ext entry (ptr, ptr),
     cv_oct_check_ ext entry (char (*), fixed bin) returns (fixed bin (35)),
     db_assign ext entry (char (132) aligned, fixed bin, fixed bin, ptr, ptr, ptr, fixed bin,
     fixed bin, fixed bin, fixed bin, bit (1)),
     db_break$global ext entry (fixed bin, fixed bin, char (236), fixed bin),
     db_break$print_bseg ext entry (fixed bin),
     db_break$print_default ext entry,
     db_break$set_break ext entry (ptr, fixed bin, ptr, fixed bin),
     db_break$set_default ext entry (ptr),
     db_break$set_skips ext entry (fixed bin, fixed bin),
     db_break$sub_global ext entry (fixed bin, fixed bin, char (236), fixed bin),
     db_break$single ext entry (fixed bin, fixed bin, fixed bin, char (236), fixed bin),
     db_parse_condition$set ext entry (char (132) aligned, fixed bin, fixed bin, fixed bin, char (236), fixed bin),
     db_get_count ext entry (char (132) aligned, fixed bin, fixed bin) returns (fixed bin),
     db_get_count$dec ext entry (char (132) aligned, fixed bin, fixed bin) returns (fixed bin),
     db_get_count$double entry (char (132) aligned, fixed bin, fixed bin) returns (fixed bin (71)),
     db_get_sym ext entry (ptr),
     db_print ext entry (ptr, char (*) aligned, ptr, char (*) aligned, fixed bin, fixed bin, ptr,
     fixed bin, fixed bin),
     db_regs$get ext entry (ptr, char (4) aligned, bit (72), fixed bin),
     db_regs$print ext entry (ptr, char (4) aligned, fixed bin),
     db_regs$assign ext entry (ptr, char (4) aligned, bit (72), fixed bin),
     db_fill_snt ext entry (ptr, ptr),
     db_fill_snt$proc_ptr entry (ptr, ptr),
     db_sym ext entry (char (72) var, ptr, ptr, fixed bin (18), fixed bin, char (1) aligned, char (*) aligned,
     fixed bin, fixed bin, fixed bin),
     decode_descriptor_ entry (ptr, fixed bin, fixed bin, bit (1) aligned,
     fixed bin, fixed bin, fixed bin),
     expand_path_ ext entry (ptr, fixed bin, ptr, ptr, fixed bin),
     hcs_$fs_get_path_name ext entry (ptr, char (*) aligned, fixed bin, char (*) aligned, fixed bin),
     hcs_$fs_get_seg_ptr entry (char (*), ptr, fixed bin),
     hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*), fixed bin (1), fixed bin (2),
     ptr, fixed bin),
     hcs_$make_ptr ext entry (ptr, char (*) aligned, char (*) aligned, ptr, fixed bin),
     ioa_$ioa_stream entry options (variable),
     ioa_$rsnnl ext entry options (variable),
     iox_$close ext entry (ptr, fixed bin (35)),
     iox_$detach_iocb ext entry (ptr, fixed bin (35)),
     iox_$attach_ioname ext entry (char (*), ptr, char (*), fixed bin (35)),
     iox_$find_iocb ext entry (char (*), ptr, fixed bin (35)),
     iox_$open ext entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)),
     list_arg_ ext entry (fixed bin, char (1) aligned, ptr),
     db_parse_arg ext entry (char (132) aligned, fixed bin, fixed bin, ptr, fixed bin, fixed bin),
     stu_$get_location ext entry (ptr, fixed bin, fixed bin (18));

dcl  is_condition_frame_ entry (ptr) returns (bit (1) aligned);

dcl  db_find_mc entry (ptr, bit (1) aligned, ptr);

dcl  find_condition_info_ entry (ptr, ptr, fixed bin);

dcl  stu_$get_runtime_location entry (ptr, fixed bin) returns (fixed bin (18));

dcl  db_parse_arg$ptr_offset entry (char (132) aligned, fixed bin, fixed bin, fixed bin,
     ptr, fixed bin, fixed bin);



dcl  error_table_$segknown ext fixed bin;


dcl  code35 fixed bin (35);
dcl  fboff fixed bin (9),
     code fixed bin,
     d_type fixed bin,
     itemp fixed bin,
    (max_stack, new_type, line_number) fixed bin,
    (pc, i, j) fixed bin,
     temp1 fixed bin (18),
    (ct, nv) fixed bin,
    (lin, ill) fixed bin,
    (size, scale, ndims) fixed bin,
     exec fixed bin;
dcl  offset_incr fixed bin;				/* increment to be added to offset and working pointer */

dcl  dol fixed bin;
dcl  max_size fixed bin;

dcl  based_bit72 bit (72) based;

dcl  based_fix fixed bin based aligned;


dcl  arglist (21) ptr,
     based_ptr ptr based (sp),
     ptr_array (1) based ptr,
    (pp, ilp, tp, tpp) ptr;




dcl  switch bit (1) aligned;


dcl  new_line char (1) aligned static init ("
"),

     il char (132) aligned,
     reg_name char (4) aligned,
     str char (exec) based aligned,
     str1 char (ill) based aligned,
     sym_name char (72) var,
    (c1, c2) char (1) aligned,
     dir_name char (168) aligned,
     pathname char (168),
    (ent_name, ref_name) char (32) aligned,
     cmc char (1) aligned;
dcl  char char (1) aligned;				/* character being used for parse */

dcl (attach,					/* 1 = switch_name attached */
     open) bit (1) unaligned;				/* 1 = switch_name opened */
dcl  dec_default bit (1);				/* 1 = use dec_default for temporaries (%) */
dcl  switch_name char (32);				/* switch_name for ".si" request */

dcl  entry_name char (32) aligned;


dcl  desc_area (11) bit (36) internal static
     init ((11) (1) "100000100000000000000000000000000001"b);

dcl  desc_ptr ptr init (addr (desc_area));

dcl 1 desc (11) aligned based (desc_ptr),
   (2 flag bit (1),
    2 type bit (6),
    2 packed bit (1),
    2 n_dims bit (4),
    2 size fixed bin (23)) unaligned;

dcl  dummy_desc bit (36) aligned static init
    ("101010100000000000000000000000100000"b);		/* char(32) */

dcl  return_desc bit (36) aligned static init
    ("100000100000000000000000000000000001"b);		/* fixed bin, 1 word */



dcl (addr, addrel, baseno, baseptr, bit, max, null, ptr, rel, substr, index, search, verify) builtin;
dcl (binary, divide, hbound, length, min, reverse) builtin;


dcl 1 ff aligned based,
    2 (w0, w1) fixed bin;


dcl 1 bi aligned based,
    2 ts (132) fixed bin (8) unaligned;			/* character codes used as subscripts to type array */


dcl 1 lot (0: 1023) aligned based,
    2 segno bit (18) unaligned,
    2 offset bit (18) unaligned;

/* constants */

dcl  NUMBER char (11) int static init ("0123456789&amp;");
dcl  MODES (21) char (6) var int static init (
     "a",
     "b",
     "p",
     "P",
     "i",
     "I",
     "l",
     "s",
     "o",
     "h",
     "d",
     "el",
     "fl",
     "f",
     "e",
     "g",
     "x",
     "comp-5",
     "comp-6",
     "comp-7",
     "comp-8");

dcl 1 cond_info aligned,
%include cond_info;
%include db_ext_stat_;
%include iocb;
/*  */
%include db_common_auto;
/*  */
%include db_common_static;
/*  */
%include db_snt;
/*  */
%include db_arg_list;
/*  */
%include its;
/*  */
%include stack_header;
%include stack_frame;
/*
   
   use of big label arrays

   label_1		label_2		label_3

   0		syntax_error	syntax_error	syntax_error
   1 (:)		colon0		colon		colon
   2 (%)		per_cent		syntax_error	syntax_error
   3 (/)		namel		syntax_error	syntax_error
   4 ($)		reg		relative_offset	syntax_error
   5 (n)		offset1		relative_offset	syntax_error
   6 (+ -)	relative_offset	relative_offset	syntax_error
   7 (,)		set_mode		set_mode		set_mode
   8 (=)		assign		assign		assign
   9 (&lt;)		set		set		set
   10 (&gt;)		go		go		go
   11 ( )		----		----		----
   12 (;)		rskip		print		print
   13 (&amp;)		amper		amper		syntax_error
   l4 (letter)	offsetl		offsetl		syntax_error
   15 (nl)	print		print		print
   16 (*)		star		star		syntax_error
   17 (.)		com		syntax_error	syntax_error
   */
/*  */
/*	Initialize data needed to parse the command line.	  */


     com_auto_ptr = arg_auto_ptr;

	com_stat_ptr = arg_stat_ptr;


	lin = 1;
	ill = input_line_len;
	ilp = addr (il);
	ilp -&gt; str1 = input_buffer_ptr -&gt; str1;

	if first_call_flag = 0

	then do;
	     data_ptr = stack_ptr_array (max_sp_x);
	     offset = 0;
	     stack_depth = max_sp_x;
	     data_id = "s";
	     data_format = "h";
	     input_type = "";
	     first_call_flag = 1;
	end;

	sntp = snt_ptr;
	max_stack = max_sp_x;
	sb = ptr (stack_ptr_array (max_stack), 0);


depth_1:

	if get_char (lin, lin, char) then do;
	     d_type = 0;
	     pc = 1;				/* default is print one item */
	     go to label_1 (type (ilp -&gt; bi.ts (lin)));
	end;
	else goto print;

/* come here (depth 2) when the procedure name has been established
   and associated defaults set up */

depth_2:
	if get_char (lin, lin, char) then do;		/* PL1 bug 1497 */
	     goto label_2 (type (ilp -&gt; bi.ts (lin)));
	end;
	else goto print;

/* come here after the following have been set up
   data_ptr
   offset
   output mode

   must either print out a value (or values), set a break, restart execution,
   or assign a value (or values) */

depth_4:
	if get_char (lin, lin, char) then do;		/* PL1 bug 1497 */
	     goto label_3 (type (ilp -&gt; bi.ts (lin)));
	end;
	else goto print;
						/*  */
						/* come here if we are at start of a symbolic name */

label_1 (14):
label_2 (14):
offsetl:
	nv = 0;					/* initialize depth count */
	do i = lin to ill;				/* scan over variable name */
	     cmc = substr (il, i, 1);			/* pick up current character */
	     j = type (ilp -&gt; bi.ts (i));		/* get type of current character */
	     if j = 4 | j = 5 | j = 14 | j = 11 | cmc = "." then go to endl;
	     if cmc = "(" then nv = nv + 1;
	     else if cmc = ")" then do;
		if nv &gt; 0 then nv = nv - 1;
	     end;
	     else if cmc = "-" then do;
		if substr (il, i+1, 1) = "&gt;" then i = i+1; /* scan over arrow */
		else if nv = 0 then go to donel;	/* done if not in parens */
	     end;
	     else if nv = 0 then go to donel;
endl:	end;
donel:
	sym_name = substr (il, lin, i-lin);
	lin = i;
	new_type = 0;
	call db_sym (sym_name, sntp, data_ptr, offset, d_type, data_id, data_format, pc, max_size, code);
	if data_format ^= "a" &amp; data_format ^= "b" then pc = 1;
	if code = 0 then do;			/* continue if no error */
	     input_type = "v";
	     goto relative_offset;
	end;
	if code &gt; 100 then do;
	     i = code - 100;			/* a parameter */
	     cmc = "?";
	     go to list_arg;
	end;
	call sym_err;				/* print message and goto rskip */

/*  */
/* come here when a colon is encountered in the scan */

label_1 (1):
	ct = 0;					/* no return value */
	go to colon_join;
label_2 (1):
label_3 (1):
	ct = 1;					/* return value requested */
colon_join:
	if substr (il, lin+1, 1) ^= "=" then go to syntax_error; /* check for following = */
	if ^get_char (lin + 2, lin, "") then goto syntax_error;
	do i = lin to ill while (is_name (ilp -&gt; bi.ts (i))); /* skip to end of procedure name */
	end;
	ent_name = substr (il, lin, i-lin);		/* pick up segment procedure name */
	if substr (il, i, 1) = "$" then do;		/* secondary entry point given */
	     do lin = i+1 to ill while (is_name (ilp -&gt; bi.ts (lin))); /* skip to end of entry name */
	     end;
	     ref_name = substr (il, i+1, lin-1-i);	/* copy entry point name */
	     end; else do;				/* if no entry point name, use same */
	     ref_name = ent_name;
	     lin = i;
	end;
	call hcs_$make_ptr (null, ent_name, ref_name, tp, code); /* get pointer to the entry */
	if code ^= 0 | tp = null then do;
	     call ioa_$rsnnl ("^a$^a", ent_name, i, ent_name, ref_name);
	     call com_err_ (code, "debug", ent_name);
	     go to rskip;
	end;

	if ^get_char (lin, lin, "") then goto make_call;
	i = 0;
	if substr (il, lin, 1) ^= "(" then go to make_call; /* check for no args */
	lin = lin + 1;
argl:	i = i + 1;				/* go to next arg */
	if ct + i &gt; 11 then do;			/* watch for too many args */
	     call ioa_$ioa_stream (debug_output, "Too many arguments.");
	     go to rskip;
	end;

	call db_parse_arg (il, lin, ill, addr (dummy_arg (i)), j, exec); /* pick up the next arg */
	if substr (il, lin, 1) = "," then lin = lin + 1;	/* skip over "," */
	arglist (i+1) = addr (dummy_arg (i));		/* set up default arglist pointer */
	if j = 0 then do;				/* a variable as the argument */
	     sym_name = addr (dummy_arg (i)) -&gt; str;	/* get returned symbol name */
	     call db_sym (sym_name, sntp, pp, temp1, j, c1, c2, pc, max_size, code);
	     if code = 0 then do;			/* no error, variable */
		arglist (i+1) = pp ;		/* stuff pointer to var in arglist */
		exec = pc;
		go to make_desc;
	     end;
	     if code &gt; 100 then arglist (i+1) = snt.sp -&gt; stack_frame.arg_ptr -&gt; ptr_array (code - 99);
	     else call sym_err;
	end;
	if j &gt; 0 then do;
make_desc:     desc (i).type = bit (binary (j, 6), 6);
	     desc (i).size = binary (exec, 23);
	     arglist (i + 11) = addr (desc (i));
	end;
	else if j = -1 then do;			/* no arg, all done */
	     do j = 1 to i-1;			/* loop through all arguments */
		arglist (j+i+ct) = arglist (11+j);	/* move descriptor pointers down */
	     end;
make_call:     addr (arglist) -&gt; arg_list.num_args = binary (i+ct-1, 17);
	     addr (arglist) -&gt; arg_list.num_desc = binary (i+ct-1, 17);
	     if ct ^= 0 then do;
		arglist (i + 1) = data_ptr;
		arglist (2*i + 1) = addr (return_desc);
	     end;
	     addr (arglist) -&gt; arg_list.code = (16) "0"b || "100"b;
	     addr (arglist) -&gt; arg_list.fill = "0"b;

	     in_debug = "0"b;			/* pass all conditions on */
	     call cu_$gen_call (tp, addr (arglist));	/* call the specified procedure */
	     in_debug = "1"b;			/* turn handler on */
	     go to skip;
	end;
	else if j = -2 then do;			/* syntax error */
	     call ioa_$ioa_stream (debug_output, "Syntax error in argument ^d.", i);
	     go to rskip;
	end;
	else if j = -3 then arglist (i+11) = addr (dummy_desc); /* "%" in arg position */
	else call ioa_$ioa_stream (debug_output, "??");
	go to argl;

/*  */
/* come here to print out dummy args */

label_1 (2):
	input_type = "%";
	nv = db_get_count$dec (il, lin+1, lin);		/* get correct dummy arg */
	if nv &lt; 1 | nv &gt; 10 then go to syntax_error;	/* make sure it's valid */
	data_ptr = addr (dummy_arg (nv));		/* set data ptr to point to the dummy arg */
	data_format = "h";				/* set print default to octal */
	go to star1;				/* merge with indirect code */


/*  */
/* come here if we are at start of a stack procedure name */

label_1 (3):
namel:
	do i = lin+1 to ill while (substr (il, i, 1) ^= "/");
	end;
	if i = ill+1 then go to syntax_error;
	nv = cv_oct_check_ (substr (il, lin+1, i-lin-1), code);
	if code = 0 then do;
	     if nv &lt; hcs_count then do;		/* check for hardcore segment number */
		call ioa_$ioa_stream (debug_output, "Hardcore segment number.");
		go to rskip;
	     end;
	     pp = baseptr (nv);
	     call hcs_$fs_get_path_name (pp, dir_name, itemp, ent_name, code);
	     if code ^= 0 then do;			/* signaller if trouble */
		ent_name = "signaller";
		dir_name = "signaller_directory";
	     end;
	     pathname, entry_name = ent_name;		/* if given number use primary name */
	end;
	else do;
	     pathname = substr (il, lin+1, i-lin-1);

/* find out if it's of form seg$entry */

	     dol = index (pathname, "$");
	     if dol &gt; 0 then do;			/* it is */
		entry_name = substr (pathname, dol + 1);
		pathname = substr (pathname, 1, dol - 1);
	     end;
	     else entry_name = pathname;

	     j = index (reverse (entry_name), "&gt;");
	     if j &gt; 0 then entry_name = substr (entry_name, 32 -j);

	     if substr (pathname, 1, 2) = "&amp;n" then do;
		pathname = substr (pathname, 3);
		lin = lin + 2;
	     end;
	     call expand_path_ (addr (pathname), i-lin-1, addr (dir_name), addr (ent_name), code);
	     if code ^= 0 then do;
com1:		call com_err_ (code, "debug", pathname);
		go to rskip;
	     end;
	     call hcs_$fs_get_seg_ptr (pathname, pp, code); /* is segment already known ? */
	     if pp ^= null then do;			/* yes, get real names for the segment */
		call hcs_$fs_get_path_name (pp, dir_name, itemp, ent_name, code);
		go to check1;
	     end;
	     call hcs_$initiate (dir_name, ent_name, "", 0, 0, pp, code); /* no, initiate it */
	     if code ^= 0 then if code ^= error_table_$segknown then go to com1;
	end;
check1:
	lin = i+1;
	do i = max_stack to 0 by -1;			/* search the stack for the procedure pointer */
	     sp = stack_ptr_array (i);		/* get current stack pointer */
	     call db_fill_snt$proc_ptr (sp, tpp);
	     if tpp ^= null ()
	     then if baseno (pp) = baseno (tpp) then do;	/* we've found a good segment */
		     stack_depth = i;		/* set index into stack */
		     call db_fill_snt (sp, sntp);	/* Get data about working segment. */
		     if snt.ent_pt_name = entry_name then do; /* make sure it's really right frame */
			data_ptr = sp;		/* set defaults */
			data_id = "s";
found3:			offset = 0;
			data_format = "h";

			input_type = "a";
			go to depth_2;
		     end;
		end;
	end;

	snt.symp = null;
	snt.symflag = "1"b;				/* set flag saying we haven't got symp yet */
	snt.pp = pp;
	snt.sp = null;
	snt.lp = ptr (baseptr (stack_header.lot_ptr -&gt; lot (binary (baseno (pp))).segno), stack_header.lot_ptr -&gt; lot (binary (baseno (pp))).offset);
	snt.ent_name = ent_name;
	snt.dir_name = dir_name;
	snt.ent_pt_name = entry_name;			/* use reference name for symbol table */
	data_ptr = pp;
	stack_depth = -1;				/* stack depth is undefined */
	data_id = "t";
	go to found3;
						/*  */

/* come here when a star is encountered */

label_1 (16):
label_2 (16):
	lin = lin+1;
	if data_ptr -&gt; its.its_mod ^= "100011"b then do;
	     call ioa_$ioa_stream (debug_output, "Cannot indirect through ^w ^w.", data_ptr -&gt; ff.w0, data_ptr -&gt; ff.w1);
	     go to rskip;
	end;
	data_ptr = data_ptr -&gt; based_ptr;		/* indirect once through ptr */
	input_type = "*";
star1:	offset = binary (rel (data_ptr), 17);		/* set up offset variable */
	snt.symp = null;				/* fill in snt structure */
	snt.symflag = "1"b;
	snt.pp = ptr (data_ptr, 0);
	snt.sp = null;
	snt.lp = ptr (baseptr (stack_header.lot_ptr -&gt; lot (binary (baseno (data_ptr))).segno), stack_header.lot_ptr -&gt; lot (binary (baseno (data_ptr))).offset);
	call hcs_$fs_get_path_name (data_ptr, snt.dir_name, itemp, snt.ent_name, code);
	snt.ent_pt_name = snt.ent_name;
	stack_depth = -1;
	data_id = "t";
	go to relative_offset;

/* come here if a syntax error is encountered while scanning the command line */

label_1 (0): label_2 (0): label_3 (0): go to syntax_error;
label_2 (2): label_3 (2): go to syntax_error;
label_2 (3): label_3 (3): go to syntax_error;
label_3 (16):
label_2 (17): label_3 (17):
label_3 (4):
label_3 (14):
label_3 (5): label_3 (6):
label_3 (13):
syntax_error: call ioa_$ioa_stream (debug_output, "Syntax error");


label_1 (12):
rskip:
	db_action_code = 1;
	return;

skip:	i = index (substr (il, lin, ill-lin+1), ";");
	if i &gt; 0 then do;
	     lin = lin + i;
	     if lin &lt; ill then go to depth_1;
	end;
	lin = ill;
	return;


/*  */
/*  come here on "."   */


label_1 (17):
	if lin + 1 &gt;= ill then go to no_comm;
	cmc = substr (il, lin+1, 1);
	if verify (cmc, "0123456789") = 0 then do;	/* no command name, set stack frame */
	     stack_depth = db_get_count$dec (il, lin+1, lin); /* pick up desired stack depth */
	     i = stack_depth;			/* in case error, set frame to 0 */
	     go to set_stack;
	end;
	nv = type (ilp -&gt; bi.ts (lin+2));		/* get type of character after command */
	if cmc = "t" then call stack_trace;
	else if cmc = "+" | cmc = "-" then do;		/* pop or push stack */
	     i = db_get_count$dec (il, lin+1, lin);
	     stack_depth = stack_depth + i;
set_stack:     if stack_depth &lt; 0 | stack_depth &gt; max_stack then do;
		call ioa_$ioa_stream (debug_output, "^d not in stack range.", stack_depth);
		stack_depth = stack_depth - i;
		go to rskip;
	     end;
	     call db_fill_snt (stack_ptr_array (stack_depth), sntp); /* get data for this new frame */
	     if snt.pp = null () then call ioa_$ioa_stream (debug_output, "Cannot get text section for stack frame.");
	     data_ptr = snt.sp;
	     data_id = "s";
	     data_format = "h";
	     offset = 0;
	end;
	else if cmc = "|" | cmc = "." then do;
	     substr (il, 1, lin+1) = " ";

	     in_debug = "0"b;			/* pass all conditions on */
	     call cu_$cp (ilp, ill, i);
	     in_debug = "1"b;
	     return;
	end;
	else if cmc = "d" then do;
	     fboff = binary (addr (data_ptr) -&gt; its.bit_offset, 9);
	     call ioa_$ioa_stream (debug_output, "^d  /^a/^o(^d)&amp;^a,^a  ^o", stack_depth, snt.ent_name, offset, fboff, data_id, data_format,
		binary (baseno (snt.pp), 18));
	end;
	else if cmc = "D" then do;
	     fboff = binary (addr (data_ptr) -&gt; its.bit_offset, 9);
	     call ioa_$ioa_stream (debug_output, "^d  /^a&gt;^a/^o(^d)&amp;^a,^a  ^o", stack_depth, snt.dir_name, snt.ent_name, offset, fboff,
		data_id, data_format, binary (baseno (snt.pp), 18));
	end;
	else if cmc = "m" then do;			/* output mode */
	     if substr (il, lin+2, 1) = "b" then print_mode = 0;
	     else if substr (il, lin+2, 1) = "l" then print_mode = 1;
	     else go to syntax_error;
	end;

	else if cmc = "c" then do;
	     cmc = substr (il, lin+2, 1);		/* get next character */
	     if cmc = "t" then do;			/* into temporary break mode */
		lin = lin + 1;
		temp_break_mode = 1;
	     end;
	     else if cmc = "r" then do;		/* regular break mode */
		lin = lin + 1;
		temp_break_mode = 0;
	     end;
	     if substr (il, lin+2, 1) = "," then num_skips = db_get_count$dec (il, lin+3, lin) + 1;
	     else num_skips = 1;			/* num_skips is times to skip the break */

	     db_action_code = 3;
	     return;
	end;
	else if cmc = "q" then do;
	     db_action_code = 2;
	     return;
	end;
	else if cmc = "b" then do;			/* some type of break command */
	     i = lin + 2;
	     cmc = substr (il, i, 1);			/* get the particular break command name */
	     if cmc = "g" then do;			/* global break request */
		cmc = substr (il, i+1, 1);		/* get the command char */
		if cmc = "t" then do;		/* .bge  set up global exec line */
		     i = i + 2;			/* get index of first character of exec line */
		     temp_comd_len = ill-i+1;
		     if temp_comd_len = 1 then temp_comd_len = 0;
		     else temp_comd_line = substr (il, i, temp_comd_len); /* copy string to execute into static */
		     return;			/* read next request line */
		end;
		lin = i + 2;			/* point past request type */
		call get_break_action_code;
		if break_action_code = 0
		then goto skip;
		else call db_break$global (break_action_code, break_data_len, break_data_line, print_mode);
		if break_return = 1 then lin = ill;
		goto skip;
	     end;
	     if cmc = "d" then do;			/* change default break segment */
		if ^get_char (i+1, lin, char) then do;
		     call db_break$print_default;
		     go to skip;
		end;
		pathname = substr (il, lin, ill-lin);	/* get name of segment */
		nv = cv_oct_check_ (pathname, code);	/* see if number was given */
		if code = 0 then do;
		     tp = baseptr (nv);		/* get pointer to break seg */
		end;
		else do;
		     if substr (pathname, 1, 2) = "&amp;n" then do;
			pathname = substr (pathname, 3);
			lin = lin + 2;
		     end;

		     call expand_path_ (addr (pathname), ill-lin, addr (dir_name), addr (ent_name), code);
		     call hcs_$fs_get_seg_ptr (pathname, tp, code);
		     if tp ^= null then go to got_seg;	/* if refence name is known */
		     call hcs_$initiate (dir_name, ent_name, "", 0, 0, tp, code);
		     if tp = null then go to com1;
		end;
got_seg:		call db_break$set_default (tp);	/* set up default seg */
		return;
	     end;
	     if cmc = "p" then do;			/* print break segs */
		call db_break$print_bseg (print_mode);
		go to skip;
	     end;
	     if ^get_char (i + 1, i, "") then do;
		lin = i;
		call get_break_action_code;
		if break_action_code &gt; 0 then do;
		     call db_break$sub_global (break_action_code, break_data_len, break_data_line, print_mode);
		     if break_return &gt; 0 then lin = ill;
		end;

		goto skip;
	     end;
	     nv = db_get_count$dec (il, i, lin);	/* Get break number. */
	     if nv &lt;= 0 then do;			/* and make sure it's okay */
		call ioa_$ioa_stream (debug_output, "Invalid break number.");
		go to rskip;
	     end;

	     if cmc = "s" then do;
		i = db_get_count$dec (il, lin+1, lin);
		call db_break$set_skips (nv, i);
		go to skip;
	     end;
	     call get_break_action_code;
	     if break_action_code = 0
	     then goto skip;
	     else call db_break$single (nv, break_action_code, break_data_len, break_data_line, print_mode);
	     if break_return = 1 then lin = ill;
	     goto skip;
	end;
						/*  */
	else if cmc = "a" then do;
	     if snt.sp = null then do;		/* must have stack frame for arglist print out */
nost:		call ioa_$ioa_stream (debug_output, "No argument list available.");
		go to rskip;
	     end;
	     if snt.sp -&gt; stack_frame.prev_sp -&gt; stack_frame_flags.signaller then go to nost;
	     if snt.sp -&gt; stack_frame.arg_ptr = null () then go to nost;
	     if nv = 7 then do;			/* if comma, use mode specified and do all args */
		cmc = substr (il, lin+3, 1);
		i = -1;
	     end;
	     else if nv = 5 | nv = 13 then do;
		i = db_get_count$dec (il, lin+2, lin);
		if substr (il, lin, 1) = "," then cmc = substr (il, lin+1, 1);
		else cmc = "?";
	     end;
	     else if nv = 12 | nv = 15 then do;
		i = -1;
		cmc = "?";
	     end;
list_arg:	     call list_arg_ (i, cmc, snt.sp -&gt; stack_frame.arg_ptr);
	end;
	else if cmc = "f"				/* get pointer to fault conditions */
	then call db_find_mc (snt.sp, "0"b, db_mc_ptr);

	else if cmc = "C"				/* get pointer to crawlout conditions */
	then call db_find_mc (snt.sp, "1"b, db_mc_ptr);


	else if cmc = "s" then do;
	     attach, open = "0"b;
	     if substr (il, lin+2, 1) = "i" then j = 1;
	     else if substr (il, lin+2, 1) = "o" then j = 2;
	     else go to skip;
	     lin = lin + 3;
	     i = verify (substr (il, lin, ill-lin+1), " ");
	     if i &gt; 1 then do;
		lin = lin + i - 1;

		i = search (substr (il, lin, ill-lin+1), " ;
");
		if i = 0 then i = ill;
		else i = lin + i -2;
		switch_name = substr (il, lin, i-lin+1);
		call check_switch;
		call iox_$find_iocb (switch_name, pp, code35);
		if code35 ^= 0 then goto switch_err;
		if pp -&gt; iocb.attach_descrip_ptr = null then do;
		     call ioa_$ioa_stream (debug_output, "^a switch not attached", switch_name);
		     goto skip;
		end;
		if pp -&gt; iocb.open_descrip_ptr = null then do;
		     call ioa_$ioa_stream (debug_output, "^a switch not open", switch_name);
		     goto skip;
		end;
	     end;
	     else do;
		if j = 1 then switch_name = "debug_input";
		else switch_name = "debug_output";
		call check_switch;			/* Is this the same switch? */
		call iox_$find_iocb (switch_name, pp, code35);
		if code35 ^= 0 then go to switch_err;
		if pp -&gt; iocb.attach_descrip_ptr = null then do;
		     call iox_$attach_ioname (switch_name, pp, "syn_ user_i/o", code35);
		     if code35 ^= 0 then go to switch_err;
		     attach = "1"b;
		end;

		if pp -&gt; iocb.open_descrip_ptr = null then do;
		     call iox_$open (pp, j, "0"b, code35);
		     if code35 ^= 0 then go to switch_err;
		     open = "1"b;
		end;
	     end;

	     if debug_io_open (j) then call iox_$close (debug_io_ptr (j), code35);
	     if debug_io_attach (j) then call iox_$detach_iocb (debug_io_ptr (j), code35);
	     debug_io_ptr (j) = pp;
	     debug_io_attach (j) = attach;
	     debug_io_open (j) = open;
	     if j = 1 then debug_input = switch_name;
	     else debug_output = switch_name;

	     go to skip;

switch_err:    call com_err_ (code35, "debug");
	     go to skip;
	end;

	else
no_comm:	call ioa_$ioa_stream (debug_output, "db");

	go to skip;

/*  */
/* come here if we are looking at a register command */

label_1 (4):
	do i = lin+1 to lin+4 while (is_name (ilp -&gt; bi.ts (i)));
	end;
	reg_name = substr (il, lin+1, i-lin-1);
	do i = lin+1 to ill while (substr (il, i, 1) ^= ";" &amp; substr (il, i, 1) ^= "=");
	end;
	if i &gt;= ill | substr (il, i, 1) ^= "=" then do;
	     if ill = lin + 1 then if substr (il, ill, 1) = new_line then goto syntax_error; /* avoid "$(nl)" */
	     call db_regs$print (db_mc_ptr, reg_name, print_mode);
	     go to skip;
	end;
	if ^get_char (i + 1, i, "") then goto syntax_error;
	temp_reg_val = db_get_count$double (il, i, lin);	/* is an assignment */
	if i = lin then goto syntax_error;
	if substr (il, lin, 1) = "|" then do;		/* pointer value, parse it */
	     call db_parse_arg$ptr_offset (il, lin, ill, binary (temp_reg_val, 17),
		addr (temp_reg_val), d_type, nv);
	     if d_type ^= 13 then go to syntax_error;
	end;

	reg_val = addr (temp_reg_val) -&gt; based_bit72;
	call db_regs$assign (db_mc_ptr, reg_name, reg_val, print_mode); /* assign a value to the register */
	go to skip;

/*  */
/* . handlers */

label_1 (13): label_2 (13):
	cmc = substr (il, lin+1, 1);
	if lin &gt;= ill then go to syntax_error;
	if cmc = "d" | cmc = "o" then go to offset1;
	if cmc = "n" then do;			/* next char escaped */
	     lin = lin+2;
	     go to offsetl;
	end;
	if cmc ^= data_id then new_type = 1; else new_type = 0;
	goto relative_offset;


/*  */
/* come here to set a break point */

label_1 (9): label_2 (9): label_3 (9):
	if data_id = "s" then tp = ptr (snt.pp, binary (rel (data_ptr))-binary (rel (snt.sp)));
	else tp = data_ptr;				/* force pointer to text if in stack */
	call db_break$set_break (tp, 0, sntp, print_mode); /* set the break */
	go to skip;

/*  */
/* come here when restarting a program */

label_1 (10): label_2 (10): label_3 (10):
	if stack_depth &gt; max_stack | stack_depth &lt; 0 then call ioa_$ioa_stream (debug_output, "No stack frame for given segment.");
	else do;
	     addr (goto_label) -&gt; label_map.pp = data_ptr;
	     addr (goto_label) -&gt; label_map.sp = snt.sp;
	     goto goto_label;
	end;
	go to rskip;


/* come here if scanning a number in a type 1 command */

label_1 (5):
	input_type = "a";				/* user typed an offset */
offset1:	offset = 0;
	goto relative_offset;

/*  */
/* come here when 'offset' has been established.  Search for an optional relative offset */

label_2 (4): label_2 (5):
label_1 (6): label_2 (6):
relative_offset:

	code = 0;
	continue = "1"b;
	do while (code = 0 &amp; continue);
	     if ^get_char (lin, lin, char) then continue = "0"b;
	     else do;

		if char = "&amp;" then do;
		     char = substr (il, lin+1, 1);
		     if char = "d" | char = "o" then do;
			offset = offset + db_get_count (il, lin, lin);
			call set_data_ptr (data_id);
		     end;
		     else do;
			if char ^= data_id then new_type = 1;
			else new_type = 0;
			if new_type = 1 then data_format = "h";
			if char = "p" then call parse_parameter (lin, code);
			else if char = "a" then call parse_source (lin, code);
			else if char = "n" then do;
			     lin = lin +2;
			     if lin &gt;= ill then goto syntax_error;
			     goto namel;
			end;
			else do;
			     call set_data_ptr (char);
			     if code = 0 then data_id = char;
			     lin = lin +2;
			end;
		     end;
		end;

		else do;
		     if char = "+" then offset_incr = db_get_count (il, lin + 1, lin);
		     else if char = "-" then offset_incr = - db_get_count (il, lin + 1, lin);
		     else if verify (char, NUMBER) = 0 then offset_incr = db_get_count (il, lin, lin);

		     else if char = "$" then do;
			do i = lin+1 to lin+4 while (is_name (ilp -&gt; bi.ts (i)));
			end;
			reg_name = substr (il, lin+1, i-lin-1);
			lin = i;
			call db_regs$get (db_mc_ptr, reg_name, reg_val, print_mode);
			offset_incr = binary (reg_val);
		     end;

		     else continue = "0"b;		/* must not be a relative offset */
		     if continue then do;
			offset = offset + offset_incr;
			call set_data_ptr (data_id);
		     end;
		end;
	     end;
	end;

	if code ^= 0 then do;
	     if code &gt; 0 then call ioa_$ioa_stream (debug_output, "^a for ^a", err_mess (code), snt.ent_name);
	     goto rskip;
	end;

	go to depth_4;


/* come here if changing output mode :	, [print mode] [amount to print] */

label_1 (7): label_2 (7): label_3 (7):

	call parse_print;
	goto print;

label_2 (12): label_3 (12):
label_1 (15): label_2 (15): label_3 (15):
print:
	if data_format = "n" then go to skip;
	pp = data_ptr;
	if data_id = "s" then nv = binary (rel (pp)) - binary (rel (snt.sp));
	else if data_id = "l" then nv = binary (rel (pp)) - binary (rel (snt.lp));
	else if data_id = "i" then nv = binary (rel (pp)) - binary (rel (snt.static_ptr));
	else nv = binary (rel (pp));

	call db_print (debug_io_ptr (2), debug_output, pp, data_format, nv, pc, sntp, d_type, max_size);
	go to skip;

/* come here when an equal sign is encountered */

label_1 (8): label_2 (8): label_3 (8):
	lin = lin + 1;
	pp = data_ptr;

/*	If the assignment is not to a program variable the default is octal.
   */
	if input_type = "v" then dec_default = "1"b;
	else dec_default = "0"b;
	call db_assign (il, lin, ill, pp, sntp, db_mc_ptr, d_type, pc, max_size, print_mode, dec_default);
	go to skip;


/*  INTERNAL PROCEDURES */
is_name:	proc (b9) returns (bit (1) aligned);

dcl  b9 fixed bin (8) unal, t fixed bin;

	     t = type (b9);
	     if t ^= 14 then if t ^= 5 then return ("0"b);
	     return ("1"b);

	end;
						/*  */
get_break_action_code: proc;

	     break_data_len,
		break_action_code,
		break_return = 0;
	     break_data_line = " ";


	     if cmc = "l" then break_action_code = 1;

	     else if cmc = "r" then break_action_code = 2;

	     else if cmc = "o" then break_action_code = 3;

	     else if cmc = "n" then break_action_code = 4;

	     else if cmc = "e"
	     then do;
		break_action_code = 5;
		break_data_len = ill-lin+1;
		if break_data_len = 1 then break_data_len = 0;
		else break_data_line = substr (il, lin, break_data_len);
		break_return = 1;
	     end;

	     else if cmc = "c"
	     then do;
		break_action_code = 6;
		call db_parse_condition$set (il, lin, ill, break_data_len, break_data_line, code);
		if code = 100 then goto syntax_error;
		if code ^= 0 then call ioa_$ioa_stream (debug_output, "Symbol error in conditional break.");
	     end;

	     else call ioa_$ioa_stream (debug_output, "Unknown break request");
	end get_break_action_code;

type:	proc (n) returns (fixed bin);

dcl  n fixed bin (8) unal;
dcl  table (0: 127) fixed bin static init
    ((10)0, 15, (21)0, 11, 0, 14, 0, 4, 2, 13, (3)0, 16, 6, 7, 6, 17, 3, (10)5, 1,
     12, 9, 8, 10, (2)0, (26)14, (4)0, 14, 0, (26)14, 0, 17, (3)0);

/* The table array has the following meaning:
   0 = illegal
   1 = :
   2 = %
   3 = /
   4 = $
   5 = number
   6 = + or -
   7 = ,
   8 = =
   9 = &lt;
   10 = &gt;
   11 = blank
   12 = ;
   13 = &amp;
   14 = letter
   15 = new-line
   16 = *
   17 = | or . */

	     if n &gt; -1 then if n &lt; 128 then return (table (n)); /* legal ascii value */
	     call ioa_$ioa_stream (debug_output, "invalid character ""^a""", substr (il, n, 1));
	     go to rskip;				/* error return */

	end type;


check_switch: proc;

/* 	This procedure compares the old switch name and the new switch name.  If they are the same
   *	a message is printed and the procedure exits to skip which looks for the next request.
   */
		if j = 1 then if switch_name ^= debug_input then return; else;
	     else if switch_name ^= debug_output then return;
	     call ioa_$ioa_stream (debug_output, "Switch already set to ^a", switch_name);
	     goto skip;

	end check_switch;

/*  This procedure prints the error message for db_sym and exits to rskip to
   *   find the next db request.
*/

sym_err:	proc;

dcl  mess char (80) var;

	     mess = "";
	     if code = 1 then mess = "Symbol " || sym_name || " not found for " || snt.ent_name;
	     else if code = 2 then mess = "No symbol table for " || snt.ent_name;
	     else if code = 3 then mess = "No linkage section for " || snt.ent_name;
	     else if code = 4 then mess = "No stack frame for " || snt.ent_name;
	     else if code = 5 then mess = "Cannot get address of " || sym_name;
	     else if code = 6 then mess = "Cannot get size of " || sym_name;
	     else if code = 7 then go to syntax_error;
	     else if code = 8 then mess = "Subscripting error in " || sym_name;
	     else if code = 9 then mess = "Invalid subscript in " || sym_name;
	     else if code = 10 then mess = "Based variable error in " || sym_name;
	     else if code = 11 then mess = "Too many structure levels in " || sym_name;
	     else if code = 12 then mess = "Symbol is too long " || sym_name;
	     else if code = 13 then mess = "Reference is ambiguous " || sym_name;
	     else if code = 14 then mess = sym_name || " is entry constant; not supported";
	     else if code = 15 then mess = "Symbol table for this language is not supported by debug.";

	     if mess ^= "" then call ioa_$ioa_stream (debug_output, mess);
	     go to rskip;

	end sym_err;

/*  This procedure searches for the next non-blank character in the line beginning with index.
   It returns "0"b if the rest of the line is blank.  Otherwise it returns "1"b, the index and the character
   found.
*/
get_char:	proc (index_in, index_out, char_out) returns (bit (1));

dcl  index_in fixed bin;
dcl  index_out fixed bin;
dcl  char_out char (1) aligned;
dcl  i fixed bin;

	     index_out = index_in;
	     if index_out &lt; ill then do;
		i = verify (substr (il, index_out, ill - index_out +1), " ");

		if i &gt; 0 then do;
		     index_out = index_out + i -1;
		     char_out = substr (il, index_out, 1);
		     if char_out ^= ";" &amp; char_out ^= new_line then return ("1"b);
		end;
		else index_out = ill;
	     end;

	     return ("0"b);

	end get_char;

/*  */

parse_print: proc;

dcl  i fixed bin;
dcl  size fixed bin;
dcl (have_mode, have_size, have_count) bit (1);

	     have_mode, have_size, have_count = "0"b;

	     do while (get_char (lin+1, lin, char));

/* (&lt;size&gt;)  */
		if char = "(" then do;
		     if ^have_size then do;
			have_size = "1"b;
			i = db_get_count$dec (il, lin+1, lin);
			if i &gt; 0 then do;
			     if get_char (lin, lin, char) then do;
				if char = ")" then do;
				     size = i;
				     goto next;
				end;
			     end;
			end;
		     end;
		     goto syntax_error;
		end;

/* &lt;amount to print&gt;  */
		else if index (NUMBER, char) &gt; 0 then do;
		     if have_count then goto syntax_error;
		     pc = db_get_count$dec (il, lin, lin);
		     pc = max (pc, 1);
		     have_count = "1"b;
		     lin = lin -1;
		end;

/* &lt;mode&gt;   Set mode and default size.  A change in mode causes the amount to print to be set to 1 */
		else do;
		     if substr (il, lin, 1) = "n" then goto skip;
		     do i = 1 to hbound (MODES, 1)
			     while (substr (il, lin, length (MODES (i))) ^= MODES (i));
		     end;
		     if i &gt; hbound (MODES, 1) then do;
			call ioa_$ioa_stream (debug_output, "Undefined output mode ""^a""", substr (il, lin, 1));
			goto rskip;
		     end;
		     data_format = MODES (i);
		     lin = lin + length (MODES (i)) -1;
		     if data_format = "p" then max_size = 72;
		     else if data_format = "comp-7" then max_size = 18;
		     else if data_format = "el" | data_format = "fl" then max_size = 72;
		     else max_size = 36;
		     if ^have_count then pc = 1;
		end;
next:
	     end;

/* data_format and pc have been set.  Only set size if it is valid.  */

	     if have_size then do;
		if data_format = "p" &amp; ^(size = 36 | size = 72) then do;
		     call ioa_$ioa_stream (debug_output, "Invalid size for pointer.  Use 36 or 72");
		     goto rskip;
		end;
		else if data_format = "comp-8" | data_format = "comp-5" then max_size = divide (size*9, 2, 17, 0);
		else max_size = size;
	     end;
	end parse_print;

/*  */
/*  This procedure parses &amp;p requests and sets the data_ptr and offset and pc (data size).
   code = 0			Pointer was found to the argument.
   code = err_no_stack		No stack frame, so no parameter list.
   code = -1			Illegal number for argument poaition.

   index			(input) Set to start of string "&amp;p"
   (output) Set to first character not used in parse
*/
parse_parameter: proc (index, code);

dcl  index fixed bin;
dcl  code fixed bin;

	     i = db_get_count$dec (il, index+2, index);
	     if snt.sp = null then code = err_no_stack;
	     else do;
		if snt.sp -&gt; stack_frame.arg_ptr = null then code = err_no_stack;
		else do;
		     if i &lt;= 0 | i &gt; binary (snt.sp -&gt; stack_frame.arg_ptr -&gt; arg_list.num_args, 17) then do;
			call ioa_$ioa_stream (debug_output, "No parameter ^d.", i);
			code = -1;		/* no error message, but error return */
		     end;
		     else do;
			call decode_descriptor_ (snt.sp -&gt; stack_frame.arg_ptr, i, code, switch, ndims, size, scale);
			data_ptr = snt.sp -&gt; stack_frame.arg_ptr -&gt; arg_list.args (i);
			offset = binary (rel (data_ptr), 18);
						/* COBOL data codes */
			if code = 38 | code = 39 | code = 41 then do;
			     pc = 1;
			     if code = 41 then data_format = "comp-8";
			     else data_format = "comp-5";
			     if code = 38 then size = divide (size*9, 2, 17, 0);
			     else size = divide ((size+1)*9, 2, 17, 0);
			end;
			else if code &gt; 0 then do;
			     data_format = substr ("dhffdhfhhhhhphpphbbaah", code, 1); /* decode type into mode */
			     if code = 2 then pc = 2; /* if double precision fixed point */
			     else if code = 5 then pc = 2; /* complex fixed short */
			     else if code = 7 then pc = 2; /* complex float short */
			     else if code = 15 then pc = 2; /* label variable */
			     else if code = 16 then pc = 2; /* entry variable */
			     else if data_format = "a" then do;
				if code = 22 then pc = max (0, addrel (data_ptr, -1) -&gt; based_fix);
				else pc = size;
			     end;
			     else if data_format = "b" then if code = 19 then pc = size;
				else pc = max (0, addrel (data_ptr, -1) -&gt; based_fix);
			     data_id = "p";
			end;
			code = 0;
		     end;
		end;
	     end;
	     return;

	end parse_parameter;
						/*  */
						/*  This procedure sets offset and data_ptr to the text beginning at a given source line.
						   code = 0		Was able to set the pointer to object code for line number.

						   data_ptr  = location of first instruction on the line.
						   data_format = "s"   (db_print mode for source code )
						   data_id   = "t"   (segment_ID is &amp;t for text )

						   code = no_sym_tab	The procedure was not compiled with the table option.
						   code = -1		No code generated for 10 lines after the line number requested.
						   */
parse_source: proc (index, code);

dcl  index fixed bin;
dcl  code fixed bin;

	     line_number = db_get_count$dec (il, index+2, index);
	     if snt.symflag then call db_get_sym (sntp);
	     tp = snt.symp;				/* get pointer to symbol table */
	     if (^snt.std &amp; tp = null) | snt.headp = null then code = err_no_sym_tab;
	     else do;
		switch = "0"b;
		do line_number = line_number to line_number + 10 while (code = 0);
		     if snt.std then offset = stu_$get_runtime_location (snt.headp, line_number);
		     else call stu_$get_location (snt.symp, line_number, offset);
		     if offset = -2 then code = err_no_sym_tab;
		     else do;
			if offset &gt;= 0 then do;	/* if positive offset, ok */
			     data_id = "t";
			     data_ptr = ptr (snt.pp, offset);
			     data_format = "s";
			     if switch then call ioa_$ioa_stream (debug_output, "Using line number ^d.", line_number);
			     return;
			end;
			else switch = "1"b;
		     end;
		end;
		if code = 0 then do;
		     code = -1;
		     call ioa_$ioa_stream (debug_output, "debug: No code generated for 10 lines after ^d.", line_number - 11);
		end;
	     end;

	     return;

	end parse_source;
						/*  */
set_data_ptr: proc (segment_id);

dcl  segment_id char (1) aligned;

	     if segment_id = "t" then data_ptr = ptr (snt.pp, offset);
	     else if segment_id = "s" then do;
		if snt.sp = null then code = err_no_stack;

		else do;
		     data_ptr = addrel (snt.sp, offset);
		end;

	     end;
	     else if segment_id = "l" then do;
		if snt.pp = null () then code = err_no_linkage;
		else do;
		     snt.lp = ptr (baseptr (stack_header.lot_ptr -&gt; lot (binary (baseno (snt.pp))).segno),
			stack_header.lot_ptr -&gt; lot (binary (baseno (snt.pp))).offset);
		     if rel (snt.lp) = "0"b then code = err_no_linkage;
		     else do;
			data_ptr = addrel (snt.lp, offset);
		     end;
		end;
	     end;

	     else if segment_id = "i" then do;
		if snt.pp = null () then code = err_no_static;
		else do;
		     snt.static_ptr = ptr (baseptr (stack_header.isot_ptr -&gt; lot (binary (baseno (snt.pp))).segno),
			stack_header.isot_ptr -&gt; lot (binary (baseno (snt.pp))).offset);
		     if rel (snt.static_ptr) = "0"b then code = err_no_static;
		     else do;
			data_ptr = addrel (snt.static_ptr, offset);
		     end;
		end;
	     end;

	     else do;
		call ioa_$ioa_stream (debug_output, "bad segment ID ""^a""", segment_id);
		code = -1;
	     end;
	end set_data_ptr;

/*  */
/* * This procedure parses the trace stack request.
   *	.tN,M	where N is the number of the first frame to print and M is the number of frames to be printed.
   *
   * It uses global variables:
   *	lin	input	= index of "." on line
   *		output	= index of last character used for trace stack request
*/
stack_trace: proc ();

dcl (i, start, last) fixed bin;
dcl  ent_name char (32) aligned;
dcl 1 trace_snt aligned like snt;
dcl  trace_snt_ptr ptr;

	     trace_snt_ptr = addr (trace_snt);
	     start = 0;
	     last = max_stack;

	     lin = lin + 2;
	     if verify (substr (il, lin, 1), NUMBER) = 0 then start = db_get_count$dec (il, lin, lin);
	     if substr (il, lin, 1) = "," then last = start + db_get_count$dec (il, lin+1, lin) -1;
	     start = max (0, start);
	     start = min (start, max_stack);
	     last = min (last, max_stack);

	     if print_mode = 1
	     then call ioa_$ioa_stream (debug_output, "^/DEPTH  SEGNO  OFFSET  ^5xNAME^20xCONDITION^/");

	     do i = start to last;
		call db_fill_snt (stack_ptr_array (i), trace_snt_ptr); /* get data for this stack frame */
		if is_condition_frame_ (trace_snt.sp) then do;
		     call find_condition_info_ (trace_snt.sp, addr (cond_info), code);
		     ent_name = cond_info.condition_name;
		end;
		else ent_name = "";
		call ioa_$ioa_stream (debug_output, " ^4d  ^5o  ^6o  ^a|^o^2-^a",
		     i, binary (baseno (trace_snt.pp), 15), binary (rel (trace_snt.sp), 18),
		     trace_snt.ent_pt_name, binary (rel (trace_snt.pp), 18), ent_name);
	     end;

	end stack_trace;

     end db_parse;




		    db_parse_arg.pl1                11/04/82  1959.8rew 11/04/82  1628.7       59238



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


db_parse_arg: proc (il, lin, ill, retp, type, size);

dcl  l fixed bin;

dcl  il char (132) aligned,				/* input character string to be scanned */
     conversion bit (1) aligned,
     lin fixed bin,					/* starting index into il */
     ill fixed bin,					/* length of il */
     retp ptr,					/* pointer to location in which to return arg */
     type fixed bin,				/* type of returned arg */
     size fixed bin;				/* size in chars or bits of returned arg */

/* types handled:

   1 fixed bin (octal or decimal)
   3 float bin
   13 pointer
   19 bit string
   21 char string
   0 variable
   -1 no arg error
   -2 syntax error
   -3 % in string

   */

dcl (bit, fixed, addrel, substr, mod, ptr) builtin;

dcl  db_conversion condition;

dcl  neg fixed bin;

dcl  work char (80);
dcl  bstr bit (size) based (retp) aligned,
     cstr char (size) based (retp) aligned,
    (i, j, cstrt, k, depth) fixed bin,
     nl char (1) aligned static init ("
"),
    (temp, temp1) float bin,
     fword fixed bin based,
     flword float bin based,
     c1 char (1) aligned,
     bptr ptr based,
     db_get_count$data ext entry (char (132) aligned, fixed bin, fixed bin, ptr, fixed bin, fixed bin),
     db_get_count ext entry (char (132) aligned, fixed bin, fixed bin) returns (fixed bin),
     db_get_count$dec ext entry (char (132) aligned, fixed bin, fixed bin) returns (fixed bin);

dcl  assign_ ext entry (ptr, fixed bin, fixed bin, ptr, fixed bin, fixed bin);
%include its;
/*  */

	type = -1;				/* initialize return args */
	size = 0;
	neg = 0;

	do i = lin to ill while (substr (il, i, 1) = " "); /* skip leading blanks */
	end;
	if i &gt;= ill then go to ERROR;			/* syntax error if off end of string */

	c1 = substr (il, i, 1);			/* get first character of argument */
	if c1 = ")" | c1 = ";" then return;		/* must signal no arg error */

	if c1 = "&amp;" then do;			/* decimal fixed bin */
	     if substr (il, i+1, 1) = "n" then do;
		i = i + 2;
		go to is_var;
	     end;
	     if substr (il, i+1, 1) = "d" | substr (il, i+1, 1) = "o" then go to get_fixed;
	     else go to ERROR;
	end;

	if c1 = "." then do;			/* decimal # or floating # */
	     call get_float;
	end;

	if c1 = """" then do;			/* bit or char string */
	     cstrt = 0;
scan_end_chars:
	     do j = i+1 to ill while (substr (il, j, 1) ^= """"); /* look for end of string */
	     end;
	     if j &gt;= ill then go to ERROR;		/* syntax error */
	     size = j - i - 1;			/* get size of string */
	     if substr (il, j+1, 1) = "b" then do;	/* bit string */
		if cstrt ^= 0 then go to ERROR;	/* have found doubled quotes in it */
		bstr = "0"b;			/* set to zeros to start */
		do k = 1 to size;			/* set each one bit ON */
		     if substr (il, i+k, 1) = "1" then substr (bstr, k, 1) = "1"b;
		end;
		type = 19;
		lin = j+2;
		return;
	     end;
						/* check here for "" in char string */
	     if substr (il, j+1, 1) = """" then do;
		substr (cstr, cstrt+1, size+1) = substr (il, i+1, size+1); /* copy string ending with " */
		i = j + 1;			/* remember where in scan we are */
		cstrt = cstrt+size+1;		/* update filled in offset in output string */
		go to scan_end_chars;		/* and scan for closing " */
	     end;

	     substr (cstr, cstrt+1, size) = substr (il, i+1, size); /* copy string */
	     size = cstrt+size;			/* and remember final size for caller */
	     type = 21;
	     lin = j + 1;
	     return;
	end;

	if verify (c1, "-+0123456789") = 0 then do;
get_fixed:   j = db_get_count$dec (il, i, lin);		/* assume afixed binary no. */
	     if i = lin then go to ERROR;
	     if substr (il, lin, 1) = "." | substr (il, lin, 1) = "e" then call get_float;
	     else if substr (il, lin, 1) = "|" then do;
		j = db_get_count (il, i, lin);	/* rescan in octal for segment no. */
		call get_offset;
	     end;
	     type = 1;
	     retp -&gt; fword = j;
	     go to RETURN;
	end;

	if c1 = "%" then do;			/* dummy argument */
	     type = -3;
	     lin = i+1;				/* set up return arg */
	     c1 = substr (il, lin, 1);
	     if verify (c1, ", );") ^= 0 then go to ERROR;
	     return;
	end;

is_var:	depth = 0;				/* argument must be a variable */
	do lin = i+1 to ill;			/* scan char by char */
	     c1 = substr (il, lin, 1);		/* pick up current character */
	     if verify (c1, "0123456789 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ._") = 0 then go to endl;
	     if c1 = "(" then depth = depth + 1;
	     if c1 = ")" then do;
		if depth &gt; 0 then depth = depth - 1;
		else go to done;
	     end;
	     else if c1 = "-" then do;
		if substr (il, lin+1, 1) = "&gt;" then lin = lin + 1;
		else if depth = 0 then go to done;
	     end;
	     else if depth = 0 then go to done;
endl:	end;
	go to ERROR;
done:	
	size = lin - i;				/* get length of variable name */
	cstr = substr (il, i, size);			/* copy name into return area */
	type = 0;
RETURN:	return;

ERROR:	type = -2;
	return;




ptr_offset: entry (il, lin, ill, base_val, retp, type, size);

/* entry to parse the offset portion of a pointer whose seg. no. is known */

dcl  base_val fixed bin;

	j = base_val;
	call get_offset;


get_float: proc;
	     call db_get_count$data (il, i, lin, retp, 6, 35);
	     if i = lin then go to ERROR;;
	     type = 3;
	     go to RETURN;
	end get_float;

get_offset: proc;

	     k = db_get_count (il, lin+1, lin);		/* get offset */
	     retp -&gt; bptr = ptr (baseptr (j), k);	/* create and return pointer */
	     type = 13;
	     if substr (il, lin, 1) = "(" then do;	/* bit offset given */
		j = db_get_count$dec (il, lin+1, lin);
		retp -&gt; bptr = addrel (retp -&gt; bptr, divide (j, 36, 18, 0)); /* maybe bit offset &gt; 36 */
		retp -&gt; its.bit_offset = bit (fixed (mod (j, 36), 6)); /* stuff in bit offset */
		if substr (il, lin, 1) ^= ")" then go to ERROR;
		lin = lin + 1;			/* skip over last ")" */
	     end;
	     if substr (il, lin, 1) = "["
		then do;
		l = db_get_count$dec (il, lin+1, lin);
		if l &gt; 7 then go to ERROR;
		retp -&gt; its.ringno = bit (fixed (l, 3), 3);
		if substr (il, lin, 1) ^= "]" then go to ERROR;
		lin = lin + 1;
	     end;
	     go to RETURN;

	end get_offset;


     end;
��



		    db_parse_condition.pl1          11/04/82  1959.8rew 11/04/82  1628.7       79047



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


db_parse_condition:	procedure;


/*	This procedure is called to parse condition data involved with a conditional break.
*	This procedure was created so that semantic considerations would not be present
*	in  db_break.
*
*	Written in  Dec 72  for the  6180  by  Bill Silver.
*/



dcl	arg_cond_ptr	ptr,		/* Pointer to condition data passed as an
					*  argument.  */

	break_map_ptr	ptr,		/* Pointer to the segments break map. */

	cond_data		char(236),	/* Return area where condition data is
					*  actually built.  */

	cond_len		fixed bin,	/* Actual size of the condition data.
					*  0 =&gt; no condition.  */

	sntp		ptr;		/* Pointer to debug's  snt data.  */


dcl	il	char(132)  aligned,
	(lin, ill, acode)	  fixed bin;


dcl	cond_flag		fixed bin;	/* Return flag indicating whether condition
					*  was met or not.  0 =&gt; YES, 1 =&gt; NO. */


dcl	return_string	char(72) var;	/* Used to return compare line. 


/*	This constant indicates the size of the whole condition data area.  */

dcl	cond_size		fixed bin	    init(224)	internal static;



dcl	cond_ptr	ptr;		/* Pointer to the condition data. */


dcl  1 cond_map	based ( cond_ptr )  aligned,
    (2 relation,				/* Relation between two variables.
					*  1 =&gt;  "=",  2 =&gt; "^=".  */
     2 p1,				/* offset of first comparand */
     2 p2,				/* ditto for 2nd (both are -1 if variable) */
     2 lname1,				/* length of name1 */
     2 lname2) fixed bin,			/* length of name2 */
     2 (name1,name2) char(40),		/* names of variables used in comparison */
     2 compare char(64) aligned,		/* contents of compare line for cond. break */
     2 (constant1,constant2) bit(288) aligned;	/* constants used in comparison */



dcl (tp1,tp2,tp) ptr;

dcl
     db_sym ext entry (char (72) var,ptr,ptr,fixed bin, fixed bin,
		char(1) aligned, char(*) aligned, fixed bin, fixed bin, fixed bin(35)),
     ioa_$ioa_stream ext entry options(variable),
     db_parse_arg ext entry (char (132) aligned,fixed bin,fixed bin,ptr,fixed bin,fixed bin);

%include db_ext_stat_;

dcl
     (i,j) 	fixed bin,
     code 	fixed bin(35),
     exec 	fixed bin,
      l		fixed bin,
     no		fixed bin,
     old_value 	fixed bin,
     pc 		fixed bin,
     pflag	fixed bin,
     t2 		fixed bin,
     temp 	fixed bin,
     relation 	fixed bin;

dcl	pcm	fixed bin;
dcl	cp	ptr;


dcl	char1 (32)	char(1)	based,

	char32		char(32)	based;

dcl
    (c1,c2) char (1) aligned,
     bits bit(pc) based,
     n1 char(72) var,
     str char (exec) based;


dcl
     addr builtin,
     fixed builtin,
     null builtin,
     ptr builtin,
      rel builtin,
     substr builtin,
     unspec builtin;
/*  */
check:	entry ( break_map_ptr, arg_cond_ptr, sntp, cond_flag );


/*	This entry is called by  db_break to determine if the condition of the specified
*	break has been met.  The answer will be returned in cond_flag where:
*	0  =&gt; YES,  and  1 =&gt; NO.  Note, in the case of an error the  cond_flag  will
*	be set to  0.
*/


	cond_ptr  =  arg_cond_ptr;		/* Copy argument pointer. */

	pc = 36;				/* Default size to compare is 1 word. */
	cond_flag  =  0;			/* Initialize return arg. */

	relation  =  cond_map.relation;

	     i = cond_map.p1;			/* get default pointer to data */
	     if i &lt; 0 then do;
		n1 = substr(cond_map.name1,1,cond_map.lname1);
		if substr (n1,1,1) = "(" then do;		/* got a numeric pointer (xxx|yyy) */
		     call db_parse_arg((n1),2,cond_map.lname1,addr(cond_map.constant1),j,exec);
		     if substr(cond_map.constant1,31,6) ^= "100011"b then go to badcond;  /* not  "43" its pair */
		     unspec(tp1) = substr(cond_map.constant1,1,72);
		     go to next_constant;
		end;
		call db_sym(n1,sntp,tp1,temp,t2,c1,c2,pc,pcm,code); /* get pointer to first data item */
		if code ^= 0 then do;
badcond:		     call ioa_$ioa_stream (debug_output, "Error in conditional break.");
			return;
		end;
		if c2 = "a" then pc = pc * 9;
		else if c2 = "p" then pc = 72;
	     end;
	     else tp1 = addr(cond_map.constant1);
next_constant:
	     i = cond_map.p2;
	     if i &lt; 0 then do;
		n1 = substr(cond_map.name2,1,cond_map.lname2);
		call db_sym(n1,sntp,tp2,temp,t2,c1,c2,pc,pcm,code);
		if code ^= 0 then go to badcond;
		if c2 = "a" then pc = pc * 9;
		else if c2 = "p" then pc = 72;
	     end;
	     else tp2 = addr(cond_map.constant2);


	     if tp1 -&gt; bits = tp2 -&gt; bits then do;		/* make compare */
		if relation = 2 then cond_flag = 1;		/* if looking for not equal we lose */
		return;
	     end;
	     if relation = 1 then cond_flag = 1;		/* lose if looking for equal */


	return;
/*  */
print_line:	entry ( arg_cond_ptr, return_string );


/*	This entry is called by  db_break  in order to get a string of data which it
*	can print about a condition.
*/


	return_string  =  arg_cond_ptr -&gt; cond_map.compare;


	return;
/**/
set:	 entry(il,lin,ill,cond_len,cond_data,acode);


/*	This entry is called  to parse the condition line entered by the user and
*	to convert this input line into the appropriate condition data.  The condition
*	data will then be returned to the caller ( db_parse ).
*/



	acode = 0;				/* zero out return error code */
	pflag = 0;				/* reset pointer relation flag */

	cond_ptr  =  addr(cond_data);			/* We will build the condition data
						*  in our own area.  */

	pc = 36;					/* default number of bits to compare */
	if ill &lt;= lin then do;			/* resetting conditional break ? */
		cond_len  =  0;		/* YES, reset condition. */
		cond_data  =  " ";
	     return;
	end;
	cond_map.compare = substr(il,lin,ill-lin);	/* save compare line */
	tp = addr(cond_map.constant1);		/* default pointer to constant area */
	call db_parse_arg(il,lin,ill,tp,j,exec);		/* pick off first argument */
	if j = 0 then do;				/* a variable */
	     cond_map.name1 = tp -&gt; str;		/* copy name of variable into break */
	     if tp -&gt; char1(1) = "/" then		/* test for pointer */
	       if substr(il,lin,1) = "/" then do;	/* handle form /xxx/yyyy */
		pflag = 1;			/* set flag for pointer case */
		cp = addr(il);			/* get pointer to original string */
		tp -&gt; char1(1) = "(";		/* start change of form to (xxx|yyyy) */
		tp -&gt; char1(exec + 1) = "|";
		do l = 1 to ill - lin while (cp-&gt;char1(lin + l) &gt;= "0" &amp;
					cp-&gt;char1(lin + l) &lt;= "7");
		     tp -&gt; char1(l + exec + 1) = cp -&gt; char1(lin + l);
		end;

		exec = exec + l + 1;
		lin = lin + l;
		tp -&gt; char1(exec) = ")";
		cond_map.name1 = substr(tp-&gt;char32,1,exec);
	       end;
	     cond_map.lname1 = exec;
	     cond_map.p1 = -1;			/* indicate we've got a variable */
	end;
	else if j &lt; 0 then do;			/* syntax error */
ser:	     acode = 100;				/* special error code indicates syntax error */
	     return;
	end;
	else cond_map.p1 = 1;		/* Filll in offset of constant area */

skip_blanks:	do lin = lin to ill while(substr(il,lin,1) = " "); /* skip blanks */
	end;
	if lin &gt;= ill then go to ser;
	if pflag = 1 then				/* are we handling pointer relation */
	  if substr(il,lin,2) ="&amp;t" then		/* is it valid */
	    do;
	     pflag = 0;
	     lin = lin + 2;				/* start beyond the "&amp;t" */
	     go to skip_blanks;			/* scan for next symbol */
	    end;
	    else go to ser;			    	/* incorrect syntax for pointer relation */
	if substr(il,lin,1) = "=" then relation = 1;	/* get compare relation */
	else if substr(il,lin,2) = "^=" then do;	/* not-equal compare relation */
	     relation = 2;
	     lin = lin + 1;				/* one more character to skip */
	end;
	else do;					/* bad compare relation */
	     call ioa_$ioa_stream (debug_output, "Only ""="" and ""^^="" allowed.");
code0:	     acode = 100;
	     return;
	end;

	lin = lin + 1;				/* scan over (rest of) compare relation */
	tp = addr(cond_map.constant2);		/* set default pointer */
	call db_parse_arg(il,lin,ill,tp,j,exec);		/* get second argument */
	if j = 0 then do;				/* a variable */
	     cond_map.name2 = tp -&gt; str;		/* copy name of variable into break */
	     cond_map.lname2 = exec;
	     cond_map.p2 = -1;			/* indicate we've got variable */
	end;
	else if j &lt; 0 then go to ser;
	else cond_map.p2 = 2;
	cond_map.relation  =  relation;			/* Save relation for when condition
						*  is tested.  */


/*	Now return condition line we have just made.  Return the actual number of
*	characters used.  The rest of the are will just be blank.
*/

	cond_len  =  cond_size;



	end	db_parse_condition;
�



		    db_print.pl1                    11/04/82  1959.8rew 11/04/82  1628.8      155106



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


db_print: proc (arg_iocb_ptr, arg_output_switch, data_ptr, mode, rel_offset, arg_no_prt, sntp, data_type, data_size);

/* Modified 10/76 by S. Barr to add COBOL data types and to use data_size with octal format */
/* Modified 1/77 by S. Barr to add number to print to "l" mode */
/* Modified 771116 by PG to add el &amp; fl output modes */

/* parameters */

dcl  arg_iocb_ptr ptr;				/* arg_iocb pointer for iox_ ioa_ calls */
dcl  arg_output_switch char (32);			/* for print_text_ (to be removed eventually) */
dcl  data_type fixed bin;
dcl  data_size fixed bin;
dcl  data_ptr ptr,
     mode char (*) aligned,
    (rel_offset, arg_no_prt) fixed bin;

/* entries */

dcl
     print_text_ ext entry (ptr, fixed bin, char (*) aligned),
     db_get_sym ext entry (ptr),
     get_wdir_ ext entry returns (char (168) aligned),
     ioa_$ioa_switch entry options (variable),
     ioa_$ioa_switch_nnl entry options (variable),
     ioa_$rsnnl entry options (variable),
     db_line_no ext entry (ptr, fixed bin, fixed bin, fixed bin, fixed bin);
dcl  comp_8_to_ascii_ entry (bit (*), char (*));
dcl  gr_print_ entry (char (*));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  stu_$get_line entry (ptr, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin);
dcl  com_err_ entry options (variable);
dcl  condition_ entry (char (*), entry);
dcl  reversion_ entry (char (*));

/* automatic &amp; based */

dcl  string char (64),
     num fixed bin,
     iocb_ptr ptr,
     output_switch char (32) aligned;			/* output_switch: default is user_output */

dcl
     i9 fixed bin (9),
    (no_prt, j, k, first, line_no, no, okp) fixed bin,
     code fixed bin (35),
     i fixed bin;


dcl  line_offset fixed bin;				/* char. position of source line */
dcl  line_length fixed bin;				/* length of source line */
dcl  file fixed bin;				/* file containing source line */

dcl  smap_ptr ptr;
dcl  packed_ptr ptr unal based (pp);
dcl  packed_bit_offset bit (6) based (pp);

dcl  hp ptr;
dcl  pp ptr,
     based_ptr ptr based;

dcl
     bits bit (arg_no_prt) based (pp),
     cbit_offset char (8) aligned,
     str char (no_prt) based (pp);

dcl 1 copy_its aligned like its ;


dcl  format char (20) var aligned init ("^6o ^6o ^v(^");
dcl  per_line fixed bin init (4);			/* no. of items per line */
dcl  octal bit (1) init ("0"b);			/* 1 = octal print out */
dcl  packed_decimal bit (1) init ("0"b);		/* 1 = packed_decimal format */
dcl  float bit (1) init ("0"b);			/* 1 = float binary data */
dcl (offset, loc) fixed bin;
dcl 1 ff aligned based (pp),
    2 (w0, w1, w2, w3, w4) fixed bin (35);
dcl  print_err bit (1) init ("1"b);			/* 1 = print error message */

/* builtins */

declare (addr, addrel, baseno, binary, divide, fixed, max, min, null, ptr, rel, substr, mod, unspec, hbound) builtin;

/* external static */

dcl  iox_$user_output ptr ext;

/* internal static */

dcl  bit_loc (8) int static options (constant) init (0, 5, 9, 14, 18, 23, 27, 32);
dcl  last_source char (32) static init (" ");		/* last source used for printing */
dcl  MODES (21) char (6) static init ("a", "b", "p", "P", "i", "I", "l", "s", "o", "h", "d", "f", "e", "g",
     "x", "comp-6", "comp-7", "comp-8", "comp-5", "fl", "el");

/* include files */

%include component_info;
%include db_snt;
%include its;
%include std_symbol_header;
%include source_map;

/* program */

	if arg_iocb_ptr = null then do;
	     iocb_ptr = iox_$user_output;
	     output_switch = "user_output";
	end;
	else do;
	     output_switch = arg_output_switch;
	     iocb_ptr = arg_iocb_ptr;
	end;

	no_prt = max (1, arg_no_prt);			/* get number of units to print */
	pp = data_ptr;				/* get pointer to first word to be printed */
	offset = rel_offset;			/* get offset within stack or linkage */
	loc = fixed (rel (pp), 17);

	call condition_ ("out_of_bounds", oob_handler);

	do j = 1 to hbound (MODES, 1) while (mode ^= MODES (j));
	end;
	if j &gt; hbound (MODES, 1) then do;
	     call ioa_$ioa_switch (iocb_ptr, "Undefined output mode ""^a""", mode);
	     return;
	end;

	goto label (j);

/* a, x	character string */
label (1):
label (15):

	call ioa_$ioa_switch_nnl (iocb_ptr, "^6o ^6o """, loc, offset);

	if arg_no_prt &gt; 0 then do;
	     call iox_$put_chars (iocb_ptr, pp, arg_no_prt, code);
	     if code ^= 0 then call com_err_ (code, "debug");
	end;
	call ioa_$ioa_switch (iocb_ptr, """");
	return;

/*  b	bit string */
label (2):
	call ioa_$ioa_switch (iocb_ptr, "^6o ^6o ""^b""b", loc, offset, bits);
	return;

/* p, P	pointer */
label (3):
label (4):

	if data_size = 36 then no = 1;
	else no = 2;

	do j = 1 to no_prt;

	     if no = 2 then do;
		if pp -&gt; its.its_mod ^= "100011"b | pp -&gt; its.mod
		then call ioa_$ioa_switch (iocb_ptr, "^6o ^6o  ^w ^w", loc, offset, w0, w1);
		else do;
		     i9 = fixed (pp -&gt; its.bit_offset, 9); /* get bit offset of pointer */
		     if i9 ^= 0 then call ioa_$rsnnl ("(^d)", cbit_offset, okp, i9); /* convert it to character */
		     else cbit_offset = "";
		     call ioa_$ioa_switch (iocb_ptr, "^6o ^6o  ^o|^o^a", loc, offset, fixed (baseno (pp -&gt; based_ptr), 18), fixed (rel (pp -&gt; based_ptr), 18), cbit_offset);
		end;
	     end;

	     else do;
		if binary (packed_bit_offset) &gt; 35
		then call ioa_$ioa_switch (iocb_ptr, "^6o ^6o  ^w", loc, offset, pp -&gt; w0);
		else call ioa_$ioa_switch (iocb_ptr, "^6o ^6o  ^p", loc, offset, packed_ptr);
	     end;

	     pp = addrel (pp, no);
	     loc = loc + no;
	     offset = offset + no;
	end;
	return;

/*  i, I	instruction */
label (5):
label (6):
	if sntp = null then okp = 0;			/* ol_dump calls without snt table */
	else okp = 1;				/* Try to get line numbers */
	j = 0;

	do while (j &lt; no_prt);

	     if okp = 1 then do;			/* try to get source line */

		call db_line_no (sntp, loc, first, no, line_no);
		if first &lt; 0 then do;		/* can't find source line no. */
		     okp = 0;
		     no = no_prt - j;
		end;
		else do;
		     call ioa_$ioa_switch (iocb_ptr, "LINE NUMBER ^d", line_no);
		     no = no - loc + first;		/* In case loc is in middle of line */
		end;
	     end;
	     else no = no_prt;

	     no = min (no, no_prt - j);
	     call print_text_ (pp, no, output_switch);
	     loc = loc + no;
	     pp = addrel (pp, no);
	     j = j + no;
	end;
	return;

/*  l	instructions for a given line */
label (7):
	do j = 1 to no_prt;
	     call db_line_no (sntp, loc, first, no, line_no);
	     if first &lt; 0 then goto ERROR_NO_LINE;
	     call ioa_$ioa_switch (iocb_ptr, "LINE NUMBER ^d", line_no);
	     call print_text_ (ptr (pp, first), no, output_switch);
	     loc = loc + no;
	end;

	return;

/*  s	source line */
label (8):
	call print_source;
	return;

/*  o, h	octal */
label (9):
label (10):
	octal = "1"b;
	format = format || ".3b ^)";
	if mode = "o" then per_line = 8;
	call print_data;
	return;

/*  d, comp-6, comp-7	decimal */
label (11):
label (16):
label (17):
	format = format || "13d^)";
	call print_data;
	return;

/*  f	float binary */
label (12):
	float = "1"b;
	format = format || "8.4f^)";
	call print_data;
	return;

/*  e */
label (13):
	float = "1"b;
	format = format || "8e^)";
	call print_data;
	return;

/*  fl    float-long */

label (20):
	float = "1"b;
	format = format || "19.6f^)";
	call print_data;
	return;

/*  el    exponential-long */

label (21):
	float = "1"b;
	format = format || "19e ^)";
	call print_data;
	return;

/*  g	graphic */
label (14):
	call gr_print_ (str);
	return;

/*  comp-5,  comp-8	COBOL */
label (18):
label (19):
	packed_decimal = "1"b;
	call print_data;
	return;

out:						/* for the out_of_bounds_handler */
	return;
ERROR_NO_LINE: call ioa_$ioa_switch (iocb_ptr, "Cannot get line.");
	return;

/*  */
/*  print_data prints "per_line" data items on one line.  It matches the data type with
   the format to prevent ioa_ from doing a data conversion before printing.
   The next line is checked with the current line.  If it is the same, then "=====" will be
   printed on the line instead.  This symbol will be printed only once for a series of repeated lines.
*/

print_data: proc;

dcl  same bit (1) init ("0"b);			/* ON if current output line is a repeat */
dcl  print_equal bit (1);				/* ON if should print ===== */
dcl  d_size fixed bin;
dcl  fl (4) float bin (63);
dcl  fx (4) fixed bin (71);
dcl  b bit (256);					/* copy of number to print in octal */
dcl  d fixed bin;					/* number of octal digits to print */
dcl  num_digits fixed bin;				/* Number of digits for paced decimal comp-8 */
dcl  check_ptr bit (1) aligned;			/* ON, for comp-8 with odd number of digits */
dcl  add_bit bit (1) aligned;				/* ON, if must add bit to data ptr */
dcl  next_p ptr;					/* points to next item to print */

dcl  fxb (8) fixed bin (35) based (pp);
dcl  bits (16) bit (d_size) based (pp);
dcl  based_comp bit (data_size+1) unal based (next_p);

dcl  data_line bit (data_line_len*2) unal based (pp);	/* line data_line_lenust printed + next line */
dcl  data_line_len fixed bin;				/* number of bits in one line */

	     d_size = data_size;
	     if d_size = 0 then d_size = 36;		/* no size given for temporaries (%) */
	     if d_size &gt;72 &amp; ^packed_decimal then d_size = 36;
	     data_line_len = d_size * per_line;

/* COBOL - Packed decimal data with an odd number of digits as an alternating data size.  (ie. 7 digits = 32 bits, 31...)
   db_print is given the smaller of these 2 sizes.  The pointer is digit aligned the first time.  Later a bit
   is added every other time to correct the pointer.
*/
	     check_ptr = "0"b;
	     if packed_decimal then do;
		num_digits = divide (d_size *2+1, 9, 17, 0);
		check_ptr = (mod (num_digits, 2) ^= 0);
		unspec (copy_its) = unspec (pp);
		num = fixed (copy_its.bit_offset, 6);
		do i = 1 to 8 while (num &gt; bit_loc (i));
		end;

/* If the pointer is not aligned on a digit boundary, then the pointer will be rounded up to the next boundary. */
		if num ^= bit_loc (i) then do;
		     i = min (i, 8);
		     copy_its.bit_offset = substr (unspec (bit_loc (i)), 31, 6);
		     unspec (pp) = unspec (copy_its);
		end;
		add_bit = "1"b;

/* If there are an odd number of digits in a packed decimal number and we have the smaller of the two numbers
   then must add 2 bits for a line of 4 numbers. (i.e. 4*31+2 for 32, 31, 32, 31) */
		if check_ptr then data_line_len = data_line_len +2;
	     end;
	     k = loc - offset;

	     do while (no_prt &gt; 0);
		per_line = min (no_prt, per_line);
		if same then if print_equal then do;
			call ioa_$ioa_switch (iocb_ptr, "======"); /* skip line */
			print_equal = "0"b;
		     end;
		     else;

		else do;

		     if octal then do;
			if d_size = 36
			then call ioa_$ioa_switch (iocb_ptr, format, loc, offset, per_line, bits);

/* Numbers to be printed in octal are copied into b so that they can be right justified.  Procedure ioa_ left justifies.  */
			else do;
			     call ioa_$ioa_switch_nnl (iocb_ptr, "^6o ^6o ", loc, offset);
			     do j = 1 to per_line;
				b = "0"b;
				d = divide (d_size+2, 3, 17, 0);
				substr (b, d*3-d_size+1, d_size) = bits (j);
				call ioa_$ioa_switch_nnl (iocb_ptr, " ^v.3b", d, b);
			     end;
			     call ioa_$ioa_switch (iocb_ptr, "");
			end;
		     end;

		     else if float then do;
			do j = 1 to per_line;
			     fl (j) = 0;
			     unspec (fl (j)) = unspec (bits (j));
			end;
			call ioa_$ioa_switch (iocb_ptr, format, loc, offset, per_line, fl);
		     end;

/* COBOL data type */
		     else if packed_decimal then do;
			call ioa_$ioa_switch_nnl (iocb_ptr, "^6o ^6o ", loc, offset, per_line);
			next_p = pp;
			do j = 1 to per_line;
			     call comp_8_to_ascii_ (based_comp, string);
			     call ioa_$ioa_switch_nnl (iocb_ptr, "  ^a", substr (string, 1, num_digits));

			     next_p = addr (next_p -&gt; bits (2));

/* Add one bit to the pointer for odd digits per number. */
			     if check_ptr then do;
				if add_bit then do;
				     unspec (copy_its) = unspec (next_p);
				     num = fixed (copy_its.bit_offset, 6)+1;
				     copy_its.bit_offset = substr (unspec (num), 31, 6);
				     unspec (next_p) = unspec (copy_its);
				end;
				add_bit = ^add_bit;
			     end;
			end;
			call ioa_$ioa_switch (iocb_ptr, ""); /* new_line */
		     end;
		     else do;

			if d_size = 36 then call ioa_$ioa_switch (iocb_ptr, format, loc, offset, per_line, fxb);

			else do;
			     do j = 1 to per_line;
				if substr (bits (j), 1, 1) = "1"b then fx (j) = -1;
				else fx (j) = 0;
				substr (unspec (fx (j)), 73-d_size, d_size) = bits (j);
			     end;
			     call ioa_$ioa_switch (iocb_ptr, format, loc, offset, per_line, fx);

			end;
		     end;
		end;

		if ^same then print_equal = "1"b;

/* Check for duplicate line.  Last line of comp-8 with odd number of digits will be printed. */

		no_prt = no_prt - per_line;
		if no_prt &gt; 0 then do;
		     if no_prt &gt;= per_line then j = data_line_len;
		     else j = no_prt * d_size;
		     if check_ptr &amp; (no_prt &lt; 4) then same = "0"b;
		     else if substr (data_line, 1, j) = substr (data_line, data_line_len + 1, j) then same = "1"b;
		     else same = "0"b;
		end;
		pp = addr (substr (data_line, data_line_len+1, 1));
		loc = fixed (rel (pp), 17);
		offset = loc - k;

	     end;

	end print_data;

/*  */
/*  This procedure prints one or more lines of source code beginning with the line associated with the object code
   pointed to by data_ptr.  For an unbound segment, the directory in which
   the object segment was compiled is searched for the source segment.  If the source segment is not found there,
   the working directory is searched.  For bound segments only the working directory is searched for the source
   segment.
*/
print_source: proc;

dcl  source_based char (2) based (source_ptr);
dcl  source_dir char (168);
dcl  source_ent char (32);
dcl  source_len fixed bin;
dcl  source_name char (source_len) based (source_name_ptr);
dcl  source_name_ptr ptr;
dcl  source_ptr ptr;				/* pointer to source segment */

	     if sntp -&gt; snt.symflag then call db_get_sym (sntp);

	     if snt.std then do;			/* standard header, use source map */
		hp = snt.headp;
		call stu_$get_line (hp, loc, no_prt, line_no, line_offset, line_length, file);

		if line_no = -1 | line_length = 0 then go to ERROR_NO_LINE;
		file = file + 1;			/* because of dimensioning in include file */

		if hp -&gt; std_symbol_header.source_map = (18)"0"b then go to ERROR_NO_LINE;
		smap_ptr = addrel (hp, hp -&gt; std_symbol_header.source_map);
		source_name_ptr = addrel (hp, smap_ptr -&gt; source_map.map (file).pathname.offset);
		source_len = fixed (smap_ptr -&gt; source_map.map (file).pathname.size, 18);

/* got source name, separate it out for initiate */

		call expand_pathname_ (source_name, source_dir, source_ent, code);

		call hcs_$initiate (source_dir, source_ent, "", 0, 1, source_ptr, code);

/* If there is no pointer to the source segment, look in the working directory.  */

		if source_ptr = null () then do;

		     if source_ent = last_source then print_err = "0"b;
		     if print_err then call ioa_$ioa_switch (iocb_ptr, "Cannot initiate source.  ^a&gt;^a", source_dir,
			source_ent);

		     source_dir = get_wdir_ ();
		     call hcs_$initiate (source_dir, source_ent, "", 0, 1, source_ptr, code);

		     if source_ptr = null () then do;
			if ^print_err then call ioa_$ioa_switch (iocb_ptr, "Cannot initiate source.  ^a&gt;^a",
			     source_dir, source_ent);
			return;
		     end;
		     if print_err then call ioa_$ioa_switch (iocb_ptr, "Using source  ^a&gt;^a", source_dir, source_ent);

		end;
		last_source = source_ent;

/* Now just write out the requisite stuff */

		call iox_$put_chars (iocb_ptr, addr (substr (source_based, line_offset+1, 1)), line_length, code);
		call ioa_$ioa_switch (iocb_ptr, "");	/* add new-line */
		return;
	     end;

	     else call ioa_$ioa_switch (iocb_ptr, "Version 1 object segments are not supported by debug.");

	     return;

	end print_source;

/*  */
oob_handler: proc (mcp, name, x_p, y_p, cont_sw);

/*	Procedure to handle out_of_bounds. If it occurred in the data segment,
   *	the user specified to high an address or too much data. Else it's a real
   *	program error and we want to hear about it.
   */

dcl  name char (*);
dcl (x_p, y_p) ptr;
dcl  cont_sw bit (1) aligned;

%include mc;


	     scup = addr (mcp -&gt; mc.scu);
	     if scu.tpr.tsr = substr (baseno (pp), 4) then do; /* oob in data seg. */
		call reversion_ ("out_of_bounds");
		call ioa_$ioa_switch (iocb_ptr, "Request goes beyond end of segment.");
		go to out;
	     end;

/* Elsewhere, use previous handler */

	     cont_sw = "1"b;
	     return;

	end oob_handler;
     end db_print;
��



		    db_regs.pl1                     11/04/82  1959.8rew 11/04/82  1628.8      236556



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


db_regs:	procedure;



/*	This procedure is used to print, get, or assign the values of the  debug  or  user
*	defined data registers.  There is an entry provided for each of these three
*	functions.   The  debug data registers  are really data fields in the machine
*	conditions and are referenced via pre-defined names.
*
*	Rewritten  Nov 72  for the  6180  by  Bill Silver.
*/



/*		PARAMETER  DATA		*/

dcl	db_mc_ptr	ptr,		/* Pointer to the current machine conditions.  All debug keeps
				*  is a pointer to the machine conditions which are in the stack.
				*  If this pointer is null then we don't have any machine
				*  registers to play with.  Note, the user defined registers
				*  are always available.  	*/

	name	char(4) aligned,	/* The name of the data item that is to be processed.  It is
				*  either a predefined debug data name or the name of a
				*  user defined register.  	*/

	print_mode	fixed bin,	/* 0 =&gt; BRIEF,  1 =&gt; LONG.  */

	value	bit(72) aligned;	/* Used to assign or get the value of one debug data item.
				*  Its contents are always right justified.  	*/





/*		AUTOMATIC  DATA		*/


/*	These  data items are used as work variables.  */

dcl	block_ptr		ptr,	/* Pointer to a block of 8 words to be printed. */


	work_ptr		ptr;	/* Just a temporary pointer. */

dcl	indp		ptr;	/* pointer to indicator reg. in scu */

dcl	delim		char(2);	/* comma or blank for indicator list */

dcl	namex	fixed bin,	/* The index of the db_data$names table. */

	userx	fixed bin,	/* The index of both the user_reg_names and
				*  user_reg_values  table. */

	i	fixed bin;	/* Just a work varaible. */

dcl	len	fixed bin;	/* Another work variable. */


/*	This variable is used to obtain a printable string of information about
*	an instruction from the  print_text_$format procedure.
*/

dcl	source_string	char (72)	varying;




/*	These words are used to print data items in octal via calls to  "ioa_".   They
*	are needed to correctly print, for example, a 3 octal digit number since the
*	number must be right justified in a 36 bit word and all but the 3 digits to be
*	printed must be zero.
*/

dcl	( print_word1, print_word2, print_word3, print_word4 )
	bit(36)	init( "0"b );




/*	This word is used in printing out the value of the eaq in floating format */

dcl	float_val float bin(63);


dcl	print_request bit (1) init ("0"b);	/* ON if entry by db_regs$print  */




/*		BASED  DECLARATIONS		*/


/*	Used to overlay floating value for eaq output */

dcl	1 float_overlay	aligned based(addr(float_val)),
	2 exponent	unal bit(8),
	2 a_part		unal bit(36),
	2 q_part		unal bit(27);


/*	Used to print out a block of  8  words.  */

dcl	block (0:7)  bit(36)  based;
dcl	eight_words bit(288) based aligned;


/*	Used to reference a pointer as a bit string.  */

dcl	ptr_bit_string	bit(72)	based;

dcl	based_ptr 	ptr   based;

dcl	ind_bits		bit(14) based(indp);	/* indicators */



/*		INTERNAL  STATIC  DATA	    */



/*	The following two tables are used to convert an index of a debug data name into
*	an index of a label constant array.  Except for the first and the last entries
*	all of the entries of these two tables correspond to a debug data name as defined
*	in the  db_data$names array.  The first entry (-1) is used when there is no room
*	left for another user register.  The last entry is used for  user defined registers.
*	The value of each entry is an index into the label array which corresponds to each.
*	of these tables.  Note, the  get_ass_label_table  is used for both the
*	get_label array  and the  assign_label array.   The entries in the label arrays
*	are used to transfer the routine which can process this type of data.
*/



dcl	print_label_table ( -1:33 )	fixed bin	  internal  static

/*			    DATA NAME	PRINT ROUTINE	*/

	init (	    0,	/*		return		*/
		(8) 6,	/* pointer regs	print_pr		*/
		(8) 7,	/* index regs	print_xreg	*/
		    9,	/*   aq		print_aq		*/
		    1,	/*   all		print_all		*/
		    2,	/*   prs		print_prs		*/
		    3,	/*   regs		print_regs	*/
		    4,	/*   scu		print_scu		*/
		    5,	/*   user		print_user_regs	*/
		   10,	/*   a		print_a		*/
		   11,	/*   q		print_q		*/
		   12,	/*   exp		print_exp		*/
		   13,	/*   tr		print_tr		*/
		   14,	/*   ralr		print_ralr	*/
		   15,	/*   ppr		print_ppr		*/
		   16,	/*   tpr		print_tpr		*/
		   17,	/*   even		print_even	*/
		   18,	/*   odd		print_odd		*/
		   19,	/*   ind		print_indicators	*/
		   20,	/*   eaq		print_floating_eaq  */
		    8);	/*   		print_user_reg	*/



dcl	get_ass_label_table ( -1:33 )	fixed bin	  internal  static

/*			    DATA NAME	GET/ASSIGN ROUTINE	*/

	init (	    0,	/*		return		*/
		(8) 2,	/* pointer regs	get/assign_pr	*/
		(8) 3,	/* index regs	get/assign_xreg	*/
		    5,	/*   aq		get/assign_aq	*/
		    1,	/*   all		get/assign_illegal	*/
		    1,	/*   prs		get/assign_illegal	*/
		    1,	/*   regs		get/assign_illegal	*/
		    1,	/*   scu		get/assign_illegal	*/
		    1,	/*   user		get/assign_illegal	*/
		    6,	/*   a		get/assign_a	*/
		    7,	/*   q		get/assign_q	*/
		    8,	/*   exp		get/assign_exp	*/
		    9,	/*   tr		get/assign_tr	*/
		   10,	/*   ralr		get/assign_ralr	*/
		   11,	/*   ppr		get/assign_ppr	*/
		   12,	/*   tpr		get/assign_tpr	*/
		   13,	/*   even		get/assign_even	*/
		   14,	/*   odd		get/assign_odd	*/
		    1,	/*   ind		get/assign_illegal	*/
		    1,	/*   eaq		get/assign_illegal	*/
		    4);	/*   		get/assign_user_reg	*/


/*	The following table contains the names to be associated with
*	each bit of the Indicators register.
*/

dcl	ind_names (14) char(4)	int static initial
	("zero",
	 "neg ",
	 "cary",
	 "ovfl",
	 "eovf",
	 "eufl",
	 "oflm",
	 "tro ",
	 "par ",
	 "parm",
	 "^bar",
	 "tru ",
	 "mif ",
	 "abs ");




/*	These tables contain the user defined registers.  The maximum number that may
*	be defined is  16.   The corresponding entries of the two tables define the
*	name and the value of each register.  Note, these registers are defied as
*	INTERNAL STATIC and thus will remain unchanged for recursive calls to  debug.
*	This is not true for the debug machine condition data.
*/

/*	These variables contain the number of user defined registers which have actually
*	been defined  and the  maximum number which may be defined.
*/

dcl      (num_user_regs	fixed bin    init(0),

	max_num_user_regs	fixed bin	   init(16) )    internal static;


dcl	user_reg_names(16)	char(4)	internal  static;

dcl	user_reg_values(16)	bit(36)	internal static;





/*		EXTERNAL  and  BUILTIN  DATA		*/


/*	These are the external procedures called by  db_regs.  */

%include db_ext_stat_;

dcl	print_text_$format	ext    entry	( ptr, char(*) var ),

	ioa_$ioa_stream	ext    entry	options(variable);

dcl	ioa_$rsnnl	ext    entry	options(variable);



dcl	( addr, substr )	builtin;
/**/
% include	db_data_map;
/**/
% include	its;
% include mc;
/**/


print:	entry  ( db_mc_ptr, name, print_mode );

	print_request = "1"b;		/* Set so we won't create if not found */

	call	get_namex;		/* Get the index of this name. */


/*	This index is used to reference the label table which then gives us the index
*	of the label constant that we want to  goto.
*/

	goto	print_label( print_label_table(namex) );






get:	entry  ( db_mc_ptr, name, value, print_mode );


	call	get_namex;


	value  =  "0"b;		/* Initially set the return value to zero.  */


	goto	get_label( get_ass_label_table(namex) );






assign:	entry  ( db_mc_ptr, name, value, print_mode );


	call	get_namex;


	print_word1  =  substr( value, 1,36);	/* Break up the input value into two words */
	print_word2  =  substr( value,37,36);	/* so it can be more easily printed
					*  via  ioa_.  */


	goto	assign_label( get_ass_label_table(namex) );





/*	We come here if  "namex"  =  -1  which implies that there was no room for another
*	user defined register.  We will simply return.
*/

print_label(0):
get_label(0):
assign_label(0):

	return;




/*	This label is called from  get_namex  when the pointer to the machine conditions is
*	null.  Since there is no register data to work with we will just return.
*/

no_mc_data:

	if	print_mode  =  0			/* BRIEF  or  LONG  */

		then	call    ioa_$ioa_stream (debug_output, "No  mc  data.");


		else  do;				/* LONG. */
		call    ioa_$ioa_stream (debug_output, "No fault frame found in stack trace.");
		end;


	return;
/**/
get_namex:	procedure;


/*	This procedure is called to set  "namex"  to the number which corresponds to the data
*	name passed to  db_regs  in  "name".   If it is a standard pre-defined debug data
*	name then  "namex"  will be simply the index of the   db_data$names array entry
*	which contains this name.  Otherwise it will be a user defined register name and "namex"
*	will be equal to a number one greater than the highest valid index to  db_data$names.
*	The index of the user register is set in  "userx".   If there is no room to allocate
*	a new user register then  "namex"  will be set to  -1.
*/



	mcp  =  db_mc_ptr;		/* Copy the parameter which points to the area where
				*  debug's  copy of the machine conditions are saved.  */


/*	See if this name is one of the standard debug data names.  If it is then  "namex"
*	is equal to the index of the db_data$names entry which contains this name.
*	If it is one of the standard register names then we will check the pointer to the
*	machine conditions that we were passed.  If it is  null  then we can't do anything
*	with this register since as far as we are conserned it doesn't exist.
*/

	do    namex  =  0  to  db_data$n_regs;

	if    name  =  db_data$names(namex)		/* Is it one of the standard machine
						*  condition type register names? */

		then    if    db_mc_ptr  =  null()	/* YES it is - do we have a pointer
						*  to it?  */

			then  goto  no_mc_data;	/* NO. */

			else  do;			/* YES, return with namex. */
			scup  =  addr( mcp -&gt; mc.scu );
			return;
			end;

	end;


/*	This name is not one of the standard names.  It must be the name of a user defined
*	register.  "namex"  is set correctly.  It came out of the  do loop  one greater
*	than the number of standard names.  We will now see if this user name is allready
*	defined.  If it is we will just return with  "userx"  set correctly.
*/

	do    userx  =  1  to  num_user_regs;

	if    name   =  user_reg_names(userx)    then  return;

	end;


/*	This is a new user register name.  Do we have another slot in the user register
*	tables for it?  If not we will tell the user and  "namex"  will be set to -1.
*	The register will not be created for a print request.
*/


	if print_request then do;
	     call ioa_$ioa_stream (debug_output, "User register not defined.  ^a", name);
	     namex = -1;
	     return;
	end;
	if	userx  &gt;  max_num_user_regs

		then  do;
		call  ioa_$ioa_stream (debug_output, "User register  ^a  not initialized - max number exceded",name);
		namex  =  -1;
		return;
		end;


/*	There is room for this new user register so lets initialize it.
*/

	num_user_regs  =  userx;		/* Reset the count of active user registers
					*  to reflect this new register.  */

	user_reg_names(userx)   =  name;	/* Remember its name. */

	user_reg_values(userx)  =  "0"b;	/* Initialize its value to zero. */

/*	If we are in LONG mode then we will tell the user that he has just created
*	a new user register.  */

	if	print_mode  ^=  0

		then    call    ioa_$ioa_stream (debug_output, "Creating new user register  ^a", name );


	end	get_namex;
/**/
/*	These are the routines called via the  print_label  array.   Each little piece
*	of code  PRINTS  some of the debug machine conditions data.
*/


/*	Print all of the machine conditions data.  Also print the user defined
*	registers.
*/

print_label(1):			/*	print_all 	*/

	if	print_mode  ^=  0
		then    call    ioa_$ioa_stream (debug_output, "All  ""machine conditions""  data.");

	call	print_prs;

	call	print_regs;

	call	print_scu;

	if	print_mode  ^=  0
		then    call  ioa_$ioa_stream (debug_output, "^/The  8  words after the  SCU  data");
	block_ptr  =  addr( mcp -&gt; mc.mask );
	call	print_block;

	block_ptr  =  addr( mcp -&gt; mc.eis_info );
	if block_ptr -&gt; eight_words ^= "0"b then do;
		if	print_mode  ^=  0
		then    call  ioa_$ioa_stream (debug_output, "^/EIS  info");
		call	print_block;
	end;

	call	print_user_regs;

	return;





/* 	Print  all  of the  pointer registers.  */

print_label(2):

	call	print_prs;
	return;


print_prs:	procedure;

	call	ioa_$ioa_stream (debug_output, "^/Pointer Registers");

	do    i  =  0  to  7;
	call	ioa_$ioa_stream (debug_output, "^a^-^p",db_data$names(i), mcp-&gt;mc.prs(i));
	end;

	end	print_prs;





/*	Print all of the registers: index registers, A,Q,Exp,Timer Register and
*	Ring Alarm Register.
*/

print_label(3):

	call	print_regs;
	return;


print_regs:	procedure;

	if	print_mode  ^=  0

		then  do;

		call  ioa_$ioa_stream (debug_output, "^/Index  and other  Registers");

		do    i  =  0  to  7;
		call	ioa_$ioa_stream (debug_output, "^a^-^.3b", db_data$names(i+8), mcp-&gt;mc.regs.x(i));
		end;
		end;


		else  do;			/* BRIEF  mode.  */

		call    ioa_$ioa_stream (debug_output, "^-^.3b  ^.3b  ^.3b  ^.3b",
			mc.regs.x(0), mc.regs.x(1), mc.regs.x(2), mc.regs.x(3));
		call    ioa_$ioa_stream (debug_output, "^-^.3b  ^.3b  ^.3b  ^.3b",
			mc.regs.x(4), mc.regs.x(5), mc.regs.x(6), mc.regs.x(7));

		end;
	call	ioa_$ioa_stream (debug_output, "a^-^w^/q^-^w", mcp-&gt;mc.regs.a, mcp-&gt;mc.regs.q);

	call	print_exp;
	call	print_tr;
	call	print_ralr;

	end	print_regs;





/*	Print the SCU data.  We will print out the  PPR, TPR and the EVEN and ODD
*	instructions.  Then we will print out the  SCU  data as a block.
*/

print_label(4):

	call	print_scu;
	return;


print_scu:	procedure;

	if	print_mode  ^=  0

		then  do;
		call	ioa_$ioa_stream (debug_output, "^/SCU  data");
		call	print_ppr;
		call	print_tpr;
		call	ioa_$ioa_stream (debug_output, "^/");
		call	print_even;
		call	print_odd;
		call	print_ind;
		call	ioa_$ioa_stream (debug_output, "The  SCU  data as a block");
		end;

	block_ptr  =  scup;
	call	print_block;

	end	print_scu;





/*	Print out all of the user defined registers.  */

print_label(5):

	call	print_user_regs;
	return;


print_user_regs:	procedure;

	if	num_user_regs  =  0

		then  do;
		if	print_mode  ^=  0
			then    call  ioa_$ioa_stream (debug_output, "^/No user defined registers");
		return;
		end;

	if	print_mode  ^=  0
		then    call  ioa_$ioa_stream (debug_output, "^/User defined registers");

	do    i  =  1  to  num_user_regs;
	call	ioa_$ioa_stream (debug_output, "^a^-^w", user_reg_names(i), user_reg_values(i));
	end;

	end	print_user_regs;





/*	Print out  one  pointer register.  */

print_label(6):			/*	print_pr  	*/

	call	ioa_$ioa_stream (debug_output, "^a^-^p",db_data$names(namex), mcp-&gt;mc.prs(namex));
	return;





/*	Print out  one  index register.  */

print_label(7):			/*	print_xreg  	*/

	call	ioa_$ioa_stream (debug_output, "^a^-^.3b", db_data$names(namex), mcp-&gt;mc.regs.x(namex-8) );
	return;





/*	Print out  one  user defined register.  */

print_label(8):			/*	print_user_reg	*/

	call	ioa_$ioa_stream (debug_output, "^a^-^w", user_reg_names(userx), user_reg_values(userx));
	return;





/*	Print the  AQ  as a combined register  or  print the  A  or  the  Q.  */

print_label(9):			/*	print_aq  	*/

	call	ioa_$ioa_stream (debug_output, "aq^-^w ^w", mcp -&gt; mc.regs.a, mcp -&gt; mc.regs.q);
	return;


print_label(10):			/*	print_a   	*/

	call	ioa_$ioa_stream (debug_output, "a^-^w", mcp-&gt;mc.regs.a);
	return;



print_label(11):			/*	print_q   	*/

	call	ioa_$ioa_stream (debug_output, "q^-^w", mcp-&gt;mc.regs.q);
	return;





/*	Print the  Exponent register.  */

print_label(12):

	call	print_exp;
	return;

print_exp:	procedure;

	call	ioa_$ioa_stream (debug_output, "exp^-^.3b", "0"b || mc.regs.e);

	end	print_exp;






/*	Print the  Timer Register.  */

print_label(13):

	call	print_tr;
	return;


print_tr:		procedure;

	call	ioa_$ioa_stream (debug_output, "tr^-^.3b", mcp-&gt;mc.regs.t);

	end	print_tr;





/*	Print the  Ring Alarm Register.  */

print_label(14):

	call	print_ralr;
	return;


print_ralr:	procedure;

	call	ioa_$ioa_stream (debug_output, "ralr^-^.3b", mc.regs.ralr);

	end	print_ralr;




/*	Print the  PPR.  */

print_label(15):

	call	print_ppr;
	return;


print_ppr:	procedure;

	if	print_mode  ^=  0
		then    call  ioa_$ioa_stream (debug_output, "^/ppr:^-prr  psr   p    ic");

	call	ioa_$ioa_stream (debug_output, "^- ^.3b  ^.3b  ^.1b  ^.3b", scu.ppr.prr,
		     scu.ppr.psr, scu.ppr.p, scu.ilc);

	end	print_ppr;





/*	Print  the  TPR.  */

print_label(16):

	call	print_tpr;
	return;


print_tpr:	procedure;

	if	print_mode  ^=  0
		then    call  ioa_$ioa_stream (debug_output, "^/tpr:^-trr  tsr   tbr   ca");

	call	ioa_$ioa_stream (debug_output, "^- ^.3b  ^.3b  ^.3b  ^.3b",  scu.tpr.trr,
		     scu.tpr.tsr, scu.tpr_tbr, scu.ca);

	end	print_tpr;





/*	Print out the  EVEN  or  the  ODD  instruction.  */

print_label(17):

	call	print_even;
	return;

print_even:	procedure;

	call	print_text_$format( addr( scup -&gt; scu.even_inst), source_string);

	call	ioa_$ioa_stream (debug_output, "even^-^a", source_string );

	end	print_even;



print_label(18):

	call	print_odd;
	return;


print_odd:	procedure;

	call	print_text_$format( addr( scup -&gt; scu.odd_inst), source_string);

	call	ioa_$ioa_stream (debug_output, "odd^-^a", source_string);

	end	print_odd;



print_label(19):

	call	print_ind;
	return;

/*	Print out eaq in exponential format */

print_label(20):

	float_overlay.exponent = mc.e;
	float_overlay.a_part = mc.a;
	float_overlay.q_part = mc.q;

	call ioa_$ioa_stream (debug_output, "eaq^-^e",float_val);
	return;


print_ind:	procedure;

	indp = addr(scup -&gt; scu.ir);	/* point to indicator bits */

	delim = "";			/* initialize */
	source_string = "";

	if indp -&gt; ind_bits = (14)"0"b
	then source_string = "none";		/* no point if they're all off */

	else
	do i = 1 to 14;
	     if substr (indp -&gt; ind_bits, i, 1)
	     then do;

		call ioa_$rsnnl ("^a^a^a", source_string, len, source_string,
			delim, ind_names(i) );
		delim = ", ";		/* in case it was first one */
	     end;
	end;

	call ioa_$ioa_stream (debug_output, "indicators: ^a", source_string);

	end	print_ind;








/*	This procedure prints out a block of  8  octal words.  It must be passed
*	a pointer to the block of wors to be printed.
*/

print_block:	procedure;

	call	ioa_$ioa_stream (debug_output, "^/^-^w  ^w  ^w  ^w",
		block_ptr-&gt;block(0), block_ptr-&gt;block(1), block_ptr-&gt;block(2), block_ptr-&gt;block(3));

	call	ioa_$ioa_stream (debug_output, "^-^w  ^w  ^w  ^w",
		block_ptr-&gt;block(4), block_ptr-&gt;block(5), block_ptr-&gt;block(6), block_ptr-&gt;block(7));

	end	print_block;
/**/
/*	These are the routines called via the  get_label  array.  note, the value returned
*	will always be  RIGHT  justified with leading zeros.
*/




/*	The names used to print multiple data items cannot be used to retrieve data.
*	A zero will be returned.
*/

get_label(1):			/*	get_illegal	*/

	return;			/* value is allready zero.  */




get_label(2):			/*	get_pr    	*/

	value  =  addr( mcp -&gt; mc.prs(namex)) -&gt; ptr_bit_string;
	return;




get_label(3):			/*	get_xreg		*/

	substr( value, 55, 18 )  =  mcp -&gt; mc.regs.x(namex-8);
	return;



get_label(4):			/*	get_user_reg	*/

	substr( value, 37, 36 )  =  user_reg_values(userx);
	return;




get_label(5):			/*	get_aq		*/

	substr( value, 1, 36 )   =  mcp -&gt; mc.regs.a;
	substr( value, 37, 36 )  =  mcp -&gt; mc.regs.q;
	return;




get_label(6):			/*	get_a		*/

	substr( value, 37, 36 )  =  mcp -&gt; mc.regs.a;
	return;




get_label(7):			/*	get_q		*/

	substr( value, 37, 36 )  =  mcp -&gt; regs.q;
	return;




get_label(8):			/*	get_exp		*/

	substr( value, 65, 8 )  =  mcp -&gt; mc.regs.e;
	return;



get_label(9):			/*	get_tr		*/

	substr( value, 46, 27 )  =  mcp -&gt; mc.regs.t;
	return;




get_label(10):			/*	get_ralr		*/

	substr( value, 70, 3 )  =  mcp -&gt; mc.regs.ralr;
	return;




get_label(11):			/*	get_ppr		*/

	work_ptr  =  addr( value );
	work_ptr -&gt; its.segno  =  scup -&gt; scu.ppr.psr;
	work_ptr -&gt; its.ringno =  scup -&gt; scu.ppr.prr;
	substr( value, 3, 1 )  =  scup -&gt; scu.ppr.p;	/* Normal its pointers have no p bit. */
	work_ptr -&gt; its.offset =  scup -&gt; scu.ilc;
	return;




get_label(12):			/*	get_tpr		*/

	work_ptr  =  addr( value );
	work_ptr -&gt; its.segno  =  scup -&gt; scu.tpr.tsr;
	work_ptr -&gt; its.ringno =  scup -&gt; scu.tpr.trr;
	work_ptr -&gt; its.bit_offset  =  scup -&gt; scu.tpr_tbr;
	work_ptr -&gt; its.offset =  scup -&gt; scu.ca;
	return;




get_label(13):			/*	get_even		*/

	substr( value, 37, 36 )  =  scup -&gt; scu.even_inst;
	return;




get_label(14):			/*	get_odd		*/

	substr( value, 37, 36 )  =  scup -&gt; scu.odd_inst;
	return;
/**/
/*	These routines are called via the assign_label array.  note, the value to be
*	assigned is always assumed to be a  RIGHT  justified  BIT  string.
*	Note, if the print mode is  LONG  we will print out the value of the data item
*	before it is changed and after the assignment.  If we are in  BRIEF  mode we will
*	just make the assignment without telling the user anything.
*/



/*	The name used to print multiple data items cannot be used to assign values.
*	Each assignment must be made to a specific register.
*/

assign_label(1):			/*	assign_illegal	*/

	call	ioa_$ioa_stream (debug_output, "The  debug  name  ^a  cannot be used in an assignment command.",
		      db_data$names(namex));
	return;

assign_label(2):			/*	assign_pr		*/

	if	print_mode  =  1

		then    	call	ioa_$ioa_stream (debug_output, "^a  changed from  ^p  to  ^p",
			          db_data$names(namex), mcp -&gt; mc.prs(namex), addr(value) -&gt; based_ptr);

	addr( mcp -&gt; mc.prs(namex)) -&gt; ptr_bit_string  =  value;

	return;

assign_label(3):			/*	assign_xreg	*/

	if	print_mode  =  1
		then  do;
		call	ioa_$ioa_stream (debug_output, "^a  changed from  ^.3b  to  ^.3b",
		          db_data$names(namex), mc.regs.x(namex-8), substr(print_word2, 19, 18));
		end;

	mcp -&gt; mc.regs.x(namex-8)  =  substr( print_word2, 19, 18 );

	return;

assign_label(4):			/*	assign_user_reg	*/

	if	print_mode  =  1

		then	call	ioa_$ioa_stream (debug_output, "^a  changed from  ^w  to  ^w",
			          user_reg_names(userx), user_reg_values(userx), print_word2);

	user_reg_values(userx)  =  print_word2;

	return;

assign_label(5):			/*	assign_aq		*/

	if	print_mode  =  1

		then	call	ioa_$ioa_stream (debug_output, "aq    changed from  ^w^w  to  ^w^w",
		   	          mcp -&gt; mc.regs.a, mcp -&gt; mc.regs.q, print_word1, print_word2);

	mcp -&gt; mc.regs.a  =  print_word1;
	mcp -&gt; mc.regs.q  =  print_word2;

	return;

assign_label(6):			/*	assign_a		*/

	if	print_mode  =  1

		then	call	ioa_$ioa_stream (debug_output, "a     changed from  ^w  to  ^w",
				mcp -&gt; mc.regs.a, print_word2);

	mcp -&gt; mc.regs.a  =  print_word2;

	return;

assign_label(7):			/*	assign_q		*/

	if print_mode = 1 then
	call	ioa_$ioa_stream (debug_output, "q     changed from  ^w  to  ^w",
			          mcp -&gt; mc.regs.q, print_word2);

	mcp -&gt; mc.regs.q  =  print_word2;

	return;

assign_label(8):			/*	assign_exp	*/

	if	print_mode  =  1
		then  do;
		call	ioa_$ioa_stream (debug_output, "exp   changed from  ^.3b  to  ^.3b",
			     "0"b || mc.regs.e, "0"b || substr(print_word2, 29, 8));
		end;

	mcp -&gt; mc.regs.e  =  substr( print_word2, 29, 8 );

	return;

assign_label(9):			/*	assign_tr		*/

	if	print_mode  =  1
		then  do;
		call	ioa_$ioa_stream (debug_output, "tr    changed from  ^.3b  to  ^.3b",
			     mc.regs.t, substr(print_word2, 10, 27));
		end;

	mcp -&gt; mc.regs.t  =  substr( print_word2, 10, 27 );

	return;

assign_label(10):			/*	assign_ralr	*/

	if	print_mode  =  1
		then  do;
		call	ioa_$ioa_stream (debug_output, "ralr  changed from  ^.3b  to  ^.3b",
			     mc.regs.ralr, substr(print_word2, 34, 3));
		end;

	mcp -&gt; mc.regs.ralr  =  substr( print_word2, 34, 3 );

	return;

assign_label(11):			/*	assign_ppr	*/

	work_ptr  =  addr( value );

	if	print_mode  =  1

		then  do;
		call	ioa_$ioa_stream (debug_output, "Old  ppr");
		call	print_ppr;
		end;

	scup -&gt; scu.ppr.psr  =  work_ptr -&gt; its.segno;
	scup -&gt; scu.ppr.prr  =  work_ptr -&gt; its.ringno;
	scup -&gt; scu.ppr.p  =  substr( value, 3,1 );
	scup -&gt; scu.ilc  =  work_ptr -&gt; its.offset;

	if	print_mode  =  1

		then  do;
		call	ioa_$ioa_stream (debug_output, "New  ppr");
		call	print_ppr;
		end;

	return;

assign_label(12):			/*	assign_tpr	*/

	work_ptr  =  addr( value );

	if	print_mode  =  1

		then  do;
		call	ioa_$ioa_stream (debug_output, "Old  tpr");
		call	print_tpr;
		end;

	scup -&gt; scu.tpr.tsr  =  work_ptr -&gt; its.segno;
	scup -&gt; scu.tpr.trr  =  work_ptr -&gt; its.ringno;
	scup -&gt; scu.tpr_tbr  =  work_ptr -&gt; its.bit_offset;
	scup -&gt; scu.ca  =  work_ptr -&gt; its.offset;

	if	print_mode  =  1

		then  do;
		call	ioa_$ioa_stream (debug_output, "New  tpr");
		call	print_tpr;
		end;

	return;

assign_label(13):			/*	assign_even	*/

	if	print_mode  =  1

		then  do;
		call	print_text_$format( addr( scup -&gt; scu.even_inst), source_string);
		call	ioa_$ioa_stream (debug_output, "Old  even instruction:  ^a", source_string);
		end;

	scup -&gt; scu.even_inst  =  print_word2;

	if	print_mode  =  1

		then  do;
		call	print_text_$format( addr( scup -&gt; scu.even_inst), source_string);
		call	ioa_$ioa_stream (debug_output, "New  even instruction:  ^a", source_string);
		end;

	return;

assign_label(14):			/*	assign_odd	*/

	if	print_mode  =  1

		then  do;
		call	print_text_$format( addr( scup -&gt; scu.odd_inst), source_string);
		call	ioa_$ioa_stream (debug_output, "Old  odd instruction:  ^a", source_string);
		end;

	scup -&gt; scu.odd_inst  =  print_word2;

	if	print_mode  =  1

		then  do;
		call	print_text_$format( addr( scup -&gt; scu.odd_inst), source_string);
		call	ioa_$ioa_stream (debug_output, "New  odd instruction:  ^a", source_string);
		end;

	return;

	end	db_regs;




		    db_sym.pl1                      11/05/86  1217.3r w 11/04/86  1042.2      103068



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


db_sym: proc (line, a_sntp, data_ptr, offset, type, type_char, mode, a_size, m_size, code);


/*	Modified Nov 72 to convert to PL/I V2 by R Coren.
   *	Modified Nov 72 for 6180 (remove check entry ) by Bill Silver.
   *	Modified 10/76 to add COBOL data types by S. Barr. */
/* Changed to test for Version 1/pascal symbol table before testing data_ptr 10/14/83 S. Herbst */
dcl  line char (72) varying,
     a_sntp ptr,
     data_ptr ptr,
     offset fixed bin,
     type_char char (1) aligned,
     mode char (*) aligned,
     size fixed bin,
     a_size fixed bin,
     m_size fixed bin,
     code fixed bin;


dcl (addr, addrel, baseno, divide, fixed, length, min, null, ptr, rel, substr, unspec) builtin;

dcl  var_flag fixed bin;

dcl (type, n, i, j, steps) fixed bin,
     f17 fixed bin based,
    (p, stack_pt, found_block, symbol_pt, ref_pt) ptr,
     current_block ptr,
     packed_ptr based unaligned ptr,
     based_ptr based ptr,
     bn bit (18) aligned,
     db_get_sym ext entry (ptr),
     stu_$find_runtime_symbol entry (ptr, char (*) aligned, ptr, fixed bin) returns (ptr),
     stu_$get_runtime_address entry (ptr, ptr, ptr, ptr, ptr, ptr, ptr) returns (ptr),
     stu_$offset_to_pointer entry (ptr, ptr, ptr, ptr, ptr, ptr) returns (ptr),
     stu_$decode_runtime_value entry (fixed bin, ptr, ptr, ptr, ptr, ptr, fixed bin) returns (fixed bin);

dcl  decode_type char (32) int static aligned
     init ("oddfooooooooopoppoobvavoiiip");
						/*  */
%include db_snt;
/*  */
%include stack_frame;
%include picture_image;
/*  */
%include symbol_node;
/*  */
%include runtime_symbol;
%include stu_frame;
/*  */
	sntp = a_sntp;				/* copy arg. */
	if sntp -&gt; snt.symflag then call db_get_sym (sntp); /* attempt to get symbol pointer */
	current_block = sntp -&gt; snt.symp;

	if current_block = null
	then do;
err2:	     code = 2;				/* no symbol table */
	     return;
	end;

	if baseno (sntp -&gt; snt.lp) = "0"b then sntp -&gt; snt.lp = null;

	code = 0;

	symbol_pt = db_var (1, (1), data_ptr, ref_pt, stack_pt);

	if symbol_pt = null
	then do;
err1:	     code = 1;				/* symbol not found */
	     return;
	end;

	if data_ptr = null
	then do;
err5:	     code = 5;				/* couldn't get address */
	     return;
	end;

/* have Version II symbol node */

	type = fixed (symbol_pt -&gt; runtime_symbol.type, 6);

	if type = 38 | type = 39 then mode = "comp-5";
	else if type = 41 then mode = "comp-8";
	else if type = 63 then do;			/* PICTURE */
	     mode = "a";
	     p = ptr (snt.pp, symbol_pt -&gt; runtime_symbol.size);
	     size = p -&gt; picture_image.varlength;
	     type = 21;
	     goto l2;
	end;
	else mode = substr (decode_type, type+1, 1);
	var_flag = 0;

	if mode = "p" then do;
	     if symbol_pt -&gt; runtime_symbol.packed then size = 36;
	     else size = 72;
	     go to l2;
	end;

	if mode = "v" then do;
	     var_flag = 1;
	     mode = substr (decode_type, type, 1);
	     a_size = data_ptr -&gt; f17;
	     data_ptr = addrel (data_ptr, 1);
	     type = type - 1;
	end;

	size = symbol_pt -&gt; symbol_node.size;
	if size &lt; 0
	then do;
	     size = stu_$decode_runtime_value (size, found_block, stack_pt,
		sntp -&gt; snt.lp, sntp -&gt; snt.pp, ref_pt, code);
	     if code ^= 0 then do;
		code = 6;
		return;
	     end;
	end;


	if type = 3|type = 4 then size = size + 8;	/* floating-point, add in bits for exp */

	else if type = 14 then size = 36;			/* offset must be one fullword */

/* packed decimal */
	else if type = 38 then size = divide (size*9, 2, 17, 0);	/* unsigned */
	else if type = 39 | type = 41 then size = divide ((size+1)*9, 2, 17, 0);	/* sign uses one digit */

	else if mode ^= "a" &amp; mode ^= "b" then do;
	     if ^symbol_pt -&gt; symbol_node.packed then	/* unpacked, round size up to word */
		if size &lt; 36 then size = 36;
		else size = 72;
	     else size = size + 1;			/* add sign bit to precision */
	end;

l2:	bn = baseno (data_ptr);

	m_size = size;
	if var_flag = 0 then a_size = size;
	else a_size = min (a_size, size);

	if bn = baseno (sntp -&gt; snt.sp)
	then do;
	     type_char = "s";
	     offset = fixed (rel (data_ptr), 18) - fixed (rel (sntp -&gt; snt.sp), 18);
	     return;
	end;

	if bn = baseno (sntp -&gt; snt.static_ptr)
	then do;
	     type_char = "i";
	     offset = fixed (rel (data_ptr), 18) - fixed (rel (sntp -&gt; snt.static_ptr), 18);
	     return;
	end;

	if bn = baseno (sntp -&gt; snt.lp)
	then do;
	     type_char = "l";
	     offset = fixed (rel (data_ptr), 18) - fixed (rel (sntp -&gt; snt.lp), 18);
	     return;
	end;

	type_char = "i";
	offset = 0;
exit:	return;

text_ref:	data_ptr = ptr (sntp -&gt; snt.pp, 0);
	type_char = "t";
	mode = "i";
	goto l1;

link_ref:	if rel (sntp -&gt; snt.lp) = (18)"0"b
	then do;
err3:	     code = 3;				/* no linkage */
	     return;
	end;

	data_ptr = sntp -&gt; snt.lp;
	type_char = "l";

l1:	data_ptr = addrel (data_ptr, offset);
	return;

err4:	code = 4;					/* no stack frame */
	return;

err7:	code = 7;					/* syntax error */
	return;

err8:	code = 8;					/* array error */
	return;

err9:	code = 9;					/* value error */
	return;

err10:	code = 10;				/* based error */
	return;

err11:	code = 11;				/* more than 64 structure levels */
	return;

err12:	code = 12;				/* symbol too long */
	return;

err13:	code = 13;				/* ambiguous reference */
	return;

err14:	code = 14;				/* entry constant */
	return;

err15:	code = 15;				/* unsupported symbol table format (V1, Pascal) */
	return;

db_var:	proc (start_pos, end_pos, data_pt_out, ref_pt_out, stack_pt_out) returns (ptr);

dcl  start_pos fixed bin,				/* start index in line */
     end_pos fixed bin,				/* finish index in line (output) */
     data_pt_out ptr,				/* ptr to datum (output) */
     ref_pt_out ptr,				/* ref ptr for datum (output) */
     stack_pt_out ptr;				/* stack pointer for datum (output) */

dcl (p, q, s_pt, d_pt, r_pt, sp, dummy_pt, subs_pt) ptr,
    (pos, n, m, val, type, steps, subscript (32)) fixed bin,
    (thru, nosign) bit (1),
     ch char (1),
     db_get_count$dec entry (char (*) aligned, fixed bin, fixed bin) returns (fixed bin);

dcl  char_type (0: 127) fixed bin int static
     init ((33)0, 1, (2)0, 1, (9)0, 1, 0, (10)2, (7)0, (26)1, (4)0, 1, 0, (26)1, (5)0);

/*	char_type:	2     number
   1     letter ! $ . _
   0     other
   */

dcl  line_ char (72) aligned;

dcl  fix_single fixed bin (17) based,
     fix_double fixed bin (53) based,
     flt_single float bin (27) based,
     flt_double float bin (63) based;

	     pos = start_pos;
	     thru = "0"b;
	     r_pt, d_pt, s_pt = null;

again:	     call sob;
	     if thru then goto err7;

	     n = pos;
loop:	     ch = substr (line, pos, 1);
	     type = char_type (fixed (unspec (ch), 9));

	     if type &gt; 0
	     then do;
		pos = pos + 1;
		if pos &lt;= length (line) then goto loop;
		thru = "1"b;
	     end;

	     s_pt = stu_$find_runtime_symbol (current_block, substr (line, n, pos-n), found_block, steps);

	     if s_pt = null
	     then if steps = -2 then goto err11;
		else if steps = -3 then goto err12;
		else if steps = -5 then goto err13;
		else goto err1;

	     if ^s_pt -&gt; runtime_symbol.flag then go to err15;

	     subs_pt = null;

	     if thru
	     then do;
chk_tl:		if n &gt; 1 then goto ga;

		offset = fixed (s_pt -&gt; symbol_node.offset, 18);

		if s_pt -&gt; symbol_node.class = "1100"b	/* check for label/entry constant */
		then if s_pt -&gt; runtime_symbol.flag
		     then if s_pt -&gt; runtime_symbol.type = "011000"b
			then goto text_ref;		/* label constant is simple */
			else if s_pt -&gt; runtime_symbol.type = "011001"b
			then go to err14; else;
		     else if s_pt -&gt; symbol_node.type = "000000100101"b
		     then goto text_ref;
		     else if s_pt -&gt; symbol_node.type = "000000100100"b
		     then go to err14;

		if s_pt -&gt; symbol_node.class = "1101"b
		then if s_pt -&gt; runtime_symbol.flag
		     then if s_pt -&gt; runtime_symbol.type = "011010"b /* ext entry in */
			then go to err14;
			else go to link_ref;

		     else if s_pt -&gt; symbol_node.type = "000000100100"b /* likewise */
		     then go to err14;
		     else go to link_ref;

		goto ga;
	     end;

	     call sob;
	     if thru then goto chk_tl;

	     if ch ^= "(" then goto ga;

	     n = 1;
sub_loop:	     pos = pos + 1;
	     call sob;
	     if thru then goto err7;

	     val = 0;
	     nosign = "1"b;
	     type = char_type (fixed (unspec (ch), 9));

	     if type ^= 1 then goto s1;

	     p = db_var (pos, pos, q, dummy_pt, dummy_pt);

	     if p = null then goto err1;
	     if q = null then goto err1;

	     if p -&gt; runtime_symbol.flag then type = fixed (p -&gt; runtime_symbol.type, 6);
	     else do;
		type = fixed (p -&gt; symbol_node.type, 12);
		if type &gt; 16 then type = type - 16;
	     end;

	     if type = 1 then val = q -&gt; fix_single;
	     else if type = 2 then val = q -&gt; fix_double;
	     else if type = 3 then val = q -&gt; flt_single;
	     else if type = 4 then val = q -&gt; flt_double;
	     else goto err9;

	     nosign = "0"b;

	     call sob;
	     if thru then goto err7;

s1:	     if ch = "+" | ch = "-" | (type = 2 &amp; nosign)
	     then do;
		line_ = line;
		val = val + db_get_count$dec (line_, pos, pos);
		call sob;
		if thru then goto err7;
	     end;

	     subscript (n) = val;

	     if ch = ","
	     then do;
		n = n + 1;
		if n &gt; 32 then goto err8;
		goto sub_loop;
	     end;

	     if ch ^= ")" then goto err7;

	     if n ^= fixed (s_pt -&gt; symbol_node.ndims, 6) then goto err8;

	     if current_block -&gt; runtime_block.flag
	     then if current_block -&gt; runtime_block.fortran
		then do i = 1 to divide (n, 2, 17, 0);
		     m = subscript (i);
		     subscript (i) = subscript (n-i+1);
		     subscript (n-i+1) = m;
		end;

	     subs_pt = addr (subscript (1));

	     pos = pos + 1;
	     call sob;

ga:
	     sp = sntp -&gt; snt.sp;

	     do i = 1 to steps while (sp ^= null);
		sp = sp -&gt; frame.display;
	     end;


	     d_pt = stu_$get_runtime_address (found_block, s_pt, sp, sntp -&gt; snt.lp,
		sntp -&gt; snt.pp, r_pt, subs_pt);

	     if d_pt = null then goto err5;

	     if thru then goto done;

	     if substr (line, pos, 2) = "-&gt;"
	     then do;
		pos = pos + 2;

		if s_pt -&gt; runtime_symbol.type = "001110"b /* offset */
		then do;
		     r_pt = stu_$offset_to_pointer (found_block, s_pt, d_pt,
			sp, sntp -&gt; snt.lp, sntp -&gt; snt.pp);
		     go to again;
		end;

		if s_pt -&gt; runtime_symbol.type ^= "001101"b
		then if s_pt -&gt; runtime_symbol.type ^= "011101"b
		     then goto err10;
		if ^ s_pt -&gt; runtime_symbol.flag
		then if substr (s_pt -&gt; symbol_node.type, 1, 6)
		     then goto err10;
		if s_pt -&gt; runtime_symbol.packed then r_pt = d_pt -&gt; packed_ptr;
		else r_pt = d_pt -&gt; based_ptr;
		goto again;
	     end;

done:	     end_pos = pos;
	     data_pt_out = d_pt;
	     ref_pt_out = r_pt;
	     stack_pt_out = sp;
	     return (s_pt);

sob:	     proc;

sl:		if pos &gt; length (line)
		then do;
fini:		     thru = "1"b;
		     return;
		end;

		ch = substr (line, pos, 1);
		if ch ^= " " then return;
		pos = pos + 1;
		goto sl;
	     end;


	end db_var;
     end;




		    debug.pl1                       11/05/86  1217.3r w 11/04/86  1034.0      192051



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

debug: db: procedure;
/*	This is the main procedure of the  debug  package.  It has two entries:
   *
   *	1.  The  CALLED entry "debug" or "db" is entered when debug is called by
   *	    a user.
   *
   *	2.  "mme2_fault"  is entered to handle a mme2 fault, i.e., a break.
*/

/*		PARAMETER  DATA		*/
dcl  arg_mcp ptr;					/* Pointer to the machine conditions that is
						   *  passed to the mme2 fault entry.  This pointer
						   *  is generated by the "signaller" and is
						   *  handed down to  "debug".  */

/*		AUTOMATIC  DATA		*/
/*	Below is the automatic area reserved for common data.   Also declared is the area
   *	where the  SNT  table is built.
*/

dcl  common_auto_area (88) fixed bin aligned,

     snt_area (70) fixed bin aligned;

dcl 1 save aligned like db_ext_stat_$db_ext_stat_;
dcl  break_num fixed bin,				/* Number of the break that caused the
						   *  mme2 fault.  */

     break_ptr ptr,					/* Pointer to where the break occurred.  */

     temp_break_ptr ptr;				/* Pointer to where a temporary break will
						   *  be set.  */
dcl  comd_len fixed bin,				/* The length of the command line in a break.
						   *  0 =&gt; no command line.  */

     comd_ptr ptr,					/* Pointer to the command line  IN THE BREAK.  */

     cond_flag fixed bin;				/* A flag indicating whether a given break
						   *  should be skipped due to an unsatisfied
						   *  condition.  Its values are:
						   *  0 =&gt; NO - No condition or condition met.
						   *  1 =&gt; YES - Skip break, condition not met.  */
dcl  i fixed bin;					/* Work variable.  */

dcl  input_buffer char (132) aligned,			/* Area where the user commands are read.  */

     input_buffer_ptr ptr,				/* Pointer to the beginning of this area.  */

     input_line_len21 fixed bin (21),			/* For use with iox_ */
     input_line_len fixed bin;			/* Actual length of user's input command.  */

dcl  printer_on char (1) init ("");			/* Turn printer on "006" */

dcl  line_num fixed bin,				/* Source line number associated with an
						   *  offset in an object segment.  */

     line_1st_inst_off fixed bin,			/* The offset of the FIRST instruction of
						   *  a given source line.  */

     line_num_inst fixed bin;				/* Number of instructions used to implement
						   *  a given source line.  */

dcl  line_info char (14) aligned;			/* Line number for printing. */

dcl  last_sp ptr;					/* Pointer to the last stack frame in the
						   *  stack history which we will use as
						   *  part of our trace.  */

dcl  cleanup condition;
dcl  command_abort_ condition;
dcl  code fixed bin (35);
dcl  new_line char (1) init ("
");						/* new line character */
/*	The label used by the condition handling procedures.  */
dcl  read_line_label label;


/*		INTERNAL  STATIC  DATA	*/
/*	Below is the static area reserved for common data.  */

dcl  common_static_area (1063) fixed bin internal static aligned;
dcl  static_init_count fixed bin internal static init (0);
dcl  initial_flag bit (1) int static init ("0"b);



/*		EXTERNAL  DATA		*/
%include db_ext_stat_;

dcl 1 d like db_ext_stat_$db_ext_stat_ based (addr (db_ext_stat_$db_ext_stat_));
dcl  condition_ ext entry (char (*), entry),
     cu_$stack_frame_ptr ext entry returns (ptr),
     db_break$check_break ext entry (ptr, fixed bin, ptr, fixed bin, fixed bin,
     fixed bin, ptr, fixed bin),
     db_break$restart ext entry (ptr, fixed bin, fixed bin, ptr, fixed bin),
     db_break$set_break ext entry (ptr, fixed bin, ptr, fixed bin),
     db_fill_snt ext entry (ptr, ptr),
     db_find_mc ext entry (ptr, bit (1) aligned, ptr),
     db_parse ext entry (ptr, fixed bin, ptr, ptr),
     debug$mme2_fault ext entry (ptr),
     hcs_$high_low_seg_count ext entry (fixed bin, fixed bin),
     ioa_$ioa_stream ext entry options (variable),
     ioa_$rsnnl ext entry options (variable),
     legal_f_ ext entry (ptr) returns (fixed bin),
     db_line_no ext entry (ptr, fixed bin (18), fixed bin, fixed bin, fixed bin);
dcl  iox_$control ext entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$user_output ptr ext;
dcl  iox_$user_input ptr ext;
dcl  iox_$get_line ext entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$close ext entry (ptr, fixed bin (35));
dcl  iox_$detach_iocb ext entry (ptr, fixed bin (35));
dcl  com_err_ ext entry options (variable);
dcl  error_table_$long_record ext fixed bin (35);
dcl  error_table_$not_attached ext fixed bin (35);
dcl  error_table_$not_open ext fixed bin (35);
dcl (addr,
     addrel,
     baseptr,
     fixed,
     null,
     ptr) builtin;
						/*  */
%include db_common_auto;
%include db_common_static;
/*  */
%include db_inst;
/*  */
%include db_snt;
/*  */
%include stack_header;
%include stack_frame;
%include mc;
/*  */
/* CALLED  ENTRY  -  This is where  "debug" is entered when the user calls "debug". */

	if static_init_count = 0 then call set_internal_stat;

	call set_ext_stat;
	d.static_handler_call = "0"b;

	com_stat_ptr = addr (common_static_area);
	com_auto_ptr = addr (common_auto_area);
	sntp = addr (snt_area);

	call condition_ ("mme2", debug$mme2_fault);

	break_num = 0;				/* debug was called so there is no break number */
	temp_break_mode = 0;			/* Not in temporary break mode */
	num_skips = 0;				/* No skip count since no break. */

/* Now get a pointer to the last  sp  we will use in the stack history trace.  It
   must be the frame before the  "debug"  frame. */

	last_sp = cu_$stack_frame_ptr () -&gt;		/* Pointer to our frame. */
	     stack_frame.prev_sp;			/* ptr to the frame of the procedure that called debug */
/* Now get a pointer to the machine conditions of the last fault that was taken
   before  "debug" was called.  The stack frame of the procedure that took the
   fault must still be in the stack history if we are to get a pointer to the
   machine conditions.  If there is no fault frame in the stack history it is OK.
   The user just won't have any registers to play with.  If he tries to reference
   a machine register  "db_regs"  will tell him.
*/

	call db_find_mc (last_sp, "0"b, db_mc_ptr);

/* Now call an internal procedure that will perform the rest of the initialization.
   Once this is done we can start reading in user commands. */

	call common_init;

	goto read_line;				/* Go get user commands. */

/*  */
/* This entry is entered via a mme2 fault that occurred at a break point.  The input
   argument points to the machine conditions associated with this fault.

   There are two cases in which the break will be skipped.  In both cases debug will not print any message
   a)  The break has a non zero skip count.
   b)  The break contains a condition but the condition has not been met.
   */
mme2_fault: entry (arg_mcp);

	if static_init_count = 0 then do;		/* in case debug is entered via static handler */
	     call set_internal_stat;
	     call set_ext_stat;
	     d.static_handler_call = "1"b;
	end;

	com_stat_ptr = addr (common_static_area);
	com_auto_ptr = addr (common_auto_area);
	sntp = addr (snt_area);

	db_mc_ptr = arg_mcp;			/* The machine conditions associated with
						   *  this fault serve as our registers.  */

/* From the SCU data we get the address of where the mme2 fault occurred - in effect the PPR.  The
   The address field of the mme2 instruction contains the break number.
*/
	scup = addr (db_mc_ptr -&gt; mc.scu);
	break_ptr = ptr (baseptr (fixed (scup -&gt; scu.ppr.psr)), scup -&gt; scu.ilc);
	break_num = fixed (break_ptr -&gt; instr.offset);
	last_sp = db_mc_ptr -&gt; mc.prs (spx);		/* stack frame of the procedure that took the fault. */
	call db_fill_snt (last_sp, sntp);
	call db_break$check_break (break_ptr, break_num, sntp, cond_flag, num_skips, comd_len, comd_ptr, line_num);

/* If the break could not be handled (it was not enabled, it was a version 1 break), the user will enter command
   mode for debug. */

	if break_ptr = null then do;
	     call common_init;
	     goto  read_line_label;
	end;

	if (cond_flag = 1) | (num_skips &gt; 0) then goto restart_break;

	call common_init;

	if line_num &gt; 0 then call ioa_$rsnnl ("at line ^d", line_info, i, line_num);
	else line_info = "";

	if print_mode = 0 then call ioa_$ioa_stream (d.debug_output, "Break  ^d ^a  of  ^a", break_num, line_info, snt.ent_name);
	else call ioa_$ioa_stream (d.debug_output, "^RBreak  ^d  ^a  of  ^a  -  at  ^p^B",
	     break_num, line_info, snt.ent_name, break_ptr);
	if temp_comd_len ^= 0			/* temporary global command */
	then call db_parse (addr (temp_comd_line), temp_comd_len, com_auto_ptr, com_stat_ptr);

	if comd_len ^= 0				/* conditional break */
	then call db_parse (comd_ptr, comd_len, com_auto_ptr, com_stat_ptr);

	goto db_action_label (db_action_code);
						/*  */

/*	These condition handlers  return to "read_line".  The stack frame that
   *	"debug" will be running on will be the last  "debug" stack frame regardless of
   *	how  "debug" was entered.
*/

conversion_handler: procedure;

	     call ioa_$ioa_stream (d.debug_output, "Conversion error");
	     goto read_line_label;

	end conversion_handler;

prog_interrupt_handler: procedure;

	     goto read_line_label;

	end prog_interrupt_handler;
/*  The any_other_handler prints the name of the condition and goes to read the next
   request from the user.  The condition will be passed on if the user was not in
   debug when the condition occurred or the condition is not in the conditions table.

   The user is not in debug in the following cases:

   *	db_parse		(..) when a procedure is executed
   *			(:=) when a subroutine call is made

   *	debug		(.c) when the user continues execution after a break
*/

any_other_handler: proc (mcptr, name, wcptr, info_ptr, cont);

dcl  mcptr ptr,
     name char (*),
     wcptr ptr,
     info_ptr ptr,
     cont bit (1);
dcl  conditions char (106) init ("conversion,fixedoverflow,out_of_bounds,overflow,underflow,zerodivide,stringrange,stringsize,subscriptrange");

	     if d.in_debug then do;			/* only handle debug conditions */

		if name = "db_conversion" then name = "conversion";
		if index (conditions, name) &gt; 0 then do;
		     call ioa_$ioa_stream (d.debug_output, "db: ^a", name);
		     go to read_line_label;
		end;
	     end;

	     cont = "1"b;
	     return;

	end any_other_handler;

/*  */

/*	This routine will read a user command and then call the parsing procedure to
   *	process the command line.  What we do when the parsing procedure returns depends
   *	upon the action code which the parsing procedure sets.  Thus the contents of the
   *	command line determines what we do next.
*/

read_line:
db_action_label (0):
	call iox_$get_line (d.debug_io_ptr (1), input_buffer_ptr, 132, input_line_len21, code);
	input_line_len = input_line_len21;

	if code ^= 0 then do;
	     call com_err_ (code, "debug");
	     if code = error_table_$long_record then go to read_line;
	     else go to quit;
	end;
	if input_line_len = 1 then goto read_line;	/* Is it a blank line?  */
	db_action_code = 0;				/* in case different value was returned before */

	call db_parse (input_buffer_ptr, input_line_len, com_auto_ptr, com_stat_ptr);

	goto db_action_label (db_action_code);

/* resetread:	Flush read ahead because last request was incorrect */

db_action_label (1):

	call iox_$control (d.debug_io_ptr (1), "resetread", null, code);
	if code ^= 0 then call com_err_ (code, "debug");
	goto read_line;

/*  Quit  debug  */
db_action_label (2):
quit:

	if break_num = 0 then do;			/* debug was CALLED */
	     call restore;
	     return;
	end;

/* If this invocation was through a mme2 fault, return is made to the stack frame that had the call to debug.
   If debug was originally invoked via a static handler and return is not possible. */

	if ^d.flags.static_handler_call then goto d.return_label;
	signal command_abort_;
	goto read_line;

return_from_debug:					/* This is where the previous goto will transfer to.
						   However, we will now be in a different stack frame. */

	call restore;				/* Restore i/o attachments &amp; external data */
	return;					/* Return to CALLER. */

/*	This routine is called when the user wants to restart a break.  Note that all of
   *	the data needed to restart the break has been set up by  "debug".  Only the num_skips
   *	field could have been modified by a user if  the parse procedure was called to
   *	process a command line.  If there is no break number then  "debug" was entered
   *	via a  CALL.  Thus there is no break to restart.  We will just go and read in
   *	another command line.
   */

restart_break:
db_action_label (3):
	if break_num = 0 | break_ptr = null

	then do;
	     call ioa_$ioa_stream (d.debug_output, "No break fault, cannot restart break.");
	     goto read_line;
	end;
/*	There was a break fault so we can restart this break.  First we will check to
   *	see if we are in  temporary break mode.  If we are we will set a temporary break.
   *	The location of the temporary break will be at the beginning of the next line if
   *	there are line numbers available.  Otherwise it will be at the next instruction.
*/

	if temp_break_mode ^= 0			/* Are we in temporary break mode?  */

	then do;					/* YES */

	     call db_fill_snt (last_sp, sntp);

	     call get_line_num;			/* Get temporary break pointer.  */

	     call db_break$set_break (temp_break_ptr, 1, sntp, print_mode);

	end;
/*	Now we will call  db_break to restart the break.  It will fiddle with our  SCU
   *	data so that when we say  "return"  the instruction that was replaced by the
   *	mme2  will eventually be executed.  We return to the procedure that called  "debug"
   *	at the  mme2 fault entry.  Eventually a return is made to the signaller who does
   *	an  "RCU"  instruction from our  SCU  data.  This will restart the procedure which
   *	will execute as if the break never happened.
*/

	d.in_debug = "0"b;				/* restart break means leaving debug */
	call db_break$restart (break_ptr, break_num, num_skips, scup, print_mode);
	return;					/* This will begin the process which will
						   *  restart the procedure.  */
						/*  */
common_init: procedure;
/*	This procedure is called to perform initialization that is common the both the
   *	CALLED and the  mme2_fault entries.  It will not be called at all if the  mme2 fault
   *	entry immediately restarts the break.
*/

/*	First initialize the rest of the common automatic variables.  Also set up
   *	the pointer to the input buffer.
*/

	     first_call_flag,
		db_action_code = 0;

	     input_buffer_ptr = addr (input_buffer);
/*	Establish condition handlers for illegal  debug  conversions and for program
   *	interrupts.  Both of these condition handlers will go to  "read_line"  to get
   *	another input line.  At that time  "debug"  will be executing out of the last
   *	"debug"  stack frame regardless of how it was entered.
*/

	     read_line_label = read_line;
	     call condition_ ("db_conversion", conversion_handler);
	     call condition_ ("program_interrupt", prog_interrupt_handler);

	     call condition_ ("any_other", any_other_handler);
	     d.in_debug = "1"b;

/*	Now trace the stack history.  We will start at the beginning of the stack and
   *	trace until we reach the frame we have designated as the last frame.  The pointer
   *	to this frame is in  "last_sp".  The index of the  stack_ptr_array  entry for
   *	this last frame will be saved in the common variable  "max_sp_x".
*/
	     sp = ptr (last_sp, 0) -&gt; stack_header.stack_begin_ptr; /* Get a pointer to the first
						   *  frame in the stack.  Note,
						   *  it is a dummy and will
						   *  be skipped.  */
	     do i = 0 to 511;

		if legal_f_ (sp) ^= 0		/* Is it a legal frame?  */

		then do;				/* NO. */

		     max_sp_x = i - 1;		/* Previous frame is the last one
						   *  we can use in the stack history.  */

		     call ioa_$ioa_stream (d.debug_output, "Cannot trace stack past depth  ^d", i-1);

		     goto get_snt_data;		/* End stack trace. */

		end;
		stack_ptr_array (i) = sp;		/* Stack is legal. Save its pointer
						   *  in the stack array. */

		if sp = last_sp			/* Is this the last stack frame we
						   *  want to trace?  */

		then do;				/* YES.  This is the end of the trace.  */

		     max_sp_x = i;			/* Save number of valid stack frames
						   *  in the trace.  */

		     goto get_snt_data;

		end;

		sp = sp -&gt; stack_frame.next_sp;	/* Get a pointer to the next frame. */

	     end;
/*	If we get here we have overflowed the stack array area.  Tell the user. */

	     call ioa_$ioa_stream (d.debug_output, "Stack array overflow has occurred.");

	     max_sp_x = i - 1;
/*	Now that the stack trace has finished we will fill in the SNT table from the data
   *	in the last stack frame in the trace.
*/

get_snt_data:

	     call db_fill_snt (stack_ptr_array (max_sp_x), sntp);

	     snt_ptr = sntp;

	end common_init;
						/*  */
get_line_num: procedure;
/*	This internal procedure is called to get the line number of the instruction at
   *	the current break point.  It will also return a pointer to where the next temporary
   *	break point should be set.  If we can't get the line number then a line number
   *	value of (-1) will be returned.  This procedure assumes that "break_ptr" points to
   *	the break point and that "sntp" points to valid  SNT  data of the fault frame.
*/

/*	Get the line number. */

	     call db_line_no (sntp, fixed (rel (break_ptr), 18), line_1st_inst_off,
		line_num_inst, line_num);
	     if line_num &gt; -1			/* Did we get a line number.  */
	     then do;				/* YES, temporary pointer is beginning of
						   *  next line.  */

		temp_break_ptr = ptr (break_ptr, line_1st_inst_off + line_num_inst);

		return;
	     end;

/*	Either we couldn't get a symbol pointer or we couldn't get a line number.  In
   *	any case we will return a line number of (-1) and the temporary break pointer
   *	will be equal to the instruction after the break point.
*/

	     line_num = -1;

	     temp_break_ptr = addrel (break_ptr, 1);
	end get_line_num;
restore:	proc;

/*	This procedure is called when the user quits debug or when the cleanup condition
   *	is signaled.
   *	  1.  Any i/o attachments that were made by debug are detached.
   *	  2.  The external data is restore to its initial value when debug was called.
*/

	     do i = 1 to 2;

		if d.debug_io_open (i) then do;
		     call iox_$close (d.debug_io_ptr (i), code);
		     if code ^= 0 then if code ^= error_table_$not_open then call com_err_ (code, "debug");
		end;

		if d.debug_io_attach (i) then do;
		     call iox_$detach_iocb (d.debug_io_ptr (i), code);
		     if code ^= 0 then if code ^= error_table_$not_attached then call com_err_ (code, "debug");
		end;
	     end;

	     d = save;				/* restore external static data */
	     static_init_count = static_init_count - 1;

	     return;
	end restore;

/*  */
/* The external static is setup to work like controlled storage.  When debug is called, the
   external static is copied into automatic storage.  Before the user returns from debug, the external static is
   restored using the values saved in automatic storage.  This is required for the return_label and is also
   convienent for cleanup for users who change the io switches. */

set_ext_stat: proc;

	     save = d;				/* save ext static data */
	     d.debug_input = "user_input";
	     d.debug_output = "user_output";
	     d.debug_io_open (1), d.debug_io_open (2), d.debug_io_attach (1), d.debug_io_attach (2) = "0"b;
	     d.debug_io_ptr (1) = iox_$user_input;
	     d.debug_io_ptr (2) = iox_$user_output;
	     static_init_count = static_init_count + 1;

/* When the user issues a debug quit command we want to return to the procedure which
   called "debug".  Thus we must be using the stack frame of "debug" when it was entered
   via a call.  In order to quit out of debug when it was entered via a fault we must
   do a non local goto back to the stack frame of "debug" when it was entered via a call. */

	     d.return_label = return_from_debug;

	     on cleanup call restore;

	end set_ext_stat;
set_internal_stat: proc;

	     com_stat_ptr = addr (common_static_area);	/* common static data */
	     if initial_flag then return;

	     call hcs_$high_low_seg_count (i, hcs_count);

	     sb = ptr (cu_$stack_frame_ptr (), 0);	/* ptr to base of stack */
	     lotp = sb -&gt; stack_header.lot_ptr;		/* ptr to base of the linkage */

	     print_mode = 1;			/* long message mode */
	     temp_comd_len = 0;			/* no temporary global break command line */
	     initial_flag = "1"b;

	end set_internal_stat;
     end debug;
�



		    fix_bit.alm                     11/04/82  1959.8rew 11/04/82  1609.4       11106



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

	name	fix_bit

	entry 	fix_bit
	entry	double

"	This little function takes a left-adjusted bit string and
"	right-adjusts it in a word, propagating the sign. It can
"	be called from pl1 thus:

"	fixed_bin_word = fixed_bit(aligned_bit, length);

"	where length is the number of bits in the string (if it
"	exceeds 36 use entry point double below).


fix_bit:	lda	ap|2,*
	ldq	36,dl
	sbq	ap|4,*
	ars	0,ql
	sta	ap|6,*
	short_return


"	This entry point is used when the string is longer
"	than 36 bits (but not more than 72). It returns its
"	result in a fixed bin(71) number, thus:
"
"	fixed_bin_71 = fix_bit$double(aligned_bit, length);
"
"

double:	ldq	72,dl
	sbq	ap|4,*
	eax0	0,ql
	ldaq	ap|2,*
	lrs	0,0
	staq	ap|6,*
	short_return


	end
��



		    legal_f_.pl1                    11/05/86  1217.3r w 11/04/86  1042.2       19116



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


legal_f_: proc (arg_stack_frame_ptr, code);

/* This procedure makes some validity checks on the stack frame pointer.  It makes sure the current stack frame
   and the previous and next frames are at location modulo 16.  If the current and next frame are in the same
   segment, the procedure checks that they are in order.
*/

dcl  arg_stack_frame_ptr ptr;				/* ptr to stack frame to be checked */
dcl  code fixed bin (35);

dcl (null, baseno, fixed, rel) builtin;
%include stack_frame;

/*  */
	code = 0;
	sp = arg_stack_frame_ptr;
	if sp = null then code = 1;
	else do;
	     call check_ptr (sp);
	     call check_ptr (sp -&gt; stack_frame.prev_sp);
	     call check_ptr (sp -&gt; stack_frame.next_sp);

	     call check_frame (sp, sp -&gt; stack_frame.next_sp);
	     call check_frame (sp -&gt; stack_frame.prev_sp, sp);
	end;

	return;

/*  */
/* If a stack frame pointer is not null, it must be modulo 16. */

check_ptr: proc (p);

dcl  p ptr;
dcl  zero_mod_16_test bit (18) aligned static options (constant) init ("000000000000001111"b);

	     if p ^= null then if rel (p) &amp; zero_mod_16_test then code = 1;

	end check_ptr;


/* If two stack frame pointers are in the same segment, a check is made that the second frame follows the first
   and that the first stack frame is of the minimum length. */

check_frame: proc (s1, s2);

dcl  s1 ptr;					/* ptr to lower stack frame */
dcl  s2 ptr;					/* ptr to higher stack frame */

	     if baseno (s1) = baseno (s2)
	     then if fixed (rel (s2), 18) - fixed (rel (s1), 18) &lt; stack_frame_min_length then code = 1;

	     return;

	end check_frame;

     end legal_f_;




		    list_arg_.pl1                   11/04/82  1959.8rew 11/04/82  1609.4       51615



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


list_arg_: proc(argno,atype,ap);

dcl  argno fixed bin (18),
     atype char (1) aligned;


dcl  argp ptr,
     decode_descriptor_ entry(ptr,fixed bin(18),fixed bin(18),bit(1) aligned,
     fixed bin(18),fixed bin(18),fixed bin(18)),
     ioa_$ioa_stream ext entry options(variable),
    (i,min_arg,max_arg,type) fixed bin (18),
     c72 char (72) aligned,
     bit17 bit (17) unaligned based (argp),
     fword fixed bin (18) based (argp),
     flword float bin based (argp),
    dblword float bin(63) based (argp),
    (no_args,no_desc,j,strl,ndims,scale) fixed bin (18),
     packed bit(1) aligned,
     bit_string bit (strl) based (argp),
     char_string char(strl) based (argp);

%include db_ext_stat_;

dcl  based_p ptr based;


dcl 1 lv based,
    2 ptr ptr,
    2 stack ptr;

%include its;

%include db_arg_list;

	no_args = arg_list.num_args;			/* get the number of arguments */
	if no_args = 0 then do;			/* check for no arguments */
	     call ioa_$ioa_stream (debug_output, "No arguments.");
	     return;
	end;
	no_desc = arg_list.num_desc;			/* and the number of descriptors */
	if argno &lt;= 0 then do;
	     min_arg = 1;				/* print out all arguments */
	     max_arg = no_args;
	end;
	else min_arg, max_arg = argno; 		/* just print out the one argument */

	if argno &gt; no_args then do; 			/* check for argument number too large */
	     call ioa_$ioa_stream (debug_output, "Arg no. ^d too large. Only ^d arguments.",argno,no_args);
	     return;
	end;

	do j = min_arg to max_arg; 			/* loop through the desired number of args */
	     argp = ap -&gt; arg_list.args(j);		/* get pointer to the argument */
	     if atype = "?" then do; 			/* must find out argument type */
		if no_desc ^= 0 then do; 		/* if we have descitpros, look at them */
		     call decode_descriptor_(ap,j,type,packed,ndims,strl,scale);
		end;
		else do;				/* try to find out what type by heuristics */
		     if argp -&gt; its.its_mod = "100011"b then type = 13;  /* assume pointer */
		     else do;
			do strl = 0 to 31 while(substr(char_string,strl+1,1) &gt;= "" /* bell */
						&amp;
					    substr(char_string,strl+1,1) &lt;= "~");
			end;
			if strl &gt;= 2 then type = 21;
			else type = -1;		/* full word octal */
		     end;
		end;
	     end; 				/* of checking for type */

	     else if atype = "l" then type = -2;		/* location of arg */
	     else if atype = "o" then  type = -1;	/* full word octal */
	     else if atype = "p" then type = 13;
	     else if atype = "d" then type = 1;		/* real fixed */
	     else if atype = "a" then		/* ascii */
		do;
		     call decode_descriptor_(ap,j,type,packed,ndims,strl,scale);	/* see if ascii descriptor */

		     if type = 22 then strl = max(0,addrel(argp,-1)-&gt;fword);
		     else if type = 21 then;
		     else do;
			type = 21;
			strl = 32;	/* he asked for characters, and cannot get length */
			end;
	          end;
	     else if atype = "e" then type = 3;		/* floating point */
	     else if atype = "f" then type = 1003;	/* floating point (f-format) */
	     else if atype = "b" then do;		/* bit string */
		type = 19;
		strl = 72;			/* only allow 72 bits or less */
	     end;
	     else do;				/* invalid type */
		call ioa_$ioa_stream (debug_output, "Invalid output type specified.");
		type = -1;
	     end;

	     if type = 21 then goto cs;		/* we have char string  */
	     if type = 19 then goto bs;		/* we have bit strinng */
	     if type = 14 then goto fw;		/* we have offset */

	     if type = 13 then do;			/* pointer */
		if argp -&gt; its.its_mod = "100011"b then call ioa_$ioa_stream (debug_output, "ARG ^2d: ^p",j,argp-&gt;based_p);
		else call ioa_$ioa_stream (debug_output, "ARG ^2d: ^w  ^w",j,argp-&gt;fword,addrel(argp,1)-&gt;fword);
	     end;
	     else if type = 1 then 			/* real fixed bin single */
	     call ioa_$ioa_stream (debug_output, "ARG ^2d: ^d",j,argp -&gt; fword);
	     else if type = 3 then
	     call ioa_$ioa_stream (debug_output, "ARG ^2d: ^e",j,argp -&gt; flword);
	     else if type = 1003 then
	     call ioa_$ioa_stream (debug_output, "ARG ^2d: ^16.6f",j,argp -&gt; flword);
	     else if type = 4 then
	     call ioa_$ioa_stream (debug_output, "ARG ^2d: ^e", j, argp-&gt;dblword);	/* long precision */
	     else if type = 20 then do; 		/* var and non-var bit string */
		strl = addrel(argp,-1) -&gt; fword;
bs:		c72 = "";				/* set to blanks */
		do i = 1 to min(strl,72);
		     if substr(bit_string,i,1) = "1"b then substr(c72,i,1) = "1"; else substr(c72,i,1) = "0";
		end;
		call ioa_$ioa_stream (debug_output, "ARG ^2d: ""^a""b",j,c72);
	     end;
	     else if type = 22 then 			/* var char string */
	     do;
		strl = min(32,addrel(argp,-1) -&gt; fword);
cs:		call ioa_$ioa_stream (debug_output, "ARG ^2d: ""^va""",j,strl,char_string);
	     end;
	     else if type = -1 then /* */
fw:	     call ioa_$ioa_stream (debug_output, "ARG ^2d: ^w",j,argp -&gt; fword);	/* full word octal */
	     else if type = 15 | type = 16 then
	     call ioa_$ioa_stream (debug_output, "ARG ^2d: ^p, ^p",j,argp -&gt; lv.ptr,argp -&gt; lv.stack);
	     else if type = -2 then call ioa_$ioa_stream (debug_output, "ARG ^2d -&gt; ^p",j,argp); /* location of arg */
	     else end_loop:  call ioa_$ioa_stream (debug_output, "ARG ^2d: Type ^d not handled.",j,type);

	end;
	return;

     end;
�



		    pl1_frame_.pl1                  11/20/86  1404.9r w 11/20/86  1145.0       35613



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


pl1_frame_: proc (spt, ans);

/*	sets ans =  "1"b if stack frame pointed at by pt is a pl1 frame */

/*	Modified:  2 Januaray, 1973  by S. Webber for 6180.   */

	dcl spt ptr,
	(bc, code) fixed bin,
	ans bit (1) aligned;

	dcl pl1_operators$call_out ptr ext;

	dcl p ptr int static,
	(defp, pt) ptr,
	v2 bit (1) int static,
	legal_f_ entry (ptr) returns (fixed bin),
	bit_word aligned bit (36) based (p),
	fix_word fixed bin based (p),
	(addr, addrel, baseptr, divide, fixed, null, ptr, rel, substr) builtin,
	pl1_frame_ entry (ptr) returns (aligned bit (1));

	dcl lang fixed bin;

	dcl based_ptr ptr based;

	dcl 1 half aligned based,
	2 (left, right) unaligned bit (18);

	dcl 1 acc aligned based,
	2 length unal bit (9),
	2 string unal char (1);
						/*  */
%include definition;
/*  */
%include stack_frame;
/*  */
%include its;


%include pl1_stack_frame;
/*  */
	pt = spt;

/* Clear out any flags (such as condition list present) which may have
   been set in stack frame pointer.  This is necessary because the
   pointer we are passed may actually be the back point in a stack frame */

	addr (pt) -&gt; its.pad1 = "0"b;
	addr (pt) -&gt; its.pad2 = "0"b;

	if pt = null				/* pt can't possibly point to a stack frame */
	then do;
no:	     ans = "0"b;
	     return;
	end;

	if legal_f_ (pt) ^= 0 then goto no;		/* check to see if frame is at least threaded */

	lang = fixed(pt -&gt; stack_frame.translator_id, 18);
				/* find out which translator produced
					the segment */

	if lang = 2 then v2 = "0"b;	/*PL/I, version 1 */
	else if lang = 0 then v2 = "1"b;	/* pl/I version 2 */

	else go to no;		/* not PL/I at all */

	/* get entry pointer  for use by "name" entry */

	p = pt -&gt; stack_frame.entry_ptr;

	ans = "1"b;
	return;
						/*  */
pl1_frame_$name: entry (spt, name_pt, name_size);

/*	sets name_pt &amp; name_size to determine name of pl1 program
   corresponding to stack frame pointed at by pt.  name_pt will be
   set to null if frame is not a pl1 frame */

	dcl name_pt ptr,
	name_size fixed bin;

	if ^ pl1_frame_ (spt)			/* first see if we have a good pl1 frame */
	then do;					/* if not, there's no name to return */
l2:	     name_pt = null;
	     name_size = 0;
	     return;
	end;					/* p now contains the entry pointer */

	if addrel(p, 1) -&gt; bit_word = "000000000110001100010111010001000000"b then
		/* a tsbbp ap|614 marks the entry as a begin block */
	go to l2;	/* in which case we can't get the name */

	if v2					/* for Version II */
	then do;
	     p = addrel (p, -1);			/* length of name is 1 word before entry */
	     if p -&gt; half.left then goto std_obj;	/* left half ^= 0 means std object segment */
	     goto l1;
	end;
						/* for Version I */
	/* name-size is 3 words before entry point */

	p = addrel(p, -3);

l1:	name_size = p -&gt; fix_word;			/* get length of name in characters */
	name_pt = addrel (p, -divide (name_size+3, 4, 18, 0)); /* name immediately precedes length; get length in  */
						/* words (rounding up) and subtract from pointer */
	return;

/* For a standard object segment we use the fact that the
   linkage ptr in the stack frame points to the linkage header
   in CLS and the first two words in linkage header point
   to definition section */

std_obj:	defp = spt -&gt; pl1_stack_frame.linkage_ptr -&gt; based_ptr;

	p = addrel (defp, p -&gt; half.left);
	p = addrel (defp, p -&gt; definition.symbol);

	name_size = fixed (p -&gt; acc.length, 9);
	name_pt = addr (p -&gt; acc.string);

     end;
���



		    print_text_.pl1                 02/20/86  0912.8rew 02/19/86  1047.2      167049



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




/****^  HISTORY COMMENTS:
  1) change(85-05-13,Farley), approve(85-05-13,MCR7242),
     audit(85-05-13,Fawcett), install(86-02-19,MR12.0-1019):
     Added EIS Indirect Descriptors.
                                                   END HISTORY COMMENTS */


/* Program to display output text produced by pl/1 and Fortran.  A reduced version of
   display_text.  Numbers in the disassembled instruction are decimal.  The offset and
   the instruction as it apears in core are in octal.

  The numbers are really in octal, despite comment.  Modified by JRDavis 19 Mar 80
  to not call binoct (which was transfer vector to pl1 compiler lang_util_ MCR 4422
  Modified April 1985 by Paul Farley to add EIS Indirect Descriptors.
*/

print_text_: proc (t_pt, arg_number, output_switch);

dcl  t_pt ptr,					/* points at text base */
     arg_number fixed bin,				/* max. no. of words to print */
     output_switch char (*) aligned,			/* switch name for printing disassembled line */
     arg_offset fixed bin (18),			/* real offset to be printed instead of t_pt */
     arg_string char (*) var;				/* output.  Contains formatted instruction */


dcl  number fixed bin;				/* no. of words to print */
dcl  desc_type fixed bin;				/* descriptor type: 0 = alpha, 1 = bit, 2 = numeric */
dcl  comment char (50) var;
dcl  op_name char (32) aligned;
dcl (p, pt) ptr,
    (no_to_print, j, k, m, op_index, irand, nrands, ndesc) fixed bin,
    (fract_offset, offset, scale) fixed bin (18),
    (double, eis, eis_desc, need_comma, ext_base, has_ic, decimal, ind_desc) bit (1),
     ht char (1) int static aligned init ("	"),		/* tab */
     htht char (2) int static aligned init ("		"),	/* two tabs */
     cstring char (12),
     op_code char (5),
     tag char (3),
     line char (256),
     buff char (12) varying,
     pl1_operators_$operator_table fixed bin ext;

dcl  repeat_inst bit (1);				/* ON for rpd, rpt, rpl */
dcl  print_instr bit (1);				/* 1= print instr;	  0= return formatted string */
dcl  real_offset_entry bit (1) unal;			/* ON if instruction ptr is different from text location */
dcl  real_offset fixed bin (18);			/* used with $format, $offset entries */
dcl  ioa_$ioa_stream ext entry options (variable);
dcl  ioa_$rsnnl ext entry options (variable);
dcl  find_operator_name_ entry (char (*) aligned, ptr, char (32) aligned);

dcl (addr, addrel, fixed, length, ptr, rel, string, substr) builtin;


dcl 1 op_mnemonic_$op_mnemonic (0:1023) ext static aligned,
    2 opcode char (6) unal,
    2 dtype fixed bin (2) unal,			/* 0 = alpha, 1 = bit, 2 = numeric */
    2 num_desc fixed bin (5) unal,
    2 num_words fixed bin (8) unal;


dcl  digit (0:9) char (1) aligned int static
     init ("0", "1", "2", "3", "4", "5", "6", "7", "8", "9");


dcl  base (0:7) char (4) aligned int static
     init ("pr0|", "pr1|", "pr2|", "pr3|", "pr4|", "pr5|", "pr6|", "pr7|");

dcl  modifier (0:63) char (3) aligned int static
     init (" ", "au", "qu", "du", "ic", "al", "ql", "dl",
     "0", "1", "2", "3", "4", "5", "6", "7",
     "*", "au*", "qu*", "...", "ic*", "al*", "ql*", "...",
     "0*", "1*", "2*", "3*", "4*", "5*", "6*", "7*",
     "f", "itp", "...", "its", "sd", "scr", "f2", "f3",
     "ci", "i", "sc", "ad", "di", "dic", "id", "idc",
     "*n", "*au", "*qu", "*du", "*ic", "*al", "*ql", "*dl",
     "*0", "*1", "*2", "*3", "*4", "*5", "*6", "*7");

dcl  word (0:1) bit (36) aligned based (p);

dcl 1 instruction based (p) aligned,
    2 base unaligned bit (3),
    2 offset unaligned bit (15),
    2 op_code unaligned bit (10),
    2 inhibit unaligned bit (1),
    2 ext_base unaligned bit (1),
    2 tag unaligned bit (6);

dcl 1 half based (p) aligned,
    2 left unaligned bit (18),
    2 right unaligned bit (18);

dcl 1 mod_factor aligned,
    2 ext_base bit (1) unal,
    2 length_in_reg bit (1) unal,
    2 indirect_descriptor bit (1) unal,
    2 tag bit (4) unal;

dcl  mf (3) fixed bin (6) int static init (30, 12, 3);	/* location of modification factor fields in EIS inst */

dcl (ebase, len_reg, idesc, ic) (3) bit (1) aligned;
dcl  desc_word char (8) varying;

dcl  desc_op (0:3) char (8) varying int static init ("desc9a", "descb", "desc9fl", "desc9ls");

dcl  eis_modifier (0:15) char (3) aligned int static
     init ("n", "au", "qu", "du", "ic", "al", "ql", "...",
     "x0", "x1", "x2", "x3", "x4", "x5", "x6", "x7");

dcl  bool_word (0:15) char (6) aligned int static varying
     init ("clear", "and", "andnot", "move", "", "", "xor", "or",
     "", "", "", "", "invert", "", "nand", "set");

dcl 1 descriptor based aligned,			/* EIS descriptor */
    2 address bit (18) unal,
    2 char bit (2) unal,
    2 bit bit (4) unal,
    2 length bit (12) unal;

/*  */

	number = arg_number;
	print_instr = "1"b;
	real_offset_entry = "0"b;
	p = t_pt;

begin:	substr (line, 11, 3) = "   ";
	eis = "0"b;
	irand = 0;

	do no_to_print = 1 to number;

	     comment = "";
	     tag = "   ";
	     substr (line, 7, 2) = "  ";
	     cstring = binoct (p -&gt; word (0));

	     if eis then op_index = 0;

	     else do;
		op_index = fixed (p -&gt; instruction.op_code, 10);
		op_code = opcode (op_index);
	     end;

	     if num_words (op_index) &gt; 1 then call eis_instruction;

	     else do;
		has_ic, double, repeat_inst = "0"b;

		eis_desc = eis &amp; (ind_desc | desc_word ^= "arg");
		if eis_desc then call eis_descriptor;

		else do;
		     substr (line, 13, 2) = "  ";
		     substr (line, 15, 6) = substr (cstring, 2, 5);
		     substr (line, 21, 5) = substr (cstring, 7, 4);
		     substr (line, 26, 8) = substr (cstring, 11, 2) || ht || op_code;
		     k = 34;

		     ext_base = p -&gt; instruction.ext_base;

		     if op_code = "rpd  " | op_code = "rpt  " | op_code = "rpl  " then do;
			repeat_inst = "1"b;
			call ioa_$rsnnl ("^d", tag, j, fixed (p -&gt; instruction.tag, 6));
			offset = fixed (substr (p -&gt; half.left, 1, 8), 8);
			substr (line, 14, 1) = cstring;
			call ioa_$rsnnl ("	^d", buff, j, offset);
			substr (line, k, j) = buff;
			k = k + j;
		     end;

		     else do;
			if num_desc (op_index) ^= 0 then
			     tag = substr (binoct ((p -&gt; instruction.tag)), 1, 2);

			else do;
			     if p -&gt; instruction.tag then tag = modifier (fixed (p -&gt; instruction.tag, 6));
			     double = substr (op_code, 1, 2) = "df" | substr (op_code, 3, 2) = "aq" | substr (op_code, 4, 2) = "aq";
			     has_ic = p -&gt; instruction.tag = "000100"b; /* IC */
			end;
			call address;
		     end;

		     call set_tag;
		end;

/* Print data referred to by self relative address: (tab) (tab) data offset = contents */

		if has_ic then do;
		     if real_offset_entry then pt = ptr (p, real_offset + offset - irand);
		     else pt = addrel (p, offset-irand);
		     substr (line, k, 8) = htht || binoct (rel (pt));
		     k = k + 8;

		     if substr (op_code, 1, 1) ^= "t" then do;
			comment = " = " || binoct (pt -&gt; word (0));
			if double then comment = comment || " " || binoct (pt -&gt; word (1));
		     end;
		end;

		else if ext_base &amp; (p -&gt; instruction.base = "000"b) then do; /* info for pr0 only */

		     if op_code = "xec  " then do;
			pt = addrel (addr (pl1_operators_$operator_table), offset);
			op_index = fixed (pt -&gt; instruction.op_code, 10);
			if num_words (op_index) &gt; 1 then do;

/* we are executing an EIS instruction in pl1_operators_ */

			     call init_eis;

			     do j = 1 to ndesc;
				ebase (j) = "1"b;
				len_reg (j) = ^ decimal;
				ic (j) = "0"b;
			     end;
			end;
		     end;

		     if tag ^= " " then do;
			call find_operator_name_ ("pl1_operators_", p, op_name);
			if op_name ^= " " then do;
			     substr (line, k, 34) = htht || op_name;
			     k = k + 34;
			end;

		     end;
		end;
		if ^eis_desc &amp; ^repeat_inst &amp; p -&gt; instruction.inhibit then comment = comment || " interrupt inhibit";

	     end;

	     if comment ^= "" then do;
		j = length (comment);
		substr (line, k, j) = comment;
		k = k + j;
	     end;

	     if print_instr then call ioa_$ioa_stream (output_switch, "^6o ^a", fixed (rel (p), 17), substr (line, 11, k-11));

	     else do;				/* return string for one line only */
		j = k - 11;			/* save length of strjng */
		k = 1;
		call bin_to_oct (real_offset);
		arg_string = substr (line, 1, k-1) || substr (line, 11, j);
		return;
	     end;

	     if eis
	     then do;
		irand = irand + 1;
		if irand &gt; nrands then do;
		     eis = "0"b;
		     irand = 0;
		end;
		else if irand &gt; ndesc
		then op_code, desc_word = "arg";
	     end;

	     p = addrel (p, 1);
	end;

	return;


/*  */
/*  Entry point to return a formatted string with the disassembled instruction.  The
   real offset is returned in the string.  */

print_text_$real_offset: entry (t_pt, arg_string, arg_offset);


	p = t_pt;
	real_offset = arg_offset;
	number = 1;				/* process one word only */
	print_instr = "0"b;				/* return string instead */
	real_offset_entry = "1"b;
	go to begin;

print_text_$format: entry (t_pt, arg_string);

	number = 1;
	p = t_pt;
	real_offset = fixed (rel (p), 18);
	print_instr = "0"b;
	real_offset_entry = "0"b;
	go to begin;

bin_to_oct: proc (number);

dcl (m, number) fixed bin (18);

	     call ioa_$rsnnl ("^o", buff, m, number);
	     substr (line, k, m) = buff;
	     k = k + m;

	end bin_to_oct;


init_eis:	proc;

	     eis = "1"b;
	     nrands = num_words (op_index) - 1;
	     ndesc = num_desc (op_index);
	     decimal = dtype (op_index) = 2;
	     desc_word = desc_op (dtype (op_index));
	     desc_type = dtype (op_index);
	     irand = 0;

	end init_eis;

/*  */
eis_instruction: proc;

	     call init_eis;

	     substr (line, 13, 4) = substr (cstring, 1, 3);
	     substr (line, 17, 4) = substr (cstring, 4, 3);
	     substr (line, 21, 4) = substr (cstring, 7, 3);
	     substr (line, 25, 3) = substr (cstring, 10, 3);

	     substr (line, 28, 1) = ht;
	     substr (line, 29, 5) = op_code;
	     substr (line, 34, 1) = ht;

	     k = 35;

	     do j = 1 to ndesc;
		string (mod_factor) = substr (p -&gt; word (0), mf (j), 7);
		ebase (j) = mod_factor.ext_base;
		len_reg (j) = mod_factor.length_in_reg;
		idesc (j) = mod_factor.indirect_descriptor;

		substr (line, k, 1) = "(";
		k = k + 1;
		need_comma = "0"b;

		if ebase (j) then do;
		     substr (line, k, 2) = "pr";
		     k = k + 2;
		     need_comma = "1"b;
		end;

		if len_reg (j) then do;
		     if need_comma then do;
			substr (line, k, 1) = ",";
			k = k + 1;
		     end;
		     substr (line, k, 2) = "rl";
		     k = k + 2;
		     need_comma = "1"b;
		end;

		if idesc (j) then do;
		     if need_comma then do;
			substr (line, k, 1) = ",";
			k = k + 1;
		     end;
		     substr (line, k, 2) = "id";
		     k = k + 2;
		     need_comma = "1"b;
		end;

		if mod_factor.tag then do;
		     if need_comma then do;
			substr (line, k, 1) = ",";
			k = k + 1;
		     end;
		     ic (j) = mod_factor.tag = "0100"b; /* IC */
		     substr (line, k, 2) = eis_modifier (fixed (mod_factor.tag, 4));
		     k = k + 2;
		end;
		else ic (j) = "0"b;

		substr (line, k, 2) = "),";
		k = k + 2;
	     end;


	     if substr (p -&gt; word (0), 10, 1) then do;
		substr (line, k, 12) = "enablefault,";
		k = k + 12;
	     end;

	     if desc_word = "desc9a"
	     then if ndesc &lt; 3 then do;
		     if substr (op_code, 1, 2) ^= "sc"
		     then substr (line, k, 5) = "fill(";
		     else substr (line, k, 5) = "mask(";
		     k = k + 5;
		     substr (line, k, 3) = substr (cstring, 1, 3);
		     k = k + 3;
		     substr (line, k, 1) = ")";
		     k = k + 1;
		end;
		else k = k - 1;
	     else if desc_word = "descb" then do;
		substr (line, k, 7) = "fill(" || digit (fixed (substr (p -&gt; word (0), 1, 1), 1)) || ")"; /* fill(N) */
		k = k + 7;

		if op_code ^= "cmpb " then do;
		     substr (line, k, 6) = ",bool(";
		     k = k + 6;
		     j = fixed (substr (p -&gt; word (0), 6, 4), 4);
		     m = length (bool_word (j));
		     if m &gt; 0 then do;
			substr (line, k, m) = bool_word (j);
			k = k + m;
		     end;
		     else do;
			substr (line, k, 1) = digit (fixed (substr (p -&gt; word (0), 6, 1), 1));
			substr (line, k+1, 1) = digit (fixed (substr (p -&gt; word (0), 7, 3), 3));
			k = k + 2;
		     end;
		     substr (line, k, 1) = ")";
		     k = k + 1;
		end;
	     end;
	     else if substr (p -&gt; word (0), 11, 1) then do;
		substr (line, k, 5) = "round";
		k = k + 5;
	     end;
	     else k = k - 1;

	     return;

	end eis_instruction;

/*  */

eis_descriptor: proc;

dcl  len fixed bin (18);
dcl  type fixed bin;				/* descriptor type */

dcl 1 n_desc aligned based (p),
    2 y bit (18) unal,				/* address field */
    2 CN bit (3) unal,				/* character position */
    2 TN bit (1) unal,				/* type 0 = 9bit; 1 = 4 bit */
    2 S bit (2) unal,				/* sign type 0 = fl, 1 = ls, 2 = ts, 3 = ns */
    2 SF bit (6) unal,				/* scale factor */
    2 N bit (6) unal;				/* length */

dcl 1 b_desc aligned based (p),			/* bit descriptor */
    2 y bit (18) unal,				/* address field */
    2 c bit (2) unal,				/* 9 bit offset */
    2 b bit (4) unal,				/* bit offset */
    2 N bit (12) unal;				/* length */

dcl 1 a_desc aligned based (p),			/* alpha-numeric descriptor */
    2 y bit (18) unal,				/* address field */
    2 CN bit (3) unal,				/* character offset */
    2 TA bit (2) unal,
    2 pad bit (1) unal,				/* always zero */
    2 N bit (12) unal;				/* length */

dcl  table_n_S (0:3) char (2) int static init ("fl", "ls", "ts", "ns");
dcl  table_a_TA (0:3) char (1) int static init ("9", "6", "4", "?");

	     ind_desc = idesc (irand);
	     if ind_desc then do;
		call ind_descriptor;
		return;
	     end;

	     substr (line, 13, 2) = "  ";
	     substr (line, 15, 6) = substr (cstring, 2, 5);
	     substr (line, 21, 3) = substr (cstring, 7, 2);
	     substr (line, 24, 4) = substr (cstring, 9, 4);
	     substr (line, 28, 1) = ht;

	     ext_base = ebase (irand);
	     has_ic = ic (irand);

	     type = desc_type;
	     if op_code = "btd" &amp; irand = 1 then type = 0;
	     else if op_code = "dtb"  | op_code = "mvne" then if irand &gt; 1 then type = 0;

	     if type = 0 then do;			/*  alpha-nummeric descriptor */
		desc_word = "desc" || table_a_TA (fixed (a_desc.TA, 2)) || "a";
		if a_desc.TA = "00"b then fract_offset = fixed (substr (a_desc.CN, 1, 2), 2);
		else fract_offset = fixed (a_desc.CN, 3);
		len = fixed (a_desc.N, 12);
	     end;

	     else if type = 1 then do;		/* bit descriptor */
		desc_word = "descb";
		len = fixed (b_desc.N, 12);
		fract_offset = fixed (b_desc.c, 2) * 9 + fixed (b_desc.b, 4);
	     end;

	     else do;				/* numeric descriptor */
		if n_desc.TN then do;
		     desc_word = "desc4";
		     fract_offset = fixed (n_desc.CN,3);
		end;
		else do;
		     desc_word = "desc9";
		     fract_offset = fixed (substr (n_desc.CN, 1, 2), 2);
		end;
		desc_word = desc_word || table_n_S (fixed (n_desc.S, 2));
		len = fixed (n_desc.N, 6);

		if n_desc.S then do;		/*  for S = 00 there is no scale factor */
		     scale = fixed (n_desc.SF, 6);
		     if scale &gt; 32 then scale = scale - 64;
		end;
	     end;

/*  desc_word   address(fract_offset),tag,length,scale   */

	     k = length (desc_word);
	     substr (line, 29, k) = desc_word;
	     k = k + 29;
	     call address;

	     if fract_offset ^= 0 then do;
		call ioa_$rsnnl ("(^d)", buff, j, fract_offset);
		substr (line, k, j) = buff;
		k = k + j;
	     end;

	     if len_reg (irand) then do;		/* print register which contains length */
		tag = eis_modifier (fixed (substr (p -&gt; descriptor.length, 9, 4), 4));
		call set_tag;
	     end;

	     else do;				/* print length as given */
		substr (line, k, 1) = ",";
		k = k + 1;
		call bin_to_oct (len);
	     end;

	     if type = 2 then if n_desc.S then do;	/* scale factor for numeric only */
		     substr (line, k, 1) = ",";
		     k = k+1;
		     call bin_to_oct (scale);
		end;

	     return;

	end eis_descriptor;

/*  */

ind_descriptor: proc;

dcl 1 i_desc aligned based (p),			/* indirect descriptor */
    2 y bit (18) unal,				/* address field */
    2 pad bit (11) unal,				/* always zero */
    2 extbase bit (1) unal,				/* PR mod */
    2 pad1 bit (2) unal,				/* always zero */
    2 tag bit (4) unal;				/* reg mod */


	     substr (line, 13, 2) = "  ";
	     substr (line, 15, 6) = substr (cstring, 2, 5);
	     substr (line, 21, 5) = substr (cstring, 7, 4);
	     substr (line, 26, 2) = substr (cstring, 11, 2);
	     substr (line, 28, 1) = ht;

	     ext_base = i_desc.extbase;
	     has_ic = (i_desc.tag = "0100"b);
	     desc_word = "arg";

	     k = length (desc_word);
	     substr (line, 29, k) = desc_word;
	     k = k + 29;
	     call address;

	     if i_desc.tag then do;
		substr (line, k, 3) = "," || eis_modifier (fixed (i_desc.tag, 4));
		k = k + 3;
	     end;
	     return;
	end ind_descriptor;

/*  */

/* This procedure disassembles the address portion.  It adds: tab [prN|] offset
   It also sets the first octal digit so a blank will separate the register from the rest of the address field.

   cstring	     The octal representation of the word.

   ext_base	     ON if the address uses a register.
*/

address:	proc;

	     substr (line, k, 1) = ht;
	     k = k + 1;

	     if ext_base then do;
		substr (line, k, 4) = base (fixed (p -&gt; instruction.base, 3));
		offset = fixed (p -&gt; instruction.offset, 15);
		if offset &gt; 16384 then offset = offset - 32768;
		k = k+4;
		substr (line, 13, 1) = cstring;
	     end;

	     else do;
		offset = fixed (p -&gt; half.left, 18);
		if offset &gt; 131072 then if tag ^= "du " &amp; tag ^= "dl " then offset = offset - 262144; /* 2's comp */
		substr (line, 14, 1) = cstring;
	     end;


	     call bin_to_oct (offset);

	end address;


/*  This procedure sets the tag in the instruction line. */

set_tag:	proc;

	     if tag ^= " " then do;
		substr (line, k, 4) = "," || tag;
		k = k + 2;
		if substr (line, k, 1) ^= " " then k = k + 1;
		if substr (line, k, 1) ^= " " then k = k + 1;
	     end;

	     return;
	end set_tag;

binoct: proc (bits) returns (char (12) aligned);
        dcl bits bit (*) aligned parameter;
        dcl c12 char (12) aligned;

        call ioa_$rsnnl ("^12.3b", c12, (0), bits);
        return (c12);
end binoct;
     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
</pre></body></html>