



		    db_fnp_break_.pl1               11/15/82  1816.2rew 11/15/82  1501.3      187326



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


/* DB_FNP_BREAK_ - Implements the breakpoint options of debug_fnp */
/* Written September 1977 by Larry Johnson */

db_fnp_break_: proc;

/* Parameters */

dcl  arg_corep ptr;
dcl  arg_fnp fixed bin;
dcl  arg_cmd_infop ptr;
dcl  arg_expr_infop ptr;

/* Automatic */

dcl  corep ptr;
dcl  fnp fixed bin;
dcl  code fixed bin (35);
dcl  i fixed bin;
dcl  something_printed bit (1);
dcl  edited_addr char (32) var;
dcl  mem_buf (32) bit (18) unal;
dcl  ntibs fixed bin;
dcl  state fixed bin;
dcl  break_reset bit (1);
dcl  crbrk_val fixed bin;
dcl  break_address fixed bin;
dcl  line_given bit (1);
dcl  tty_name char (8);
dcl  stop_trace bit (1);
dcl  start_trace bit (1);
dcl  address_given bit (1);
dcl  reset_sw bit (1);
dcl 1 temp_expr_info like expr_info aligned automatic;

dcl 1 fnp_break_info aligned,				/* Info structure for setting breaks */
    2 channel char (6),
    2 address fixed bin,
    2 action fixed bin,
    2 flags,
      3 trace bit (1) unal,
      3 pad bit (35) unal;

dcl  SET fixed bin int static options (constant) init (1);	/* Values for fnp_break_info.action */
dcl  RESET fixed bin int static options (constant) init (2);
dcl  START fixed bin int static options (constant) init (3);

dcl  break_error (7) char (32) var int static options (constant) init ( /* Error codes read from fnp */
     "Bad address.",
     "Bad line number.",
     "No entry in break table.",
     "Not stopped at breakpoint.",
     "No room in break table.",
     "No opblock at address.",
     "Invalid request.");

/* Alocated copy of break table */

dcl  brk_tab_start fixed bin;
dcl  brk_tab_size fixed bin;
dcl  brk_tabp ptr init (null);

dcl 1 brk_tab aligned based (brk_tabp),
    2 entry (brk_tab_size) unal,
      3 address fixed bin (17) unal,
      3 line fixed bin (17) unal,
      3 opblock bit (18) unal,
      3 flags bit (18) unal;

dcl  tib_tablep ptr init (null);			/* Pointer to temp copy of tib table */
dcl 1 tib_table aligned based (tib_tablep),
    2 entries (ntibs) unal,
      3 address fixed bin (17) unal,			/* Address ot tib */
      3 q fixed bin (17) unal;			/* Address of q */

dcl  brk_listp ptr init (null);			/* Pointer to list of tibs at breaks */
dcl  brk_list_cnt fixed bin;				/* Number of such tibs */
dcl 1 brk_list aligned based (brk_listp),
    2 entries (ntibs) unal,
      3 line fixed bin (17) unal,
      3 t_cur fixed bin (17) unal;

/* Internal static */

dcl  symbols_looked_up bit (1) int static init ("0"b);	/* Set once all following symbols are set */
dcl  crbrk fixed bin int static;
dcl  crttb fixed bin int static;
dcl  crtte fixed bin int static;
dcl  t_flg3 fixed bin int static;
dcl  t_cur fixed bin int static;
dcl  t_line fixed bin int static;
dcl  bkptop bit (18) int static;
dcl  tfbkpt bit (18) int static;
dcl  free_areap ptr int static;
dcl  call_type fixed bin int static init (0);		/* Says which type of ring0 call to use */

dcl  free_area area based (free_areap);
dcl  name char (13) int static options (constant) init ("db_fnp_break_");

/* External */

dcl  db_fnp_sym_util_$get_value entry (char (*)) returns (fixed bin);
dcl  db_fnp_util_$edit_module_addr_force entry (ptr, fixed bin, fixed bin, char (*) var, fixed bin (35));
dcl  db_fnp_util_$edit_module_addr_paren entry (ptr, fixed bin, fixed bin, char (*) var, fixed bin (35));
dcl  db_fnp_util_$cv_chan_name entry (ptr, fixed bin, char (*), char (*), fixed bin, fixed bin (35));
dcl  db_fnp_util_$cv_line_no entry (ptr, fixed bin, fixed bin, char (*), fixed bin (35));
dcl  db_fnp_util_$get_chan_addrs entry (ptr, fixed bin, char (*), ptr, fixed bin (35));
dcl  db_fnp_opblock_util_$get_name entry (bit (18), char (*));
dcl  db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35));
dcl  db_fnp_reader_$get_operand entry (ptr);
dcl  db_fnp_eval_ entry (ptr, fixed bin, char (*), ptr, char (*), fixed bin, fixed bin (35));
dcl  db_fnp_opblock_util_$lookup entry (char (*), bit (18), fixed bin (35));
dcl  hphcs_$tty_order entry (fixed bin, char (*), ptr, fixed bin, fixed bin (35));
dcl  hphcs_$tty_control entry (char (*), char (*), ptr, fixed bin (35));
dcl  sub_err_ entry options (variable);
dcl  com_err_ entry options (variable);
dcl  get_system_free_area_ entry returns (ptr);
dcl  ioa_ entry options (variable);
dcl  ioa_$nnl entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  timer_manager_$sleep entry (fixed bin (71), bit (2));
dcl  get_fnp_name_ entry (fixed bin) returns (char (32));

dcl  iox_$user_output ext ptr;

dcl (cleanup, linkage_error) condition;

dcl (addr, bin, divide, length, max, null, string) builtin;

/* Entry to set a breakpoint */

set:	entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;
	on cleanup call clean_up;

	if corep ^= null then do;
	     call ioa_ ("Only valid on a running FNP.");
	     go to error_return;
	end;

	call get_operand;				/* Address */
	if cmd_info.endline then do;
	     call ioa_ ("No address");
	     go to error_return;
	end;

	call db_fnp_eval_ (corep, fnp, operand, expr_infop, "", break_address, code);
	if code ^= 0 then go to error_return;

	line_given = "0"b;
	stop_trace = "0"b;
	call get_operand;				/* Scan command line */
	do while (^cmd_info.endline);
	     if operand = "-stop_trace" then stop_trace = "1"b;
	     else if ^line_given then do;
		call db_fnp_util_$cv_chan_name (corep, fnp, operand, tty_name, i, code); /* See if good line number */
		if code ^= 0 then do;
		     call com_err_ (code, name, "^a", operand);
		     go to error_return;
		end;
		line_given = "1"b;
	     end;
	     else do;				/* Bad arg */
		call ioa_ ("Invalid operand: ^a", operand);
		go to error_return;
	     end;
	     call get_operand;
	end;

	fnp_break_info.address = break_address;
	fnp_break_info.action = SET;
	if line_given then fnp_break_info.channel = tty_name;
	else fnp_break_info.channel = "";
	string (fnp_break_info.flags) = "0"b;
	fnp_break_info.trace = stop_trace;

	call make_order_call;
	call check_break_error;
	if code ^= 0 then do;
	     call ioa_ ("Break not set: ^a", break_error (code));
	     go to error_return;
	end;

	call clean_up;
	return;

/* Entry to reset breaks */

reset:	entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;
	on cleanup call clean_up;

	if corep ^= null then do;
	     call ioa_ ("Only valid on a running FNP.");
	     go to error_return;
	end;

	call get_operand;				/* Read address */
	if cmd_info.endline then do;
	     call ioa_ ("No address specified");
	     go to error_return;
	end;

	if operand = "-all" | operand = "-a" then do;	/* Reset all breaks */
	     call get_break_table;			/* First need lines at breaks */
	     break_reset = "0"b;
	     do i = 1 to brk_tab_size;		/* Loop thru all breaks */
		if brk_tab.address (i) ^= 0 then do;	/* Found non-empty entry */
		     break_reset = "1"b;
		     call reset_one_break ((brk_tab.address (i)));
		end;
	     end;
	     if ^break_reset then call ioa_ ("No breaks found.");
	end;

	else do;					/* Reset one break */
	     call db_fnp_eval_ (corep, fnp, operand, expr_infop, "", i, code);
	     if code = 0 then call reset_one_break (i);
	end;

	call clean_up;
	return;

/* Entry to restart a stopped channel */

start:	entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;
	on cleanup call clean_up;

	if corep ^= null then do;
	     call ioa_ ("Only valid on a running FNP.");
	     go to error_return;
	end;

	call get_operand;
	if cmd_info.endline then do;
	     call ioa_ ("No line given.");
	     go to error_return;
	end;

	if operand = "-all" | operand = "-a" then do;	/* Start all lines */
	     call find_stopped_channels;
	     if brk_list_cnt = 0 then do;		/* None */
		call ioa_ ("No lines stopped at breaks.");
		go to start_break_end;
	     end;
	     do i = 1 to brk_list_cnt;		/* Start each line */
		call db_fnp_util_$cv_line_no (corep, fnp, (brk_list.line (i)), tty_name, code);
		if code ^= 0 then do;
		     call com_err_ (code, name, "Unable to convert ^o to tty name.", brk_list.line (i));
		     cmd_info.flush = "1"b;		/* Treat as error, but continue */
		     go to start_next;
		end;
		fnp_break_info.channel = tty_name;
		fnp_break_info.address = 0;
		fnp_break_info.action = START;
		string (fnp_break_info.flags) = "0"b;
		call make_order_call;
		call check_break_error;
		if code ^= 0 then do;
		     call ioa_ ("^a not restarted. ^a", tty_name, break_error (code));
		     cmd_info.flush = "1"b;		/* Treat as error */
		end;
		else call ioa_ ("^a restarted.", tty_name);
start_next:
	     end;
	end;

	else do;					/* Start one line */
	     call db_fnp_util_$cv_chan_name (corep, fnp, operand, tty_name, i, code);
	     if code ^= 0 then do;
		call com_err_ (code, name, "^a", operand);
		go to error_return;
	     end;
	     address_given = "0"b;
	     reset_sw = "0"b;
	     start_trace = "0"b;
	     call get_operand;
	     do while (^cmd_info.endline);		/* Scan command */
		if operand = "-reset" then reset_sw = "1"b;
		else if operand = "-start_trace" then start_trace = "1"b;
		else if ^address_given then do;
		     call db_fnp_eval_ (corep, fnp, operand, expr_infop, "", break_address, code);
		     if code ^= 0 then go to error_return;
		     address_given = "1"b;
		end;
		else do;
		     call ioa_ ("Invalid operand: ^a", operand);
		     go to error_return;
		end;
		call get_operand;
	     end;

	     if reset_sw then do;
		temp_expr_info = expr_info;		/* Setup dummy structure */
		temp_expr_info.tib_known = "0"b;
		call db_fnp_util_$get_chan_addrs (corep, fnp, tty_name, addr (temp_expr_info), code);
		if code ^= 0 then do;
no_reset_tib:	     call com_err_ (code, name, "Cant get tib address for ^a", tty_name);
		     go to error_return;
		end;
		if ^temp_expr_info.tib_known then go to no_reset_tib;
		call fetch_words (temp_expr_info.tib_addr + t_cur, 1, addr (mem_buf));
		call reset_one_break (bin (mem_buf (1)));
	     end;

	     fnp_break_info.channel = tty_name;
	     fnp_break_info.action = START;
	     if address_given then fnp_break_info.address = break_address;
	     else fnp_break_info.address = 0;
	     string (fnp_break_info.flags) = "0"b;
	     fnp_break_info.trace = start_trace;
	     call make_order_call;
	     call check_break_error;
	     if code ^= 0 then do;
		call ioa_ ("^a not restarted. ^a", tty_name, break_error (code));
		go to error_return;
	     end;
	     else call ioa_ ("^a restarted", tty_name);
	end;
start_break_end:
	call clean_up;
	return;

/* Entry to list breakpoints */

list:	entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;
	on cleanup call clean_up;

	call get_break_table;			/* Find break table in fnp */
	call find_stopped_channels;
	something_printed = "0"b;
	do i = 1 to brk_tab_size;
	     if brk_tab.address (i) ^= 0 then
		call print_one_break ((brk_tab.address (i)), brk_tab.opblock (i), (brk_tab.line (i)));
	end;
	do i = 1 to brk_list_cnt;			/* Also print lines stopped at non-std breaks */
	     if brk_list.line (i) ^= -1 then
		call print_one_break ((brk_list.t_cur (i)), "0"b, -1);
	end;
	if ^something_printed then call ioa_ ("No breaks set");
	call clean_up;
	return;

/* Procedure to print one break point. */

print_one_break: proc (a, o, l);

dcl  a fixed bin;					/* Address */
dcl  o bit (18);					/* Origional opblcok */
dcl  l fixed bin;					/* Line number */

dcl  i fixed bin;
dcl  optemp char (6);
dcl 1 b unal,					/* The bbasic print line */
    2 address char (10),
    2 opblock char (8),
    2 line char (6);

	     if ^something_printed then call ioa_ ("ADDRESS   OPBLOCK LINE   LINES STOPPED");
	     something_printed = "1"b;

	     call db_fnp_util_$edit_module_addr_force (corep, fnp, a, edited_addr, code);
	     if code ^= 0 then call ioa_$rsnnl ("^o", b.address, (0), a);
	     else b.address = edited_addr;

	     if o = "0"b then b.opblock = "";
	     else do;
		call db_fnp_opblock_util_$get_name (o, optemp);
		if optemp = "" then call ioa_$rsnnl ("^.3b", b.opblock, (0), o);
		else b.opblock = optemp;
	     end;

	     if l = -1 then b.line = "";
	     else do;
		call db_fnp_util_$cv_line_no (corep, fnp, l, tty_name, code);
		if code = 0 then b.line = tty_name;
		else call ioa_$rsnnl ("^o", b.line, (0), l);
	     end;
	     call iox_$put_chars (iox_$user_output, addr (b), length (string (b)), code);

	     do i = 1 to brk_list_cnt;		/* Print lines stopped at this break */
		if (brk_list.t_cur (i) = a) & (brk_list.line (i) ^= -1) then do;
		     call db_fnp_util_$cv_line_no (corep, fnp, (brk_list.line (i)), tty_name, code);
		     if code ^= 0 then call ioa_$nnl (" ^o", brk_list.line (i));
		     else call ioa_$nnl (" ^a", tty_name);
		     brk_list.line (i) = -1;		/* Dont print again */
		end;
	     end;
	     call ioa_ ("");			/* Finish the line */
	     return;

	end print_one_break;

/* Initialization procedure */

setup:	proc;

dcl  fb fixed bin (17) unal;

	     corep = arg_corep;
	     fnp = arg_fnp;
	     expr_infop = arg_expr_infop;
	     cmd_infop = arg_cmd_infop;

	     if ^symbols_looked_up then do;		/* Once per process */
		crbrk = db_fnp_sym_util_$get_value (".crbrk");
		crttb = db_fnp_sym_util_$get_value (".crttb");
		crtte = db_fnp_sym_util_$get_value (".crtte");
		t_flg3 = db_fnp_sym_util_$get_value ("t.flg3");
		t_cur = db_fnp_sym_util_$get_value ("t.cur");
		t_line = db_fnp_sym_util_$get_value ("t.line");
		fb = db_fnp_sym_util_$get_value ("tfbkpt");
		tfbkpt = unspec (fb);
		call db_fnp_opblock_util_$lookup ("bkptop", bkptop, code);
		if code ^= 0 then
		     call sub_err_ (code, name, "s", null, (0), "Unable to get code for ""bkptop"" opblock.");
		free_areap = get_system_free_area_ ();
		symbols_looked_up = "1"b;
	     end;

	     call get_crbrk_val;

	     return;

	end setup;

/* Procedure to fetch the break table */

get_break_table: proc;


	     if brk_tabp = null then do;		/* Havent inited yet */
		call fetch_words (crbrk_val, 2, addr (mem_buf)); /* Get address and length */
		brk_tab_start = bin (mem_buf (1));
		brk_tab_size = bin (mem_buf (2));
		allocate brk_tab in (free_area);
	     end;
	     call fetch_words (brk_tab_start, 4 * brk_tab_size, brk_tabp);
	     return;

	end get_break_table;

/* Get list of all channels stopped at break points */

find_stopped_channels: proc;

dcl  i fixed bin;
dcl  nw fixed bin;

	     call fetch_words (crttb, 1, addr (mem_buf)); /* Get start of tib table */
	     i = bin (mem_buf (1));
	     call fetch_words (crtte, 1, addr (mem_buf)); /* And end */
	     ntibs = divide (bin (mem_buf (1), 17) - i, 2, 17, 0);
	     allocate tib_table in (free_area);
	     allocate brk_list in (free_area);
	     call fetch_words (i, 2*ntibs, tib_tablep);	/* Read the tib table */
	     nw = max (t_flg3, t_cur, t_line) + 1;	/* Number of words to read to get all these fields */
	     brk_list_cnt = 0;			/* Number of lines at breaks */
	     do i = 1 to ntibs;			/* For each tib */
		call fetch_words ((tib_table.address (i)), nw, addr (mem_buf)); /* Read stat of tib */
		if mem_buf (t_flg3 + 1) & tfbkpt then do; /* If line at break */
		     brk_list_cnt = brk_list_cnt + 1;
		     brk_list.line (brk_list_cnt) = bin (mem_buf (t_line+1));
		     brk_list.t_cur (brk_list_cnt) = bin (mem_buf (t_cur+1));
		end;
	     end;
	     free tib_table;
	     return;

	end find_stopped_channels;

/* Reset a single breakpoint */

reset_one_break: proc (a);

dcl  a fixed bin;					/* The address of the break */
dcl  edited_addr char (16) var;

	     call db_fnp_util_$edit_module_addr_paren (corep, fnp, a, edited_addr, code); /* Edit address for messages */
	     if code ^= 0 then edited_addr = "?";
	     call fetch_words (a, 1, addr (mem_buf));	/* Get opblock at location now */
	     if mem_buf (1) ^= bkptop then do;
		call ioa_ ("No break at ^a", edited_addr);
		cmd_info.flush = "1"b;		/* Treat as error, but continue */
		return;
	     end;

	     fnp_break_info.action = RESET;
	     fnp_break_info.address = a;
	     fnp_break_info.channel = "";
	     string (fnp_break_info.flags) = "0"b;
	     call make_order_call;

	     call check_break_error;			/* Check for any error */
	     if code = 0 then call ioa_ ("Break at ^a reset.", edited_addr);
	     else do;
		call ioa_ ("Break at ^a not reset. ^a", edited_addr, break_error (code));
		cmd_info.flush = "1"b;
	     end;
	     return;

	end reset_one_break;

/* Precedure to read memory */

fetch_words: proc (a, n, p);

dcl  a fixed bin;					/* Address */
dcl  n fixed bin;					/* Word count */
dcl  p ptr;					/* Where to put them */

	     call db_fnp_memory_$fetch (corep, fnp, a, n, p, code);
	     if code ^= 0 then do;
		call com_err_ (code, name, "Unable to read location ^o.", a);
		go to error_return;
	     end;
	     return;

	end fetch_words;

get_operand: proc;

	     call db_fnp_reader_$get_operand (cmd_infop);
	     if cmd_info.error then go to error_return;
	     return;

	end get_operand;

/* The hphcs interface_ */

make_order_call: proc;

dcl  fnp_name char (1);

	     fnp_name = get_fnp_name_ (fnp);

retry_order_call:
	     if call_type = 0 then do;		/* Haven't established which call to use */
		on linkage_error go to call_1_failed;
		call hphcs_$tty_order (fnp, "fnp_break", addr (fnp_break_info), state, code); /* Try old call */
		revert linkage_error;		/* It worked */
		call_type = 1;
		go to check_order_code;
call_1_failed:	on linkage_error go to call_2_failed;
		call hphcs_$tty_control (fnp_name, "fnp_break", addr (fnp_break_info), code); /* Try new call */
		revert linkage_error;		/* It worked */
		call_type = 2;
		go to check_order_code;
call_2_failed:	revert linkage_error;		/* Neither worked, must mean no access */
		call sub_err_ (0, name, "h", null, (0), "No access to hphcs_ gate; unable to make fnp_break order call.");
		go to retry_order_call;
	     end;
	     else if call_type = 1 then call hphcs_$tty_order (fnp, "fnp_break", addr (fnp_break_info), state, code);
	     else call hphcs_$tty_control (fnp_name, "fnp_break", addr (fnp_break_info), code);
check_order_code:
	     if code ^= 0 then do;
		call com_err_ (code, name);
		go to error_return;
	     end;
	     return;

	end make_order_call;

/* Get value of .crbrk, which points to data in breakpoint_man */

get_crbrk_val: proc;

	     call fetch_words (crbrk, 1, addr (mem_buf)); /* Get addr of brk tab ptr */
	     crbrk_val = bin (mem_buf (1));
	     if crbrk_val = 0 then do;
		call ioa_ ("No break table");
		go to error_return;
	     end;
	     return;

	end get_crbrk_val;

/* Get break error code, reason for failure of previous request */

check_break_error: proc;

/* The following sleep call is a temporary kludge to avoid a potential
   problem which cannot be solved in MR6.0 because of lack of time.
   If the FNP should crash while a 'dump_fnp' order call is in progress, the
   Initializer will end up looping in ring 0 trying to lock the
   fnp_dump_segment in order to take a dump. The segment is, however,
   already locked to the process tperforming the 'fnp_dump' order
   and the Initializer will loop forever. Breakpoint operations are
   especially prone to this trap because each operation is immediatly
   followed by a 'dump_fnp' order to check the status of the operation.
   Therefore a start or set_break command which causes the FNP to crash will
   very likely cause this problem.  The sleep call is an attempt
   to reduce the likely-hood of this happening by waiting after a breakpoint
   operation before checking the results. The theory is that if the
   FNP is going to crash as a result of the breakpoint operation, it will do
   so quickly, and the Initializer will be able to start the dump operation
   before we attemp the dump_fnp order. This is obviously a stopgap measure to
   be deleted as soon as posssible. */

	     call timer_manager_$sleep (250000, "10"b);

	     call fetch_words (crbrk_val + 2, 1, addr (mem_buf));
	     code = bin (mem_buf (1));
	     return;

	end check_break_error;

error_return:
	cmd_info.flush = "1"b;
	call clean_up;
	return;

/* Cleanup handler */

clean_up:	proc;

	     if brk_tabp ^= null then free brk_tab;
	     if tib_tablep ^= null then free tib_table;
	     if brk_listp ^= null then free brk_list;
	     return;

	end clean_up;

%include debug_fnp_data;

     end db_fnp_break_;




		    db_fnp_buffer_status_.pl1       11/15/82  1816.2rew 11/15/82  1501.4       58311



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
db_fnp_buffer_status_: proc (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

/* Coded 7/25/78 by J. Stern */


/* Arguments */

dcl  arg_corep ptr;
dcl  arg_fnp fixed bin;
dcl  arg_cmd_infop ptr;
dcl  arg_expr_infop ptr;


/* Automatic */

dcl  corep ptr;
dcl  fnp fixed bin;
dcl (total_icpl, total_dcpl, total_ocnt) fixed bin;
dcl (max_icpl, max_dcpl, max_ocnt) fixed bin;
dcl (max_icpl_line, max_dcpl_line, max_ocnt_line) fixed bin;
dcl (icpl, dcpl, ocnt, total) fixed bin;
dcl  code fixed bin (35);
dcl (ttb_addr, tte_addr, tib_addr) fixed bin;
dcl  line fixed bin;
dcl (n_free, n_small) fixed bin;
dcl  ttbx fixed bin;
dcl  brief_sw bit (1) aligned;
dcl  ttb_temp (0:599) fixed bin (17) unal;
dcl  temp (0:99) fixed bin (17) unal;

/* Internal static */

dcl  have_symbols bit (1) aligned int static init ("0"b);
dcl (crnbf, crnbs, crttb, crtte) fixed bin int static;
dcl (t_icpl, t_dcpl, t_ocnt, t_sfcm, t_line) fixed bin int static;
dcl (sf_ib0, sf_ib1) fixed bin int static;
dcl (tib_words_needed, sfcm_words_needed) fixed bin int static;


/* Constants */

dcl  whoami char (15) int static options (constant) init ("db_fnp_analyze_");


/* Builtins */

dcl (addr, null, divide, max, rtrim, substr) builtin;


/* Entries */

dcl  com_err_ entry options (variable);
dcl  ioa_ entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  db_fnp_sym_util_$get_value entry (char (*)) returns (fixed bin);
dcl  db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35));
dcl  db_fnp_reader_$get_operand entry (ptr);
dcl  db_fnp_util_$cv_line_no entry (ptr, fixed bin, fixed bin, char (*), fixed bin (35));

%include debug_fnp_data;

	call setup;

	brief_sw = "0"b;
	call get_operand;
	if ^cmd_info.endline
	then do;
	     if operand = "-bf" | operand = "-brief"
	     then brief_sw = "1"b;
	     else do;
		call com_err_ (0, "", "Invalid operand:  ^a", operand);
		go to error_exit;
	     end;
	end;

	total_icpl, total_dcpl, total_ocnt = 0;
	max_icpl, max_icpl_line, max_dcpl, max_dcpl_line, max_ocnt, max_ocnt_line = 0;

	call fetch_words (crttb, 1, addr (temp));
	ttb_addr = temp (0);
	if ttb_addr = 0
	then do;
	     call com_err_ (0, whoami, "No tib table address.");
	     go to error_exit;
	end;

	call fetch_words (crtte, 1, addr (temp));
	tte_addr = temp (0);
	if tte_addr < ttb_addr
	then do;
	     call com_err_ (0, whoami, "Invalid tib table end address.  ^o", tte_addr);
	     go to error_exit;
	end;

	call fetch_words (crnbf, 1, addr (temp));
	n_free = temp (0);
	call fetch_words (crnbs, 1, addr (temp));
	n_small = temp (0);

	call ioa_ ("^d free", n_free);
	call ioa_ ("^d small space", n_small);

	call fetch_words (ttb_addr, tte_addr-ttb_addr, addr (ttb_temp));

	call ioa_ ("^/LINE^-INPUT^-DIA^-OUTPUT^-TOTAL^/");

	do ttbx = 0 to tte_addr-ttb_addr-1 by 2;
	     tib_addr = ttb_temp (ttbx);
	     call fetch_words (tib_addr, tib_words_needed, addr (temp));
	     line = temp (t_line);

	     icpl = max (0, temp (t_icpl));
	     dcpl = max (0, temp (t_dcpl));
	     ocnt = max (0, temp (t_ocnt));

	     if line > 512
	     then do;
		call fetch_words ((temp (t_sfcm)), sfcm_words_needed, addr (temp));
		if temp (sf_ib0) ^= 0 then icpl = icpl + 1;
		if temp (sf_ib1) ^= 0 then icpl = icpl + 1;
	     end;

	     total_icpl = total_icpl + icpl;
	     total_dcpl = total_dcpl + dcpl;
	     total_ocnt = total_ocnt + ocnt;

	     if brief_sw
	     then do;
		if icpl > max_icpl
		then do;
		     max_icpl = icpl;
		     max_icpl_line = line;
		end;
		if dcpl > max_dcpl
		then do;
		     max_dcpl = dcpl;
		     max_dcpl_line = line;
		end;
		if ocnt > max_ocnt
		then do;
		     max_ocnt = ocnt;
		     max_ocnt_line = line;
		end;
	     end;

	     else do;
		total = icpl + dcpl + ocnt;
		if total ^= 0
		then call ioa_ ("^a^-^3d^-^3d^-^3d^-^3d", chan_name (line), icpl, dcpl, ocnt, total);
	     end;

	end;

	total = total_icpl + total_dcpl + total_ocnt;
	call ioa_ ("^/TOTAL^-^3d^-^3d^-^3d^-^3d", total_icpl, total_dcpl, total_ocnt, total);

	if brief_sw & max_icpl+max_dcpl+max_ocnt > 0
	then do;
	     call ioa_ ("^/Lines holding most buffers:");
	     if max_icpl > 0
	     then call ioa_ ("^d input for line ^a", max_icpl, chan_name (max_icpl_line));
	     if max_dcpl > 0
	     then call ioa_ ("^d dia for line ^a", max_dcpl, chan_name (max_dcpl_line));
	     if max_ocnt > 0
	     then call ioa_ ("^d output for line ^a", max_ocnt, chan_name (max_ocnt_line));
	end;

	return;

error_exit:
	cmd_info.flush = "1"b;

setup:	proc;

	     corep = arg_corep;
	     fnp = arg_fnp;
	     cmd_infop = arg_cmd_infop;

	     if ^have_symbols
	     then do;
		crttb = db_fnp_sym_util_$get_value (".crttb");
		crtte = db_fnp_sym_util_$get_value (".crtte");
		crnbf = db_fnp_sym_util_$get_value (".crnbf");
		crnbs = db_fnp_sym_util_$get_value (".crnbs");

		t_icpl = db_fnp_sym_util_$get_value ("t.icpl");
		t_dcpl = db_fnp_sym_util_$get_value ("t.dcpl");
		t_ocnt = db_fnp_sym_util_$get_value ("t.ocnt");
		t_sfcm = db_fnp_sym_util_$get_value ("t.sfcm");
		t_line = db_fnp_sym_util_$get_value ("t.line");

		sf_ib0 = db_fnp_sym_util_$get_value ("sf.ib0");
		sf_ib1 = db_fnp_sym_util_$get_value ("sf.ib1");

		tib_words_needed = max (t_icpl, t_dcpl, t_ocnt, t_sfcm, t_line) + 1;
		sfcm_words_needed = max (sf_ib0, sf_ib1) + 1;

		have_symbols = "1"b;
	     end;

	end;					/* setup */

fetch_words: proc (loc, len, p);

dcl  loc fixed bin;
dcl  len fixed bin;
dcl  p ptr;

	     call db_fnp_memory_$fetch (corep, fnp, loc, len, p, code);
	     if code ^= 0
	     then do;
		call com_err_ (code, whoami, "Unable to read location ^o.", loc);
		go to error_exit;
	     end;

	end;					/* fetch_words */



get_operand: proc;

	     call db_fnp_reader_$get_operand (cmd_infop);
	     if cmd_info.error
	     then go to error_exit;

	end;					/* get_operand */

chan_name: proc (line) returns (char (32) var);

dcl  line fixed bin;
dcl  line_name char (32);

	     call db_fnp_util_$cv_line_no (corep, fnp, line, line_name, code);
	     if code ^= 0 then call ioa_$rsnnl ("^o", line_name, (0), line);
	     return (rtrim (line_name));

	end chan_name;

     end;						/* db_fnp_buffer_status_ */





		    db_fnp_call_trace_.pl1          11/15/82  1816.2rew 11/15/82  1501.4      121212



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


/* DB_FNP_CALL_TRACE_ - A procedure to decode a subroutine calling chain in a FNP dump */
/* Written Spetember 1978 by Larry Johnson */

/* This module contains a great deal of imbedded knowledge about how the fnp procedure generate calls.
   It uses a set of heuristics to search backwards from a given starting point to find
   the object code generated by a 'subr' macro. */

/* The following is a detailed description of the subr sequence:

   .	name	ind	0		entry point, and return address word

   .	*	If 'inh' is used, the following is generated

   .		sti	namsi-*		save current indicators
   .		inh			and mask interrupts

   .	*	Next, individual registers are saved.
   .	*	0-6 register saves may follow here selected from (a,q,x1,x2,x3,i)

   .		sta	namsa-*
   .		stx1	namsx1-*
   .		stx3	namsx3-*

   .	*	Now branch to body of subroutine.

   .		tra	start-*

   .	*	For the conveniece of the return macro, the subroutine exit
   .	*	sequence is generated here. The return macro transfers
   .	*	to this point.

   .	*	First, reload all saved registers

   .		lda	namsa-*
   .		ldx1	namsx1-*
   .		ldx3	namsx3-*
   .		ldi	namsi-*

   .	*	And return.

   .		tra	name-*,*

   .	*	Someday, a subroutine name may be stored here, in bcd. This is not
   .	*	done now, but would appear as follows:

   .		bci	6/name

   .	*	Next follows save area for all saved registers

   .	namsi	bss	1
   .	namsa	bss	1
   .	namsx1	bss	1
   .	namsx3	bss	1

   .	*	Next comes the body of the subroutine

   .	start	null
*/

db_fnp_call_trace_: proc (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

/* Parameters */

dcl  arg_corep ptr;
dcl  arg_fnp fixed bin;
dcl  arg_cmd_infop ptr;
dcl  arg_expr_infop ptr;

/* Automatic */

dcl  i fixed bin;
dcl  code fixed bin (35);
dcl  corep ptr;
dcl  fnp fixed bin;
dcl  debug_sw bit (1);				/* Set if -debug used */
dcl  long_sw bit (1);				/* Set if -long used */
dcl  trace_addr fixed bin;

dcl  mem_buf (0:511) bit (18) unal;			/* To hold memory data */
dcl  buf_org fixed bin;				/* Starting address of stuff in mem_buf */
dcl  n_words_in_buf fixed bin;			/* Count of good words */

/* Static */

dcl  constants_setup bit (1) int static init ("0"b);	/* Set when static initialized */
dcl  ld_opcodes (6) bit (18) unal int static;		/* Opcodes of load instruction */
dcl  st_opcodes (6) bit (18) unal int static;		/* Opcodes of store instructions */
dcl  tra bit (18) int static;				/* Opcode of tra instruction */
dcl  inh bit (18) int static;				/* Opcode of inhibit instruction */

/* Constants */

dcl  name char (18) int static options (constant) init ("db_fnp_call_trace_");
dcl  reg_names (6) char (2) int static options (constant) init ("i", "a", "q", "x1", "x2", "x3");
dcl  opmask bit (18) int static options (constant) init ("077000"b3);

/* External */

dcl  ioa_ entry options (variable);
dcl  com_err_ entry options (variable);
dcl  db_fnp_eval_ entry (ptr, fixed bin, char (*), ptr, char (*), fixed bin, fixed bin (35));
dcl  db_fnp_reader_$get_operand entry (ptr);
dcl  db_fnp_edit_inst_$assemble entry (ptr, fixed bin, char (*), ptr, bit (18), fixed bin (35));
dcl  sub_err_ entry options (variable);
dcl  db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35));
dcl  db_fnp_util_$edit_module_addr_paren entry (ptr, fixed bin, fixed bin, char (*) var, fixed bin (35));

dcl (addr, bin, dim, hbound, max, min, null, string, unspec, substr) builtin;

/* Copy arguments */

	fnp = arg_fnp;
	corep = arg_corep;
	expr_infop = arg_expr_infop;
	cmd_infop = arg_cmd_infop;
	if ^constants_setup then call setup_constants;

/* First argument is address to trace from */

	call db_fnp_reader_$get_operand (cmd_infop);
	if cmd_info.error then go to error_return;
	if cmd_info.endline then do;
	     call ioa_ ("Address missing.");
	     go to error_return;
	end;
	call db_fnp_eval_ (corep, fnp, operand, expr_infop, "", trace_addr, code);
	if code ^= 0 then go to error_return;

/* Remaining arguments are control arguments */

	debug_sw, long_sw = "0"b;
	call db_fnp_reader_$get_operand (cmd_infop);
	if cmd_info.error then go to error_return;
	do while (^cmd_info.endline);
	     if operand = "-long" | operand = "-lg" then long_sw = "1"b;
	     else if operand = "-debug" | operand = "-db" then debug_sw = "1"b;
	     else do;
		call ioa_ ("Unrecognized operand: ^a", operand);
		go to error_return;
	     end;
	     call db_fnp_reader_$get_operand (cmd_infop);
	     if cmd_info.error then go to error_return;
	end;

/* Now loop backwards decoding subroutine levels */

	call trace_level;
	do while (trace_addr ^= 0);
	     call trace_level;
	end;

	return;

error_return:
	cmd_info.flush = "1"b;
	return;


/* Procedure that does the  real work of finding a subr */

trace_level: proc;

dcl  i fixed bin;
dcl  w bit (18);
dcl  tra_addr fixed bin;				/* Address if the  second tra instruction */
dcl  ca fixed bin;					/* Current address during scan */
dcl  fb8 fixed bin (8) unal;				/* For bit->fixed conversions */
dcl  st_found (6) bit (1) unal;			/* Mask saying which store instructions found */
dcl  ld_found (6) bit (1) unal;			/* Mask saying which load instructions found */
dcl  ld_target (6) fixed bin;				/* Targets of the ld instructuons */
dcl  max_target fixed bin;
dcl  n_loads fixed bin;
dcl  target fixed bin;
dcl  msg char (64) var;

dcl 1 mi unal,					/* Machine instruction */
    2 i bit (1),					/* Indirect bit */
    2 x bit (2),					/* Index register */
    2 c bit (6),					/* Opcode */
    2 d bit (9);					/* Displacement */

/* Start with address given */

	     ca = trace_addr + 1;

/* Look backwards for a tra instruction.  It must have indirection, no index register,
   and a negative displacement. This the tra that returns from the subr. */

tra_scan:	     ca = ca - 1;
	     w = get_word (ca);			/* Read word */
	     if (w & opmask) ^= tra then go to tra_scan;
	     string (mi) = w;
	     if ^mi.i then go to tra_scan;		/* No indirection */
	     if mi.x then go to tra_scan;		/* Index present */
	     if ^substr (mi.d, 1, 1) then go to tra_scan; /* Displacement not negative */

	     tra_addr = ca;				/* Save address of tra */
	     if debug_sw then call ioa_ ("Fould likely tra at ^a: ^.3b", ed (ca), w);

/* The tra should be preceeded by 0-6 ldxx instructions. All should have no indirection,
   no index register, and an effective address greater than the tra */

	     string (st_found) = "0"b;
	     string (ld_found) = "0"b;
	     n_loads = 0;
	     max_target = tra_addr;

ldxx_scan:     ca = ca - 1;
	     w = get_word (ca);
	     do i = 1 to hbound (ld_opcodes, 1);	/* See if some kind of load */
		if (w & opmask) = ld_opcodes (i) then do; /* Got it */
		     string (mi) = w;
		     if mi.i | mi.x then do;		/* These both should be zero */
ldxx_scan_fail:		if debug_sw then call ioa_ ("ldxx scan failed at ^a: ^.3b", ed (ca), w);
			ca = tra_addr;		/* Back to tra */
			go to tra_scan;		/* And go look for new likely tra */
		     end;
		     if ld_found (i) then go to ldxx_scan_fail; /* Already had one of these */
		     unspec (fb8) = mi.d;		/* Get  signed displacement */
		     target = ca + fb8;		/* Effective address */
		     if target <= tra_addr then go to ldxx_scan_fail;
		     n_loads = n_loads + 1;		/* This is good load */
		     ld_found (i) = "1"b;
		     ld_target (i) = target;
		     max_target = max (max_target, target);
		     go to ldxx_scan;
		end;
	     end;

/* Found a non-ldx opcode. This should be the entry sequence tra to max_target */

	     if (w & opmask) ^= tra then go to ldxx_scan_fail; /* Not a tra */
	     string (mi) = w;			/* To check other fields */
	     if mi.i | mi.x then go to ldxx_scan_fail;
	     unspec (fb8) = mi.d;
	     target = ca + fb8;			/* Target of tra */
	     if n_loads > 0 then			/* If there were loads, .. */
		if target ^= (max_target + 1) then go to ldxx_scan_fail; /* Should point immiditely after save areas */
		else;				/* It does, ok */
	     else if target ^= max_target + 1 then	/* No loads, target should be here */
		if target ^= max_target + 3 then	/* Or here, to allow for two word name someday */
		     go to ldxx_scan_fail;		/* No good target */

/* The middle tra is good. Need to check preceeding stxx instructions */

stxx_scan:     ca = ca - 1;
	     w = get_word (ca);
	     if string (st_found) = string (ld_found) then go to stxx_scan_done; /* All loads have been matched by stores */
	     do i = 1 to hbound (st_opcodes, 1);	/* Look up in store list */
		if (w & opmask) = st_opcodes (i) then do; /* A match */
		     string (mi) = w;		/* For further analysis */
		     if mi.i | mi.x then do;		/* Can't have these */
stxx_scan_fail:		if debug_sw then call ioa_ ("stxx scan failed at ^a: ^.3b", ed (ca), w);
			ca = tra_addr;		/* Back to tra scanning */
			go to tra_scan;
		     end;
		     unspec (fb8) = mi.d;
		     target = ca + fb8;		/* Target of stxx */
		     if ^ld_found (i) then go to stxx_scan_fail; /* No corresponding ldxx instruction */
		     if ld_target (i) ^= target then go to stxx_scan_fail; /* Target must be same */
		     if st_found (i) then go to stxx_scan_fail; /* Duplicate */
		     st_found (i) = "1"b;
		     go to stxx_scan;
		end;
	     end;

/* All stxx instructions have been scanned. The only possible discrepency left between loads and stores,
   is a missing sti, which will occur if 'inh' is used in subr */

	     if string (st_found) ^= string (ld_found) then do; /* There is discrepency */
		if (string (st_found) | "100000"b) ^= string (ld_found) then go to stxx_scan_fail; /* Not just missing sti */
		if w ^= inh then go to stxx_scan_fail;	/* Expect inh instruction here */
		ca = ca - 1;
		w = get_word (ca);
		if (w & opmask) ^= st_opcodes (1) then	/* This better be missing sti */
		     go to stxx_scan_fail;		/* No, too bad */
		ca = ca - 1;
		w = get_word (ca);			/* Read retrun address word */
	     end;

stxx_scan_done:

/* Scan is all done. current word is return address */

	     i = trace_addr;			/* Hold starting addr */
	     trace_addr = 0;
	     if w = "000000"b3 then msg = "never called";
	     else if w = "000001"b3 then do;
		msg = "called form master dispatcher";
		ca = ca + 3;			/* Space over dummy subr */
	     end;
	     else if w = "000002"b3 then do;
		msg = "called from secondary dispatcher";
		ca = ca + 3;
	     end;
	     else do;
		trace_addr = bin (w);		/* For pervious level */
		msg = "called from " || ed (trace_addr);
	     end;

	     call ioa_ ("^a in subr at ^a, ^a", ed (i), ed (ca), msg);

	     if long_sw then do;
		do i = 1 to hbound (reg_names, 1);
		     if ld_found (i) then call ioa_ ("^-^4a^.3b", reg_names (i), get_word (ld_target (i)));
		end;
	     end;

	     return;

	end trace_level;

/* Procedure to manage internal memory buffer. If the word requested is in the buffer, it is returned.
   Otherwise, a new buffer is read with the current address near the end. This allows a small amount of forward scanning
   and a large amount of backeards scanning before more memory must be read */

get_word:	proc (ad) returns (bit (18));

dcl  ad fixed bin;

	     if n_words_in_buf = 0 then do;		/* Empty, must read */
read_new_buf:	buf_org = (max (0, ad - (dim (mem_buf, 1) - 32)));
		if debug_sw then call ioa_ ("Reading memory locations ^o-^o", buf_org, buf_org + hbound (mem_buf, 1));
		call db_fnp_memory_$fetch (corep, fnp, buf_org, dim (mem_buf, 1), addr (mem_buf), code);
		if code ^= 0 then do;
		     call com_err_ (code, name, "Unable to read ^o-^o", buf_org, buf_org + hbound (mem_buf, 1));
		     go to error_return;
		end;
		n_words_in_buf = dim (mem_buf, 1);
	     end;

	     if ad < buf_org | ad > buf_org + n_words_in_buf - 1 then /* Not in current window */
		go to read_new_buf;

	     return (mem_buf (ad - buf_org));

	end get_word;

/* Prccodure to return edited module address */

ed:	proc (ad) returns (char (32) var);

dcl  ad fixed bin;
dcl  temp char (32) var;

	     call db_fnp_util_$edit_module_addr_paren (corep, fnp, ad, temp, code);
	     if code ^= 0 then do;
		call com_err_ (code, name, "Unable to edit ^o.", ad);
		go to error_return;
	     end;

	     return (temp);

	end ed;

/* Compute some baseic needed for life of process */

setup_constants: proc;

dcl  i fixed bin;

	     inh = opc ("inh");			/* Inhibit instruction */
	     tra = opc ("tra");			/* Tra instruction */
	     do i = 1 to hbound (reg_names, 1);
		st_opcodes (i) = opc ("st" || reg_names (i));
		ld_opcodes (i) = opc ("ld" || reg_names (i));
	     end;
	     constants_setup = "1"b;
	     return;

	end setup_constants;

opc:	proc (opname) returns (bit (18));

dcl  opname char (*);
dcl  inst bit (18);

	     call db_fnp_edit_inst_$assemble (corep, fnp, opname, expr_infop, inst, code); /* "assemble" into instruction */
	     if code ^= 0 then call sub_err_ (code, name, "s", null, (0), "Unable to get opcode for ""^a"".", opname);
	     return (inst);

	end opc;

%include debug_fnp_data;

     end db_fnp_call_trace_;




		    db_fnp_convert_address_.pl1     11/15/82  1816.2rew 11/15/82  1501.5       51129



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


/* DB_FNP_CONVERT_ADDRESS_ - Implements the convert_address (cva) command in debug_fnp */
/* This modules takes an expression and converts it to as many meaningful representations as possible */
/* Written August 1977 by Larry Johnson */

db_fnp_convert_address_: proc (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

/* Parameters */

dcl  arg_corep ptr;
dcl  arg_fnp fixed bin;
dcl  arg_cmd_infop ptr;
dcl  arg_expr_infop ptr;

/* Automatic */

dcl  corep ptr;
dcl  fnp fixed bin;
dcl  val fixed bin;
dcl  code fixed bin (35);
dcl  bcode bit (36) aligned based (addr (code));
dcl  work char (32) var;
dcl  printed_version (20) char (32) var;
dcl  n_printed fixed bin;
dcl  i fixed bin;
dcl  opname char (6);
dcl  orig_argp ptr;
dcl  orig_argl fixed bin;
dcl  orig_arg char (orig_argl) based (orig_argp);

/* External */

dcl (ioa_, ioa_$nnl, ioa_$rsnnl) entry options (variable);
dcl  db_fnp_eval_ entry (ptr, fixed bin, char (*), ptr, char (*), fixed bin, fixed bin (35));
dcl  db_fnp_util_$edit_module_addr entry (ptr, fixed bin, fixed bin, char (*) var, fixed bin (35));
dcl  db_fnp_edit_inst_$compressed entry (ptr, fixed bin, bit (18), char (*) var);
dcl  db_fnp_opblock_util_$get_name entry (bit (18), char (*));
dcl  db_fnp_reader_$get_operand entry (ptr);

dcl (addr, hbound, length, rtrim, substr) builtin;

	corep = arg_corep;				/* Copy args */
	fnp = arg_fnp;
	expr_infop = arg_expr_infop;
	cmd_infop = arg_cmd_infop;

	call db_fnp_reader_$get_operand (cmd_infop);	/* Be sure one operand */
	if cmd_info.error then go to error_return;
	if cmd_info.endline then do;
	     call ioa_ ("Address missing");
	     go to error_return;
	end;

/* Evaluate each operand in turn. */

	do while (^cmd_info.endline);
	     call db_fnp_eval_ (corep, fnp, operand, expr_infop, "", val, code); /* Get value of arg */
	     if code ^= 0 then go to next_operand;
	     orig_argp = addr (operand);
	     orig_argl = length (operand);
	     if substr (orig_arg, 1, 1) = "'" then do;	/* Fudge apostrophed string */
		orig_argl = orig_argl - 1;
		orig_argp = addr (substr (orig_arg, 2, 1));
		if substr (orig_arg, orig_argl, 1) = "'" then orig_argl = orig_argl - 1;
	     end;
	     call ioa_$nnl ("""^a""", orig_arg);	/* Print origional arg */
	     n_printed = 0;

/* Try octal */

	     call ioa_$rsnnl ("^o", work, (0), val);
	     call test_print;

/* Special test for negative numbers */

	     code = val;
	     if substr (bcode, 19, 1) then do;
		call ioa_$rsnnl ("^.3b", work, (0), substr (bcode, 19));
		call test_print;
	     end;

/* Try module | offset */

	     call db_fnp_util_$edit_module_addr (corep, fnp, val, work, code);
	     if code = 0 then if work ^= "" then call test_print;

/* Try opblock name */

	     code = val;
	     if substr (bcode, 19, 9) = "777"b3 then do;
		call db_fnp_opblock_util_$get_name (substr (bcode, 19, 18), opname);
		if opname ^= "" then do;
		     work = rtrim (opname);
		     call test_print;
		end;
	     end;

/* Try system defined symbols */

	     symbol_tablep = addr (db_fnp_symbols_$db_fnp_symbols_);
	     do i = 1 to symbol_table.cnt;
		symp = addr (symbol_table.entry (i));
		if sym.reloc = reloc_abs then call check_sym (0);
		else if (sym.reloc = reloc_tib) & expr_info.tib_known then call check_sym (expr_info.tib_addr);
		else if (sym.reloc = reloc_hwcm) & expr_info.hwcm_known then call check_sym (expr_info.hwcm_addr);
		else if (sym.reloc = reloc_sfcm) & expr_info.sfcm_known then call check_sym (expr_info.sfcm_addr);
	     end;
	     if expr_info.star_known then if val = expr_info.star_addr then do;
		     work = "*";
		     call test_print;
		end;

/* Try decimal */

	     call ioa_$rsnnl ("^d.", work, (0), val);
	     call test_print;

/* Try machine instruction */

	     code = val;
	     call db_fnp_edit_inst_$compressed (corep, fnp, substr (bcode, 19), work);
	     if work ^= "" then call test_print;

/* All done with operand */

	     call ioa_ ("");
next_operand:
	     call db_fnp_reader_$get_operand (cmd_infop);
	     if cmd_info.error then go to error_return;
	end;
	return;

error_return:
	cmd_info.error = "1"b;
	return;

/* Subroutine to decide whether expr is a valid symbol */

check_sym: proc (reloc);

dcl  reloc fixed bin;
dcl (w1, w2) fixed bin;				/* Range of words in symbol */

	     w1 = sym.value + reloc;
	     w2 = w1 + sym.len -1;
	     if val >= w1 & val <= w2 then do;		/* Value within symbol */
		if val = w1 then work = sym.name;
		else call ioa_$rsnnl ("^a+^o", work, (0), sym.name, val-w1);
		call test_print;
	     end;
	     return;

	end check_sym;

/* Subrotuine that prints a converted value only if it is diffetent */

test_print: proc;

dcl  i fixed bin;

	     if work = orig_arg then return;		/* Same as origional */
	     do i = 1 to n_printed;			/* Scan list already printed */
		if work = printed_version (i) then return;
	     end;
	     call ioa_$nnl (" = ""^a""", work);		/* Print new version */
	     if n_printed < hbound (printed_version, 1) then do; /* And save it */
		n_printed = n_printed + 1;
		printed_version (n_printed) = work;
	     end;
	     return;

	end test_print;

%include debug_fnp_data;

     end db_fnp_convert_address_;




		    db_fnp_disp_cmd_.pl1            11/15/82  1816.2rew 11/15/82  1501.7      157194



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


/* DB_FNP_DISP_CMD_: Various entries to perform display type command for debug_fnp */
/* Extracted from main command, and added to, February 1978 by Larry Johnson */
/* Added set_flag and clear_flag commands October 1978 */

db_fnp_disp_cmd_: proc;

/* Arguments */

dcl  arg_corep ptr;
dcl  arg_fnp fixed bin;
dcl  arg_cmd_infop ptr;
dcl  arg_expr_infop ptr;

/* Automatic */

dcl  code fixed bin (35);
dcl  corep ptr;
dcl  fnp fixed bin;
dcl  unal_temp fixed bin (17) unal;
dcl  fnp_buf (0:2047) bit (18) unal;
dcl  flag_work bit (18);
dcl  flag_orig bit (18);
dcl  fnp_addr fixed bin;
dcl  fnp_len fixed bin;
dcl  expr_val fixed bin;
dcl  sw bit (1);
dcl  addr_sw bit (1);
dcl  first_sw bit (1);
dcl  found_sw bit (1);
dcl (i, j) fixed bin;
dcl  mask bit (18);
dcl  temp_word bit (18);
dcl  flag_name char (6);
dcl  symno fixed bin;
dcl  nbits fixed bin;
dcl  disp_type fixed bin;
dcl  disp_len fixed bin;
dcl  type_sw bit (1);
dcl  length_sw bit (1);
dcl  brief_sw bit (1);
dcl  set_flag_sw bit (1);

dcl  based_char char (i) based;

/* Internal static */

dcl  next_buf_addr fixed bin int static init (0);		/* Forward link from last buffer */
dcl  next_block_addr fixed bin int static init (0);	/* Forward link from last block */
dcl  block_length fixed bin int static init (0);
dcl  block_offset fixed bin int static init (0);

/* External */

dcl  ioa_ entry options (variable);
dcl  ioa_$nnl entry options (variable);
dcl  db_fnp_eval_ entry (ptr, fixed bin, char (*), ptr, char (*), fixed bin, fixed bin (35));
dcl  db_fnp_reader_$get_operand entry (ptr);
dcl  db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35));
dcl  db_fnp_memory_$store entry (ptr, fixed bin, fixed bin, fixed bin, ptr, char (*), fixed bin, fixed bin (35));
dcl  db_fnp_display_ entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin, fixed bin (35));
dcl  db_fnp_sym_util_$lookup entry (char (*), ptr);
dcl  com_err_ entry options (variable);

dcl (addr, bin, copy, divide, hbound, index, lbound, length, mod, null, substr, unspec) builtin;

/* Entry to display memory in various forms */

display:	entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;

	call get_operand_req ("Address");
	call cv_expr_op;
	fnp_addr = expr_val;
	disp_type = expr_info.type;
	disp_len = expr_info.len;
	length_sw = "0"b;				/* Length not specified */
	type_sw = "0"b;
	call get_operand;				/* Look for more operands */
	do while (^cmd_info.endline);
	     if ^type_sw then do;
		call check_type;
		if type_sw then go to display_command2;
	     end;
	     if ^length_sw then do;
		call cv_length_op;
		disp_len = expr_val;
		length_sw = "1"b;
	     end;
	     else do;
		call ioa_ ("Invalid operand: ^a", operand);
		go to error_return;
	     end;
display_command2:
	     call get_operand;
	end;

	if length_sw & ^type_sw then disp_type = type_oct;
	call fetch (fnp_addr, disp_len, addr (fnp_buf));
	expr_info.star_addr = fnp_addr;		/* Now safe to remember this address as "*" */
	expr_info.star_known = "1"b;
	call db_fnp_display_ (corep, fnp, fnp_addr, disp_len, addr (fnp_buf), disp_type, code);
	if code ^= 0 then call com_err_ (code, "", "Unable to display memory.");
	return;

/* Entry to patch memory */

patch:	entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;

	call get_operand_req ("Address");
	call cv_expr_op;
	fnp_addr = expr_val;
patch_command2:
	fnp_len = 0;
	call get_operand_req ("Data word");
	do while (^cmd_info.endline);
	     if ^cmd_info.opstring then do;		/* If not a quoted string */
		if fnp_len >= 32 then do;
long_patch:	     call ioa_ ("Too much data");
		     go to error_return;
		end;
		call cv_expr_op;
		code = expr_val;			/* Move into full word area */
		fnp_buf (fnp_len) = substr (unspec (code), 19, 18);
		fnp_len = fnp_len + 1;
	     end;
	     else do;				/* Do a character patch */
		i = length (operand);
		i = i + mod (i, 2);			/* Round to full words */
		if i = 0 then i = 2;
		if (fnp_len + divide (i, 2, 17, 0)) > 32 then go to long_patch;
		addr (fnp_buf (fnp_len)) -> based_char = operand;
		fnp_len = fnp_len + divide (i, 2, 17, 0);
	     end;
	     call get_operand;
	end;
	expr_info.star_addr = fnp_addr;		/* Remember location as "*" */
	expr_info.star_known = "1"b;
	call store (fnp_addr, fnp_len, addr (fnp_buf));
	return;


/* Entry to do the = command, equivalent to patch * */

equal:	entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;

	if ^expr_info.star_known then do;
	     call ioa_ ("Value of ""*"" not known.");
	     go to error_return;
	end;
	fnp_addr = expr_info.star_addr;
	go to patch_command2;

/* Entries for dealing with buffers */

buffer:	entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;

	call parse_buffer_command;
	call display_buffer;

	return;


buffer_chain: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;

	call parse_buffer_command;
	call display_buffer;
	do while (next_buf_addr ^= 0);
	     call ioa_ ("");
	     call display_buffer;
	end;
	return;

/* Entries for dealing with blocks chained together */

block:	entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;

	call parse_block_command;
	call display_block;

	return;

block_chain: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;

	call parse_block_command;
	call display_block;
	do while (next_block_addr ^= 0);
	     call ioa_ ("");
	     call display_block;
	end;
	return;


forget:	entry;

	next_buf_addr, next_block_addr, block_offset = 0;
	block_length = 8;

	return;

/* Procudure to parse commands like buffer and buffer_chain */

parse_buffer_command: proc;

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

	     type_sw = "0"b;
	     disp_type = type_char;
	     brief_sw = "0"b;
	     call get_operand;
	     do while (^cmd_info.endline);
		if operand = "brief" | operand = "bf" | operand = "-brief" | operand = "-bf" then do;
		     brief_sw = "1"b;
		     go to next_buffer_operand;
		end;
		if ^type_sw then do;
		     call check_type;
		     if type_sw then go to next_buffer_operand; /* Valid type */
		end;
		if ^got_addr then do;
		     call cv_expr_op;
		     next_buf_addr = expr_val;
		     got_addr = "1"b;
		end;
		else do;
		     call ioa_ ("Unrecognized operand: ^a", operand);
		     go to error_return;
		end;
next_buffer_operand: call get_operand;
	     end;
	     if ^got_addr then if next_buf_addr = 0 then do;
		     call ioa_ ("No next buffer");
		     go to error_return;
		end;
	     return;

	end parse_buffer_command;

/* Procedure to fetch and display a buffer */

display_buffer: proc;

dcl  i fixed bin;
dcl  nwords fixed bin;

	     if (next_buf_addr = 0) | (mod (next_buf_addr, 32) ^= 0) then do; /* Boundary is wrong */
		call ioa_ ("Invalid buffer address: ^o", next_buf_addr);
		go to error_return;
	     end;
	     call fetch (next_buf_addr, 2, addr (fnp_buf)); /* Read header */
	     if brief_sw then nwords = 2;		/* If brief, thats all */
	     else do;
		nwords = 32 * (bin (substr (fnp_buf (1), 1, 3)) + 1); /* Calc word count of buffer */
		call fetch (next_buf_addr + 2, nwords - 2, addr (fnp_buf (2))); /* Read rest of buffer */
	     end;
	     expr_info.star_addr = next_buf_addr;
	     expr_info.star_known = "1"b;
	     i = next_buf_addr;
	     next_buf_addr = bin (fnp_buf (0));
	     call db_fnp_display_ (corep, fnp, i, nwords, addr (fnp_buf), disp_type, code);
	     if code ^= 0 then do;
		call com_err_ (code, "", "Unable to display memory.");
		go to error_return;
	     end;
	     return;

	end display_buffer;

/* Procedure to parse command lines for block and block_chain commands */

parse_block_command: proc;

dcl  new_block_addr fixed bin;
dcl  new_block_length fixed bin;
dcl  new_block_offset fixed bin;
dcl  got_addr bit (1);

	     call get_operand;
	     if cmd_info.endline then do;
		if next_block_addr = 0 then do;
		     call ioa_ ("No block address.");
		     go to error_return;
		end;
		else return;
	     end;
	     new_block_offset = 0;
	     new_block_length = 8;
	     new_block_addr = next_block_addr;
	     got_addr = "0"b;
	     do while (^cmd_info.endline);
		if operand = "-offset" | operand = "-o" then do;
		     call get_operand_req ("Offset");
		     call cv_expr_op;
		     if expr_val < 0 | expr_val > 2044 then do;
			call ioa_ ("Invalid offset: ^a", operand);
			go to error_return;
		     end;
		     new_block_offset = expr_val;
		end;
		else if operand = "-length" | operand = "-l" then do;
		     call get_operand_req ("Length");
		     call cv_length_op;
		     new_block_length = expr_val;
		end;
		else if ^got_addr then do;
		     call cv_expr_op;
		     new_block_addr = expr_val;
		     got_addr = "1"b;
		end;
		else do;
		     call ioa_ ("Unrecognized operand: ^a", operand);
		     go to error_return;
		end;
		call get_operand;
	     end;

	     if new_block_offset >= new_block_length then do;
		call ioa_ ("Offset greater than block length");
		go to error_return;
	     end;
	     if new_block_addr = 0 then do;
		call ioa_ ("No block address");
		go to error_return;
	     end;
	     next_block_addr = new_block_addr;
	     block_length = new_block_length;
	     block_offset = new_block_offset;
	     return;

	end parse_block_command;

/* Procedure to display a block for block and block chain commands */

display_block: proc;

dcl  i fixed bin;

	     if next_block_addr = 0 then do;
		call ioa_ ("No next block address");
		go to error_return;
	     end;
	     call fetch (next_block_addr, block_length, addr (fnp_buf));
	     expr_info.star_addr = next_block_addr;
	     expr_info.star_known = "1"b;
	     i = next_block_addr;
	     next_block_addr = bin (fnp_buf (block_offset));
	     call db_fnp_display_ (corep, fnp, i, block_length, addr (fnp_buf), type_oct, code);
	     if code ^= 0 then do;
		call com_err_ (code, "", "Unable to display memory");
		go to error_return;
	     end;
	     return;

	end display_block;

/* Entry to display a word by interpreting its flags */

flags:	entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;

	call get_operand_req ("address");		/* Need address to decode */
	if substr (operand, 1, 1) = "=" then do;	/* A literal, no memory reference needed */
	     call db_fnp_eval_ (corep, fnp, substr (operand, 2), expr_infop, "", expr_val, code);
	     if code ^= 0 then go to error_return;
	     unal_temp = expr_val;			/* Need unaligned version for unspec */
	     flag_orig = unspec (unal_temp);
	     flag_name = "";
	     addr_sw = "0"b;
	end;
	else do;					/* Must read data from memory */
	     call cv_expr_op;
	     call fetch (expr_val, 1, addr (fnp_buf));	/* Get word */
	     flag_orig = fnp_buf (0);
	     flag_name = operand;			/* Flag type defaults to first operand */
	     if flag_name ^= operand then flag_name = ""; /* Unless too long */
	     addr_sw = "1"b;			/* Have address to print */
	     fnp_addr = expr_val;
	end;
	call get_operand;				/* Type of flag decoding to do */
	if ^cmd_info.endline then flag_name = operand;
	if flag_name = "" then do;
	     call ioa_ ("No flag type specified");
	     go to error_return;
	end;

	symbol_tablep = addr (db_fnp_symbols_$db_fnp_symbols_);
	found_sw, first_sw = "0"b;
	flag_work = flag_orig;			/* Starting value of word */
	do symno = 1 to symbol_table.cnt;		/* Scan entire symbol table */
	     symp = addr (symbol_table.entry (symno));
	     if sym.flag_mem = flag_name then do;	/* Symbol defines a flag in this kind of word */
		found_sw = "1"b;
		if ^first_sw then do;		/* Print start of line */
		     call ioa_$nnl ("^[^5o  ^;^s^]^.3b", addr_sw, fnp_addr, flag_orig);
		     first_sw = "1"b;
		end;
		temp_word = unspec (sym.value);	/* Copy value of symbol */
		i = index (temp_word, "1"b);		/* Find first 1 bit */
		if i = 0 then go to check_next_sym;	/* All zero value useless here */
		substr (temp_word, i, 1) = "0"b;	/* Turn off first bit */
		if temp_word then do;		/* Symbol is a multiple bit symbol */
		     nbits = 1;
		     do j = i+1 to 18 while (temp_word); /* First, count the bits */
			substr (temp_word, j, 1) = "0"b;
			nbits = nbits + 1;
		     end;
		     mask = unspec (sym.value);
		     temp_word = flag_orig & mask;	/* Isolate origional value of symbol */
		     if sym.type = type_oct then call ioa_$nnl (" ^a=^.3b", sym.name, copy ("0"b, mod (3 - mod (nbits, 3), 3)) || substr (temp_word, i, nbits));
		     else call ioa_$nnl (" ^a=^b", sym.name, substr (temp_word, i, nbits));
		     flag_work = flag_work & ^mask;	/* These bits have been explained */
		end;
		else do;				/* Simpler case, flag is a single bit */
		     temp_word = unspec (sym.value);
		     if temp_word & flag_work then do;	/* Bit is on */
			call ioa_$nnl (" ^a", sym.name);
			sw = "0"b;
			do i = symno+1 to symbol_table.cnt; /* Scan rest of table for synonyms */
			     symp = addr (symbol_table.entry (i));
			     if (unspec (sym.value) = temp_word) & (sym.flag_mem = flag_name) then do; /* Got one */
				call ioa_$nnl (" ^[^;(^]^a", sw, sym.name);
				sw = "1"b;
			     end;
			end;
			if sw then call ioa_$nnl (")"); /* Close list of synonyms */
		     end;
		     flag_work = flag_work & ^temp_word; /* Flag is identified */
		end;
	     end;
check_next_sym:
	end;

	if ^found_sw then do;
	     call ioa_ ("No flags found in symbol_table for ^a", flag_name);
	     go to error_return;
	end;
	if addr_sw then do;
	     expr_info.star_addr = fnp_addr;
	     expr_info.star_known = "1"b;		/* Remember flag addres as "*" */
	end;
	if ^first_sw then call ioa_ ("^[^5o  ^;^s^]^.3b", addr_sw, fnp_addr, flag_orig);
	else call ioa_ ("");
	if flag_work then call ioa_ ("No flags defined for ^.3b", flag_work);
	return;

/* Commands for setting and clearing flags */

set_flag:	entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	set_flag_sw = "1"b;
	go to join_clear_flag;

clear_flag: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	set_flag_sw = "0"b;
join_clear_flag:
	call setup;

	call get_operand_req ("Flag");
	call db_fnp_sym_util_$lookup (operand, symp);
	if symp = null () then do;
	     call ioa_ ("Undefined symbol: ^a", operand);
	     go to error_return;
	end;
	if sym.flag_mem = "" then do;
	     call ioa_ ("Symbol is not a flag: ^a", operand);
	     go to error_return;
	end;

	call db_fnp_eval_ (corep, fnp, sym.flag_mem, expr_infop, "", expr_val, code);
	if code ^= 0 then go to error_return;

	call fetch (expr_val, 1, addr (fnp_buf));	/* Read old word value */
	expr_info.star_addr = expr_val;
	expr_info.star_known = "1"b;
	if set_flag_sw then fnp_buf (0) = fnp_buf (0) | unspec (sym.value);
	else fnp_buf (0) = fnp_buf (0) & ^unspec (sym.value);
	call store (expr_val, 1, addr (fnp_buf));
	return;

error_return:
	cmd_info.flush = "1"b;
	return;

/* Procedure to extract 1 operand from the command line */

get_operand: proc;

	     call db_fnp_reader_$get_operand (cmd_infop);
	     if cmd_info.error then go to error_return;
	     return;

	end get_operand;

get_operand_req: proc (s);

dcl  s char (*);

	     call get_operand;
	     if cmd_info.endline then do;
		call ioa_ ("^a missing.", s);
		go to error_return;
	     end;
	     else return;

	end get_operand_req;

/* Procedure to convert an operand intended to be a length */

cv_length_op: proc;

	     call cv_expr_op;
	     if (expr_val < 1) | (expr_val > 2044) then do;
		call ioa_ ("Invalid length: ^a", operand);
		go to error_return;
	     end;
	     return;

	end cv_length_op;

/* Procedure called when operand is an expression */

cv_expr_op: proc;

	     call db_fnp_eval_ (corep, fnp, operand, expr_infop, "", expr_val, code);
	     if code ^= 0 then go to error_return;
	     else return;

	end cv_expr_op;

/* Read some fnp words */

fetch:	proc (a, l, p);

dcl  a fixed bin;					/* Address to read */
dcl  l fixed bin;					/* Length to read */
dcl  p ptr;					/* Where to put it */

	     call db_fnp_memory_$fetch (corep, fnp, a, l, p, code);
	     if code ^= 0 then do;
		call com_err_ (code, "", "Unable to read fnp memory.");
		go to error_return;
	     end;
	     else return;

store:	     entry (a, l, p);

	     call db_fnp_memory_$store (corep, fnp, a, l, p, "", 2, code);
	     if code ^= 0 then do;
		call com_err_ (code, "", "Unable to patch memory");
		go to error_return;
	     end;


	end fetch;

/* Setup arguments */

setup:	proc;

	     corep = arg_corep;
	     fnp = arg_fnp;
	     cmd_infop = arg_cmd_infop;
	     expr_infop = arg_expr_infop;
	     return;

	end setup;

/* Procedure to check operand for valid display type */

check_type: proc;

dcl  i fixed bin;

	     do i = lbound (long_type_names, 1) to hbound (long_type_names, 1);
		if operand = short_type_names (i) | operand = long_type_names (i)
		| operand = "-" || short_type_names (i) | operand = "-" || long_type_names (i) then do;
		     type_sw = "1"b;
		     disp_type = i;
		     return;
		end;
	     end;
	     return;

	end check_type;


%include debug_fnp_data;

     end db_fnp_disp_cmd_;




		    db_fnp_display_.pl1             11/15/82  1816.2rew 11/15/82  1501.7       63189



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


/* Procedure for displaying contents of fnp memory in various formats */

/* Written February 1977 by Larry Johnson */

db_fnp_display_: proc (arg_corep, arg_fnp, arg_fnp_addr, arg_fnp_len, arg_data_ptr, arg_type, arg_code);

/* Arguments */

dcl  arg_corep ptr;					/* Pointer to core image */
dcl  arg_fnp fixed bin;				/* Number of running fnp */
dcl  arg_fnp_addr fixed bin;				/* Fnp addr being displayed */
dcl  arg_fnp_len fixed bin;				/* The number of wrds */
dcl  arg_data_ptr ptr;				/* Multics pointer to the data */
dcl  arg_type fixed bin;				/* The editing mode to perform */
dcl  arg_code fixed bin (35);

/* Automatic */

dcl  fnp_addr fixed bin;
dcl  fnp_len fixed bin;
dcl  data_ptr ptr;
dcl  type fixed bin;
dcl  code fixed bin (35);
dcl  bcode bit (36) aligned based (addr (code));
dcl  part_len fixed bin;				/* Length of memory being displayed on 1 line */
dcl  part_ptr ptr;					/* A pointer to it */
dcl  words_per_line fixed bin;			/* The number of words on a line */
dcl  next_word fixed bin;
dcl  words_left fixed bin;
dcl  char_str char (64) var;
dcl  dt_val fixed bin (71);				/* For date_time_ */
dcl  dt_str char (24);
dcl  ebcdic_sw bit (1) init ("0"b);
dcl  last_part bit (144);				/* Contents of last line, to supress dups */
dcl  suppress bit (1);				/* Last line was not printed */
dcl  suppress_addr fixed bin;				/* Addr of last line not printed */
dcl  check_dup bit (1);				/* Try duplicate line suppression */

dcl  fnp_mem (fnp_len) bit (18) unal based (data_ptr);	/* All of memory being displayed */
dcl  part_mem (part_len) bit (18) unal based (part_ptr);	/* What will fit on a line */
dcl  ch_part_mem char (2*part_len) based (part_ptr);

/* External */

dcl  ioa_ entry options (variable);
dcl  ioa_$nnl entry options (variable);
dcl  db_fnp_util_$edit_module_addr entry (ptr, fixed bin, fixed bin, char (*) var, fixed bin (35));
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  db_fnp_opblock_util_$display entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35));
dcl  db_fnp_edit_inst_ entry (ptr, fixed bin, fixed bin, bit (18), char (*) var);
dcl  ebcdic_to_ascii_ entry (char (*), char (*));

dcl (addr, bin, length, min, substr, unspec) builtin;


/* Initialization */

	fnp_addr = arg_fnp_addr;			/* Cpy args */
	fnp_len = arg_fnp_len;
	data_ptr = arg_data_ptr;
	type = arg_type;

	if type = type_op then do;			/* Dont handle this one here */
	     call db_fnp_opblock_util_$display (arg_corep, arg_fnp, fnp_addr, fnp_len, data_ptr, arg_code);
	     return;
	end;

	if type = type_clock then words_per_line = min (4, fnp_len);
	else if type = type_addr then words_per_line = 1;
	else if type = type_inst then words_per_line = 1;
	else if type = type_dec then words_per_line = 1;
	else if type = type_bit then words_per_line = 1;
	else words_per_line = min (8, fnp_len);

	check_dup = (words_per_line = 8);
	suppress = "0"b;

	next_word = 1;				/* First word to display */
	words_left = fnp_len;			/* Words yet to do */

	do while (words_left > 0);			/* Loop until done */
	     part_len = min (words_per_line, words_left); /* Number of words on this line */
	     part_ptr = addr (fnp_mem (next_word));
	     if check_dup & (next_word > 1) then do;	/* Check for duplicate lines */
		if unspec (part_mem) = last_part then do; /* Same as previous */
		     suppress = "1"b;
		     suppress_addr = fnp_addr;	/* Last line not printed */
		     go to next_line;
		end;
		else if suppress then do;		/* End of duplicate range */
		     call ioa_ ("^5w  =", suppress_addr);
		     suppress = "0"b;
		end;
	     end;
	     if type = type_inst then do;		/* Special form for instruction */
		call db_fnp_util_$edit_module_addr (arg_corep, arg_fnp, fnp_addr, char_str, code);
		if code ^= 0 then char_str = "";
		call ioa_$nnl ("^5w ^13a ^( ^.3b^)", fnp_addr, char_str, part_mem);
	     end;
	     else call ioa_$nnl ("^5w ^( ^.3b^)", fnp_addr, part_mem);
	     go to display_edit (type);		/* Finish up, based on type */

display_edit (0):					/* Octal */
	     call ioa_ ("");
	     go to next_line;

display_edit (1):					/* Character */
	     call setup_chars;
	     call ioa_ ("^v(^7x^) ^a", words_per_line - part_len, char_str);
	     go to next_line;

display_edit (2):					/* Address */
	     call db_fnp_util_$edit_module_addr (arg_corep, arg_fnp, bin (part_mem (1)), char_str, code);
	     call ioa_ ("^[  ^a^]", (code = 0), char_str);
	     go to next_line;

display_edit (3):					/* Clock reading */
	     unspec (dt_val) = unspec (part_mem);
	     call date_time_ (dt_val, dt_str);
	     call ioa_ ("  ^a", dt_str);
	     go to next_line;

display_edit (4):					/* Machine instruction */
	     call db_fnp_edit_inst_ (arg_corep, arg_fnp, fnp_addr, part_mem (1), char_str);
	     call ioa_ ("  ^a", char_str);
	     go to next_line;

display_edit (6):					/* Decimal */
	     bcode = "0"b;
	     substr (bcode, 19, 18) = part_mem (1);
	     if substr (part_mem (1), 1, 1) then substr (bcode, 1, 18) = "777777"b3;
	     call ioa_ ("  ^d.", code);
	     go to next_line;

display_edit (7):
	     call ioa_ ("  ^b", part_mem (1));
	     go to next_line;

display_edit (8):					/* Ebcdic */
	     ebcdic_sw = "1"b;
	     go to display_edit (1);

next_line:					/* Advance indexes for next line */
	     if check_dup then last_part = unspec (part_mem); /* Save to compare to next line */
	     fnp_addr = fnp_addr + part_len;
	     next_word = next_word + part_len;
	     words_left = words_left - part_len;
	end;

	if suppress then call ioa_ ("^5w  =", suppress_addr); /* Last line was not printed */

	arg_code = 0;
	return;


/* Procedure to stup for charactr fisplay. non-graphics are replaced with dots */

setup_chars: proc;

dcl  i fixed bin;
dcl (ebc_in, ebc_out) char (16);

	     if ebcdic_sw then do;			/* Must convert to ascii */
		unspec (ebc_in) = "0"b;
		substr (ebc_in, 1, length (ch_part_mem)) = ch_part_mem;
		do i = 1 to length (ch_part_mem);
		     unspec (substr (ebc_in, i, 1)) = unspec (substr (ebc_in, i, 1)) & "377"b3;
		end;
		call ebcdic_to_ascii_ (ebc_in, ebc_out);
		char_str = substr (ebc_out, 1, length (ch_part_mem));
	     end;
	     else char_str = ch_part_mem;
	     do i = 1 to length (char_str);
		unspec (substr (char_str, i, 1)) = unspec (substr (char_str, i, 1)) & "177"b3;
		if unspec (substr (char_str, i, 1)) < "040"b3 | unspec (substr (char_str, i, 1)) > "176"b3 then
		     substr (char_str, i, 1) = ".";
	     end;
	     return;

	end setup_chars;


%include debug_fnp_data;

     end db_fnp_display_;




		    db_fnp_dumps_.pl1               11/15/82  1816.2rew 11/15/82  1501.8       60156



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


/* DB_FNP_DUMPS_ - Contains entries used by debug_fnp for finding various things in FNP dumps */

/* Written February 1977 by Larry Johnson */

/* format: style4,delnl,insnl,^ifthendo */
db_fnp_dumps_:
     proc;

/* Arguments */

dcl  arg_corep ptr;					/* Address of the dump */
dcl  arg_fnp fixed bin;
dcl  arg_cmd_infop ptr;
dcl  arg_expr_infop ptr;

/* Automatic */

dcl  corep ptr;
dcl  fnp fixed bin;
dcl  code fixed bin (35);
dcl  edited_addr char (24) var;
dcl  mem_word (1) bit (18) unal;
dcl  modnum fixed bin;
dcl  modname char (12);
dcl  i fixed bin;
dcl  rp ptr;
dcl  edit_ind char (128) var;

dcl  1 fault_data unal,				/* Format of fault data in dump */
       2 ic bit (18),
       2 ir,
         3 indicators bit (8),
         3 pad bit (10),
       2 a bit (18),
       2 q bit (18),
       2 x1 bit (18),
       2 x2 bit (18),
       2 x3 bit (18),
       2 er bit (18),
       2 et bit (18),
       2 type fixed bin (17),
       2 name bit (18);

dcl  1 die_word unal,
       2 modnum bit (4),
       2 opcode bit (5),
       2 reason bit (9);

dcl  msg_offset (1) bit (18) aligned based;		/* Table of offsets in od355_msgs$ */

/* Constants */

dcl  fault_names (0:10) char (16) int static options (constant)
	init ("power off", "power on", "memory parity", "illegal opcode", "overflow", "store", "divide", "illegal int",
	"extra int", "iom", "console abort");

dcl  indicator_names (8) char (20) var int static options (constant)
	init ("zero", "negative", "carry", "overflow", "interrupt inhibit", "parity inhibit", "overflow inhibit", "parity");

dcl  die_op bit (5) int static options (constant) init ("01001"b);
						/* Opcode used to cause crashes */

/* Static */

dcl  constants_setup bit (1) int static init ("0"b);
dcl  crreg fixed bin int static;			/* Address of saved machine conditions */

/* External stuff */

dcl  ioa_ entry options (variable);
dcl  db_fnp_util_$edit_module_addr entry (ptr, fixed bin, fixed bin, char (*) var, fixed bin (35));
dcl  db_fnp_sym_util_$get_value entry (char (*)) returns (fixed bin);
dcl  db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35));
dcl  com_err_ entry options (variable);

dcl  od355_msgs$ ext;
dcl  1 od355_msgs$die_list (8) ext aligned,
       2 name char (12),
       2 offset fixed bin;

dcl  (addr, bin, length, ptr, string, substr) builtin;

/* Entry to print reason for crash */


why:
     entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;

	call read_fault_data;

	if fault_data.ic = "0"b
	then do;
	     call ioa_ ("No fault occurred.");
	     return;
	end;

	call edit (fault_data.ic);
	if fault_data.type >= lbound (fault_names, 1) & fault_data.type <= hbound (fault_names, 1)
	then call ioa_ ("^a fault at ^o ^a", fault_names (fault_data.type), bin (fault_data.ic), edited_addr);
	else call ioa_ ("Unknown fault (type ^o) at ^o ^a", fault_data.type, bin (fault_data.ic), edited_addr);

	if fault_data.type ^= 3
	then return;				/* Not illegal opcode */
	call fetch (bin (fault_data.ic) - 1, 1, addr (mem_word));
						/* Read opcode causing the fault */
	string (die_word) = mem_word (1);
	if die_word.opcode ^= die_op
	then return;				/* Not deliberate */

	modnum = bin (die_word.modnum);
	modname = od355_msgs$die_list.name (modnum);	/* Name of module causing fault */

	rp = ptr (addr (od355_msgs$), od355_msgs$die_list.offset (modnum));
						/* Address of list of offsets to reasons */
	rp = ptr (addr (od355_msgs$), rp -> msg_offset (bin (die_word.reason)));
	call ioa_ ("^a: ^A", modname, rp);
	return;

/* Entry to print registers */

regs:
     entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;

	call read_fault_data;

	call edit (fault_data.ic);
	call ioa_ ("ic  ^.3b ^a", fault_data.ic, edited_addr);
	call ioa_ ("aq  ^.3b ^.3b", fault_data.a, fault_data.q);
	edit_ind = "";
	if fault_data.ir.indicators ^= "0"b
	then do;
	     do i = 1 to 8;
		if substr (fault_data.ir.indicators, i, 1)
		then do;				/* Found one one */
		     if length (edit_ind) = 0
		     then edit_ind = "(";
		     else edit_ind = edit_ind || ",";
		     edit_ind = edit_ind || indicator_names (i);
		end;
	     end;
	     edit_ind = edit_ind || ")";
	end;
	call ioa_ ("ir  ^.3b ^a", string (fault_data.ir), edit_ind);
	call edit (fault_data.x1);
	call ioa_ ("x1  ^.3b ^a", fault_data.x1, edited_addr);
	call edit (fault_data.x2);
	call ioa_ ("x2  ^.3b ^a", fault_data.x2, edited_addr);
	call edit (fault_data.x3);
	call ioa_ ("x3  ^.3b ^a", fault_data.x3, edited_addr);
	call ioa_ ("er  ^.3b", fault_data.er);
	call ioa_ ("et  ^.3b", fault_data.et);
	return;


/* Procedure to edit an address */

edit:
     proc (b);

dcl  b bit (18);
dcl  i fixed bin;
dcl  s char (32) var;

	i = bin (substr (b, 4));
	call db_fnp_util_$edit_module_addr (corep, fnp, i, s, code);
	if code ^= 0
	then s = "";
	if s = ""
	then edited_addr = "";
	else edited_addr = "(" || s || ")";
	return;

     end edit;

/* Setup arguments */

setup:
     proc;

	corep = arg_corep;
	fnp = arg_fnp;
	cmd_infop = arg_cmd_infop;
	expr_infop = arg_expr_infop;

	envp = cmd_info.envp;
	if ^env.dump_sw				/* this is pointless without a dump */
	then do;
	     call com_err_ (0, "debug_fnp", "not looking at a dump.");
	     go to error_return;
	end;

	if constants_setup
	then return;

	crreg = db_fnp_sym_util_$get_value (".crreg");
	constants_setup = "1"b;

	return;

     end setup;

/* Procedure to fetch the fault data */

read_fault_data:
     proc;

dcl  i fixed bin;
dcl  mem_word (1) bit (18);

	call fetch (crreg, 1, addr (mem_word));		/* Get pointer to register save area */
	i = divide (length (unspec (fault_data)), 18, 17, 0);
						/* Number of words to read */
	call fetch (bin (mem_word (1)), i, addr (fault_data));
	return;

     end read_fault_data;

/* Read some FNP memory */

fetch:
     proc (a, n, p);

dcl  (a, n) fixed bin;
dcl  p ptr;

	call db_fnp_memory_$fetch (corep, fnp, a, n, p, code);
	if code = 0
	then return;
	call com_err_ (code, "", "Unable to read location ^o.", a);
	go to error_return;

     end fetch;

error_return:
	cmd_info.flush = "1"b;
	return;

%include debug_fnp_data;
     end db_fnp_dumps_;




		    db_fnp_edit_inst_.pl1           11/15/82  1816.2rew 11/15/82  1501.9       81549



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


/* Procedure to interpret fnp machine instructions */

/* Written February 1977 by Larry Johnson */
/* Modified January 1978 by Larry Johnson for assemble entry */

db_fnp_edit_inst_: proc (arg_corep, arg_fnp, arg_fnp_addr, arg_instr, arg_str);

/* Parameters */

dcl  arg_corep ptr;					/* Pointer to core image, if dump */
dcl  arg_fnp fixed bin;				/* Fnp number, for running fnp */
dcl  arg_instr bit (18);				/* Instruction to edit */
dcl  arg_str char (*) var;				/* The output string */
dcl  arg_asm_str char (*);				/* The string to assemble */
dcl  arg_expr_infop ptr;
dcl  arg_code fixed bin (35);
dcl  arg_fnp_addr fixed bin;

/* Automatic */

dcl  fnp fixed bin;
dcl  corep ptr;
dcl  str char (64) var;
dcl  instruction bit (18) aligned;
dcl  opc bit (12) aligned;
dcl (i, j) fixed bin;
dcl  offset fixed bin;
dcl  width fixed bin init (7);			/* Width to edit opcode field */
dcl  code fixed bin (35);
dcl  val fixed bin (35);
dcl  temp_str char (4);
dcl  char_addr_val bit (3);
dcl  edited_addr char (32) var;
dcl  fnp_addr_known bit (1);

dcl 1 mi aligned based (addr (instruction)),
    2 i bit (1) unal,				/* Indirect bit */
    2 x bit (2) unal,				/* Index register */
    2 c bit (6) unal,				/* The opcode (normally) */
    2 d bit (9) unal;				/* The displacement */

/* Constants */

dcl  reg_name (3) char (1) int static options (constant) init ("1", "2", "3");
dcl  char_addr (0:7) char (3) int static options (constant) init (
     "w.1", "w.2", "b.0", "b.1", "c.0", "c.1", "c.2", "idl");
dcl  reg_code (10) char (2) int static options (constant) init (
     "*", "1*", "2*", "3*", "*1", "*2", "*3", "1", "2", "3");
dcl  reg_val (10) bit (3) unal int static options (constant) init (
     "100"b, "101"b, "110"b, "111"b, "101"b, "110"b, "111"b, "001"b, "010"b, "011"b);
dcl  white_space char (2) int static options (constant) init (" 	"); /* Space and tab */

/* External stuff */

dcl  ioa_$rsnnl entry options (variable);
dcl  db_fnp_eval_ entry (ptr, fixed bin, char (*), ptr, char (*), fixed bin, fixed bin (35));
dcl  db_fnp_util_$edit_module_addr_paren entry (ptr, fixed bin, fixed bin, char (*) var, fixed bin (35));

dcl  error_table_$bad_arg ext fixed bin (35);

dcl (addr, bin, bit, copy, index, length, ltrim, reverse, rtrim, search, substr, unspec) builtin;

/* Edit an instruction */

	fnp_addr_known = "1"b;
start:	instruction = arg_instr;
	str = "";

	opc = substr (instruction, 1, 12);

	optablep = addr (db_fnp_opcodes_$);

	do i = 1 to optable.cnt;			/* Find instruction in table */
	     opp = addr (optable.entry (i));
	     if (opc & op.mask) = op.code then go to op_edit (op.type);
	end;

	arg_str = "";
	return;


/* Type 0 - storage reference instruction */

op_edit (0):
	if mi.x = "0"b then offset = fb (mi.d);		/* 9 bit displacement for ic modified instructions */
	else do;					/* Offset depends in type of character addressing */
	     i = bin (substr (mi.d, 1, 3));		/* Get char addr code */
	     if i < 2 | i > 6 then offset = fb (mi.d);	/* If invalid, use 9 bits */
	     else offset = fb (substr (mi.d, 4, 6));	/* Else use 6 bits */
	end;
	call ioa_$rsnnl ("^va ^o", str, (0), width, op.name, offset);
	if mi.x = "0"b then do;			/* IC modifier */
	     if mi.i then str = str || ",*";
	     if fnp_addr_known then do;		/* Evaluate address */
		call db_fnp_util_$edit_module_addr_paren (arg_corep, arg_fnp, arg_fnp_addr + offset, edited_addr,
		     code);
		if code = 0 then do;
		     str = str || copy (" ", 15 - length (str)); /* Increase to 15 characters */
		     str = str || edited_addr;
		end;
	     end;
	end;
	else do;					/* Index register modifier */
	     str = str || ",";
	     str = str || reg_name (bin (mi.x));
	     if mi.i then str = str || "*";
	     i = bin (substr (mi.d, 1, 3));		/* Get byte address */
	     if i >= 2 & i <= 6 then do;		/* Valid one */
		str = str || ",";
		str = str || char_addr (i);
	     end;
	end;
	go to op_done;

/* Type 1 - immediate instructions */

op_edit (1):
	call ioa_$rsnnl ("^va ^o", str, (0), width, op.name, fb (mi.d));
	go to op_done;

/* Type 2 - iacxn instruction */

op_edit (2):
	call ioa_$rsnnl ("^va ^o", str, (0), width, op.name, fb (substr (mi.d, 4, 6)));
	if substr (mi.d, 1, 3) ^= "0"b then do;
	     str = str || ",";
	     str = str || char_addr (bin (substr (mi.d, 1, 3)));
	end;
	go to op_done;

/* Type 3 - shifts */

op_edit (3):
	call ioa_$rsnnl ("^va ^o", str, (0), width, op.name, bin (substr (mi.d, 4, 6)));
	go to op_done;

/* Type 4 - no operands */

op_edit (4):
	str = rtrim (op.name);
	go to op_done;

/* All done */

op_done:
	arg_str = str;
	return;

/* Entry which returns a compressed version */

compressed: entry (arg_corep, arg_fnp, arg_instr, arg_str);

	width = 1;
	fnp_addr_known = "0"b;
	go to start;

/* Entry to "assemble" a character string into a machine instruction word */

assemble:	entry (arg_corep, arg_fnp, arg_asm_str, arg_expr_infop, arg_instr, arg_code);

	corep = arg_corep;
	fnp = arg_fnp;
	expr_infop = arg_expr_infop;
	arg_code = 0;
	arg_instr = "0"b;

	instruction = "0"b;
	str = rtrim (ltrim (arg_asm_str, white_space), white_space); /* Trim down input */
	i = search (str, white_space);		/* Look for space after opcode */
	if i = 0 then i = length (str);
	else i = i-1;
	optablep = addr (db_fnp_opcodes_$);
	do j = 1 to optable.cnt;
	     opp = addr (optable.entry (j));
	     if op.name = substr (str, 1, i) then go to op_found; /* Found opcode match */
	end;
asm_bad:	arg_code = error_table_$bad_arg;
	return;

op_found:	instruction = op.code;			/* Start instruction with opcode */
	if i >= length (str) then go to asm_complete;	/* No operands */
	str = ltrim (substr (str, i+1), white_space);
	if str = "" then go to asm_complete;
	go to asm (op.type);			/* Complete instruction based on type */

asm (0):						/* Storage reference */
	call get_char_addr;				/* Remove char addressing */
	if length (str) >= 2 then do;			/* May have index register */
	     i = index (reverse (str), ",");		/* Look for comma before index */
	     if (i = 2) | (i = 3) then do;		/* May really be there */
		temp_str = substr (str, length (str) - i + 2); /* Copy end of string */
		do j = 1 to 10;			/* Check possible codes */
		     if temp_str = reg_code (j) then do; /* Found match */
			mi.i = substr (reg_val (j), 1, 1);
			mi.x = substr (reg_val (j), 2, 2);
			str = substr (str, 1, length (str) - i); /* Trim off index */
			go to eval_disp;
		     end;
		end;
		go to asm_bad;
	     end;
	end;
eval_disp:
	call eval_str;				/* Evaluate rest of string as expression */
	if char_addr_val = "0"b then mi.d = substr (unspec (val), 28); /* 9 bit displacement */
	else do;
	     substr (mi.d, 1, 3) = char_addr_val;
	     substr (mi.d, 4, 6) = substr (unspec (val), 31); /* 6 bit displacement */
	end;
	go to asm_complete;

asm (1):						/* Immediate instructions */
	call eval_str;				/* Whole expr is amount */
	mi.d = substr (unspec (val), 28);
	go to asm_complete;

asm (2):						/* Iacxn */
	call get_char_addr;
	go to eval_disp;				/* Rest is like storage reference */

asm (3):						/* Shifts */
	call eval_str;
	substr (mi.d, 4, 6) = substr (unspec (val), 31);	/* 6 bit disp */
	go to asm_complete;

asm (4):						/* No operand instruction */
	go to asm_bad;				/* Operand is error */

asm_complete:
	arg_instr = instruction;
	arg_code = 0;
	return;

/* Fixed of bit function which respects the leading sign bit */

fb:	proc (bits) returns (fixed bin);

dcl  bits bit (*);
dcl  i fixed bin (35);

	     if substr (bits, 1, 1) = "0"b then i = 0;
	     else i = -1;
	     substr (unspec (i), 37 - length (bits)) = bits;
	     return (i);

	end fb;

/* Remove character addressing from instruction specification */

get_char_addr: proc;

dcl  i fixed bin;

	     char_addr_val = "0"b;
	     if length (str) < 4 then return;		/* Too short */
	     if substr (str, length (str) - 3, 1) ^= "," then return; /* Should be of form ,xxx */
	     temp_str = substr (str, length (str)-2);	/* Copy the xxx part */
	     do i = 2 to 6;				/* Check legal forms */
		if temp_str = char_addr (i) then do;
		     char_addr_val = bit (bin (i, 3), 3);
		     str = substr (str, 1, length (str)-4);
		     return;
		end;
	     end;
	     return;

	end get_char_addr;

/* Evaluate operand of instruction */

eval_str:	proc;

dcl  i fixed bin;

	     val = 0;
	     if str = "" then return;
	     call db_fnp_eval_ (corep, fnp, (str), expr_infop, "", i, code);
	     if code ^= 0 then go to asm_bad;
	     val = i;
	     return;

	end eval_str;

%include debug_fnp_data;

     end db_fnp_edit_inst_;




		    db_fnp_env_.pl1                 06/01/84  1547.1r w 06/01/84  1427.8      283842



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


/* DB_FNP_ENV_ - Contains entries used by debug_fnp to maintain its environment.
   The selecting of dumps, core images, and live FNP's, and the switching between them is all done here */

/* Created September 1978 by Larry Johnson, mostly from other modules, to centralize all this code */
/* Modified July 1979 by Larry Johnson to handle empty dumps better, and to add -login_channel to line command */
/* Modified August 1979 by Larry Johnson to automatically select the channel causing a dump */
/* Modified 83-12-23 BIM for new config cards */

db_fnp_env_: proc;

/* Arguments */

dcl  arg_corep ptr;					/* Address of the dump */
dcl  arg_fnp fixed bin;
dcl  arg_cmd_infop ptr;
dcl  arg_expr_infop ptr;
dcl  arg_envp ptr;

/* Automatic */

dcl  code fixed bin (35);
dcl  i fixed bin;
dcl  dir char (168);
dcl  ename char (32);
dcl  dnx fixed bin;
dcl  segp ptr;
dcl  p ptr;
dcl  fnp fixed bin;
dcl  tag char (1);
dcl  areap ptr;
dcl  tty_name char (32);
dcl  empty_dump bit (1);
dcl  continue_scan_label local label;
dcl  version char (4) aligned;
dcl (bind_time, boot_time, up_time) fixed bin (71);
dcl  time_string char (24);
dcl  mem_word (1) bit (18) unal;
dcl  print_channel_name bit (1);
dcl  ptwp ptr;

dcl (entry_cnt1, entry_cnt2) fixed bin;
dcl (namep1, namep2) ptr init (null);
dcl (entryp1, entryp2) ptr init (null);

/* Based */

dcl  system_area area based (areap);
dcl 1 entries1 (entry_cnt1) aligned based (entryp1),	/* Data from hcs_$star_ */
    2 type bit (2) unal,
    2 nnames fixed bin (15) unal,
    2 nindex fixed bin (17) unal;
dcl  names1 (1) char (32) aligned based (namep1);
dcl 1 entries2 (entry_cnt2) aligned based (entryp2),	/* Data from hcs_$star_ */
    2 type bit (2) unal,
    2 nnames fixed bin (15) unal,
    2 nindex fixed bin (17) unal;
dcl  names2 (1) char (32) aligned based (namep2);

dcl  dnp ptr;
dcl 1 dn aligned based (dnp),
    2 sort_key unal,
      3 year char (2),
      3 month char (2),
      3 day char (2),
      3 hour char (2),
      3 min char (2),
      3 fnp char (1),
    2 ename char (32),				/* Real entry name */
    2 fdump bit (1);				/* Set if this is from fdump */

dcl  dntabp ptr init (null);
dcl  dntab_size fixed bin;
dcl 1 dntab aligned based (dntabp),
    2 dne (dntab_size) like dn;


dcl  listp ptr init (null);
dcl  list_size fixed bin;
dcl 1 list aligned based (listp),			/* List of pointers for sort_items_ */
    2 cnt fixed bin,
    2 dnp (list_size refer (list.cnt)) ptr unal;

dcl  one_k_words (1024) bit (36) aligned based;		/* For looking at emptyness of dumps */

dcl 1 fdump aligned based,				/* Format of fdump segment */
    2 fnp_dump (8),
      3 memory (0:32767) bit (18) unal;

dcl 1 ptw unal based (ptwp),				/* Format of FNP page table entry */
    2 base_address fixed bin (10) uns,
    2 read_only bit (1),
    2 secure bit (1),
    2 active bit (1),
    2 count fixed bin (5) uns;

/* Constants */

dcl  name char (11) int static options (constant) init ("db_fnp_env_");
dcl  fnp_dump_starname char (32) int static options (constant) init ("fnp.?.??????.????");
dcl  fdump_starname char (32) int static options (constant) init ("??????.????.*.*.355");

/* Static */

dcl  crver fixed bin int static;
dcl  crldt fixed bin int static;
dcl  crbdt fixed bin int static;
dcl  crreg fixed bin int static;
dcl  crpte fixed bin int static;
dcl  t_line fixed bin int static;
dcl  constants_setup bit (1) int static init ("0"b);

/* External stuff */

dcl  absolute_pathname_ entry (char (*), char (*), fixed bin (35));
dcl  check_star_name_$entry entry (char (*), fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  config_$find_2 entry (character (4) aligned, character (4) aligned, pointer);
dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  db_fnp_disp_cmd_$forget entry;
dcl  db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35));
dcl  db_fnp_reader_$get_operand entry (ptr);
dcl  db_fnp_sym_util_$get_value entry (char (*)) returns (fixed bin);
dcl  db_fnp_util_$cv_chan_name entry (ptr, fixed bin, char (*), char (*), fixed bin, fixed bin (35));
dcl  db_fnp_util_$get_chan_addrs entry (ptr, fixed bin, char (*), ptr, fixed bin (35));
dcl  encode_clock_value_ entry (fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (71),
     fixed bin, char (3), fixed bin (71), fixed bin (35));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  get_system_free_area_ entry returns (ptr);
dcl  get_wdir_ entry () returns (char (168));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  match_star_name_ entry (char (*), char (*), fixed bin (35));
dcl  parse_tty_name_ entry (char (*), fixed bin, bit (1), fixed bin, fixed bin);
dcl  sort_items_$char entry (ptr, fixed bin (24));
dcl  user_info_$terminal_data entry (char (*), char (*), char (*), fixed bin, char (*));
dcl  parse_fnp_name_ entry (char (*), fixed bin);
dcl  get_fnp_name_ entry (fixed bin) returns (char (32));


dcl  error_table_$bad_arg ext fixed bin (35);
dcl  error_table_$nomatch ext fixed bin (35);

dcl (cleanup, conversion) condition;

dcl (addr, addrel, bin, clock, divide, hbound, length, max, null, string, substr, unspec) builtin;

/* Entry to setup the default environment, FNP a, when the command begins. */

init:	entry (arg_envp);

	envp = arg_envp;

	env.corep = null ();
	env.dump_dir = ">dumps";
	env.dir, env.ename = "";
	env.segp = null ();
	string (env.flags) = "0"b;
	env.tty_name = "";
	env.fnp = -1;
	env.dump_time = 0;
	call setup_constants;

	call db_fnp_disp_cmd_$forget;

	call find_configured_fnps;			/* Check config deck for FNP's */
	call find_first_configured_fnp ("1"b);
	if fnp > 0 then do;
	     env.fnp = fnp;
	     env.fnp_sw = "1"b;
	end;

	return;

/* Entry used by cleanup handler by main command */

term:	entry (arg_envp);

	envp = arg_envp;

	if env.segp ^= null () then do;
	     call hcs_$terminate_noname (env.segp, (0));
	     env.segp = null ();
	end;
	return;

/* Command to select a specific FNP */

fnp_cmd:	entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;

	call get_opt_tag;
	if tag = "" then do;			/* Use first configured fnp */
	     call find_first_configured_fnp ("0"b);
	     if fnp < 0 then go to error_return;
	end;

	if ^substr (env.fnps_configured, fnp, 1) then do;
	     call ioa_ ("FNP ^a is not configured.", tag);
	     go to error_return;
	end;

	call forget;
	env.fnp = fnp;
	env.fnp_sw = "1"b;
	return;

/* Command to select a core image */

image_cmd: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;

	on cleanup call clean_up;
	call get_seg;

	call forget;
	env.fnp = -1;
	env.segp = segp;
	env.dir = dir;
	env.ename = ename;
	env.corep = addrel (segp, 1);			/* Core image has length word */
	env.image_sw = "1"b;
	return;


/* Command to select a specific dump by name */

dump_cmd:	entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;

	on cleanup call clean_up;
	call get_seg;				/* Check arg */

	call forget;
	env.fnp = -1;				/* Don't know FNP */
	env.segp = segp;
	env.dir = dir;
	env.ename = ename;
	env.corep = segp;
	env.dump_sw = "1"b;

/* Check format of the dump name. If it one we recognize, we can infer
   which FNP the dump is for, or select a valid dump from an FDUMP */

	call match_star_name_ (env.ename, fnp_dump_starname, code);
	if code = 0 then do;			/* Standard FNP dump */
	     call parse_fnp_name_ (substr (env.ename, 5, 1), fnp);
	     if fnp < 0 then fnp = 0;
	     if fnp ^= 0 then env.fnp = fnp;		/* Got good fnp */
	     if unspec (env.segp -> one_k_words) = "0"b then
		call ioa_ ("^a^[>^]^a appears empty.", env.dir, (env.dir ^= ">"), env.ename);
	     call setup_crashed_line;
	     call ioa_ ("^[Using line ^a^;^sNo TIB available^]", (env.tty_name ^= ""), env.tty_name);
	     return;
	end;

	call match_star_name_ (env.ename, fdump_starname, code); /* Check for standard fdump format */
	if code = 0 then do;
	     do fnp = 1 to hbound (env.segp -> fdump.fnp_dump, 1); /* Look for non-empty section */
		p = addr (env.segp -> fdump.fnp_dump (fnp));
		if unspec (p -> one_k_words) ^= "0"b then do; /* Found good data */
use_some_dump:	     env.fdump_sw = "1"b;
		     env.corep = p;
		     env.fnp = fnp;
		     call setup_crashed_line;
		     call ioa_ ("^[Using line ^a^;^sNo TIB available.^]", (env.tty_name ^= ""), env.tty_name);
		     return;
		end;
	     end;
	     call ioa_ ("^a^[>^]^a appears empty.", env.dir, (env.dir ^= ">"), env.ename);
	     fnp = 1;				/* Use first fnp */
	     p = addr (env.segp -> fdump.fnp_dump (fnp));
	     go to use_some_dump;
	end;

	call ioa_ ("^a is non-standard dump name. FNP not known.", env.ename);
	return;

/* Entry to set or print the default dump directory */

dump_dir:	entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;

	call get_operand;
	if cmd_info.endline then do;
	     call ioa_ ("Dump directory is ^a", env.dump_dir);
	     return;
	end;

	if operand = "-wd" | operand = "-working_dir" then dir = get_wdir_ ();
	else do;
	     call absolute_pathname_ (operand, dir, code);
	     if code ^= 0 then do;
		call com_err_ (code, "", "^a", operand);
		go to error_return;
	     end;
	end;

	env.dump_dir = dir;
	return;

/* Entry to print a list of available dumps */

dumps:	entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;

	on cleanup call clean_up;

	call list_dumps;
	do i = list_size to 1 by -1;
	     dnp = list.dnp (i);
	     call ioa_ ("^a", dn.ename);
	end;

	call clean_up;

	return;

/* Entry to find the most recent dump */

last_dump: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;
	continue_scan_label = prev_dump_continue;

	on cleanup call clean_up;
	call get_opt_tag;

	call list_dumps;

	do i = list_size to 1 by -1;
	     dnp = list.dnp (i);
	     if tag = "" then go to return_dump_info;	/* Any fnp ok */
	     if dn.fdump then go to return_dump_info;	/* Has all fnp's */
	     if dn.fnp = tag then go to return_dump_info;
	end;
	call ioa_ ("No dumps for FNP ^a", tag);
	go to error_return;

return_dump_info:
	call forget;
	empty_dump = "0"b;
	ename = dn.ename;
	call hcs_$initiate (env.dump_dir, ename, "", 0, 0, segp, code);
	if segp = null then do;			/* Can't access dump */
	     call com_err_ (code, name, "^a^[>^]^a", env.dump_dir, (env.dump_dir ^= ">"), ename);
	     if list_size = 1 then go to error_return;
	     env.ename = ename;
	     go to continue_scan_label;
	end;

	if ^dn.fdump then do;			/* Simple dump is easy */
	     if unspec (segp -> one_k_words) = "0"b then do;
		call ioa_ ("^a^[>^]^a appears empty.", env.dump_dir, (env.dump_dir ^= ">"), ename);
		empty_dump = "1"b;
	     end;
	     env.dir = env.dump_dir;
	     env.ename = ename;
	     env.segp = segp;
	     env.corep = segp;
	     env.dump_sw = "1"b;
	     call parse_fnp_name_ (dn.fnp, env.fnp);
	     call set_dump_time;
	     call setup_crashed_line;
	     if empty_dump then if list_size > 1 then go to continue_scan_label;
	     call ioa_ ("Using ^a, ^[line ^a^;^sNo TIB available.^]", env.ename, (env.tty_name ^= ""), env.tty_name);
	     call clean_up;
	     return;
	end;

	if tag ^= "" then do;			/* See if request fnp in this dump */
	     call parse_fnp_name_ (tag, i);
	     p = addr (segp -> fdump.fnp_dump (i));
	     if unspec (p -> one_k_words) = "0"b then do;
		call ioa_ ("No data for FNP ^a in ^a", tag, ename);
		empty_dump = "1"b;
	     end;
	     go to use_fdump;
	end;

	do i = 1 to hbound (segp -> fdump.fnp_dump, 1);	/* Look at pieces of fdumps */
	     p = addr (segp -> fdump.fnp_dump (i));
	     if unspec (p -> one_k_words) ^= "0"b then	/* Found good component */
		go to use_fdump;
	end;

	i = 1;
	p = addr (segp -> fdump.fnp_dump (1));
	call ioa_ ("^a^[>^]^a appears empty.", env.dump_dir, (env.dump_dir ^= ">"), ename);
	empty_dump = "1"b;

use_fdump:
	env.ename = ename;
	env.dir = env.dump_dir;
	env.segp = segp;
	env.corep = p;
	env.fnp = i;
	env.dump_sw, env.fdump_sw = "1"b;
	call set_dump_time;
	call setup_crashed_line;
	if empty_dump then if list_size > 1 then go to continue_scan_label;
	call ioa_ ("Using ^a (fnp ^a), ^[line ^a^;^sNo TIB available.^]", env.ename, get_fnp_name_ (env.fnp), (env.tty_name ^= ""), env.tty_name);
	call clean_up;
	return;

/* Find the next earliest dump */

prev_dump: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;

	if ^env.dump_sw then do;
	     call ioa_ ("Not currently using a dump.");
	     go to error_return;
	end;

	continue_scan_label = prev_dump_continue;
	on cleanup call clean_up;
	call get_opt_tag;

	call list_dumps;
prev_dump_continue:
	call find_current;
	do i = dnx - 1 to 1 by -1;
	     dnp = list.dnp (i);
	     if tag = "" then go to return_dump_info;
	     if dn.fdump then go to return_dump_info;
	     if dn.fnp = tag then go to return_dump_info;
	end;

	if tag ^= "" then call ioa_ ("No more dumps for FNP ^a", tag);
	else call ioa_ ("^a is the oldest dump.", env.ename);
	go to error_return;

/* Get the next lastest dump */

next_dump: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;

	if ^env.dump_sw then do;
	     call ioa_ ("Not currently using a dump.");
	     go to error_return;
	end;

	continue_scan_label = next_dump_continue;

	on cleanup call clean_up;
	call get_opt_tag;

	call list_dumps;
next_dump_continue:
	call find_current;
	do i = dnx + 1 to list_size;
	     dnp = list.dnp (i);
	     if tag = "" then go to return_dump_info;
	     if dn.fdump then go to return_dump_info;
	     if tag = dn.fnp then go to return_dump_info;
	end;

	if tag ^= "" then call ioa_ ("No more dumps for FNP ^a", tag);
	else call ioa_ ("^a is the most recent dump", env.ename);
	go to error_return;

/* Select a differnt fnp from a multi-fnp segment */

select_fdump_fnp: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;

	if ^env.dump_sw then do;
	     call ioa_ ("Only valid on dumps.");
	     go to error_return;
	end;

	call get_tag;
	p = addr (env.segp -> fdump.fnp_dump (fnp));
	if unspec (p -> one_k_words) = "0"b then	/* No data */
	     call ioa_ ("No data for FNP ^a in ^a", tag, env.ename);

	if fnp ^= env.fnp then do;			/* Something changing */
	     call forget_fnp;
	     env.fnp = fnp;
	     env.corep = p;
	end;
	call setup_crashed_line;
	if env.tty_name ^= "" then call ioa_ ("^[Using line ^a^;^sNo TIB available.^]", env.tty_name);
	return;

/* Procedure to print name of current dump, image, fnp, etc */

what:	entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;

	if ^(env.fnp_sw | env.dump_sw | env.image_sw) then do;
	     call ioa_ ("Nothing");
	     return;
	end;

	call get_version;

	if env.fnp_sw then call ioa_ ("FNP ^a, version ^a", get_fnp_name_ (env.fnp), version);
	else if image_sw then call ioa_ ("Core image in ^a^[>^]^a, version ^a", env.dir, (env.dir ^= ">"), env.ename,
	     version);
	else if env.dump_sw then if ^env.fdump_sw then
		call ioa_ ("Dump in ^a^[>^]^a, version ^a", env.dir, (env.dir ^= ">"), env.ename, version);
	     else call ioa_ ("Fdump in ^a^[>^]^a (fnp ^a), version ^a", env.dir, (env.dir ^= ">"), env.ename,
		get_fnp_name_ (env.fnp), version);

	return;

/* Entry to implement the when command which prints interesting stuff about times */

when:	entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;
	call get_version;
	call fetch (crldt, 4, addr (bind_time), "0"b);
	if code ^= 0 then go to error_return;
	call fetch (crbdt, 4, addr (boot_time), "0"b);
	if code ^= 0 then go to error_return;
	call date_time_ (bind_time, time_string);
	call ioa_ ("MCS version ^a, bound on ^a", version, time_string);
	if boot_time ^= 0 then do;
	     call date_time_ (boot_time, time_string);
	     call ioa_ ("Booted on ^a", time_string);
	end;
	if env.fnp_sw then do;
	     up_time = max (0, clock () - boot_time);
	     call ioa_ ("FNP has been up for ^a", edit_interval (up_time));
	end;
	if env.dump_sw & env.dump_time ^= 0 then do;
	     up_time = max (0, env.dump_time - boot_time);
	     call ioa_ ("FNP up for ^a before crash", edit_interval (up_time));
	end;
	return;

/* Entry to select a specific fnp channel. It will switch FNP's to get the requested line if necessary */

line:	entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;

	if ^(fnp_sw | dump_sw) then do;
	     call ioa_ ("Only valid on running FNP, or a dump.");
	     go to error_return;
	end;

	call get_operand;
	if cmd_info.endline then do;			/* No operands, print current line */
	     if env.tty_name = "" then call ioa_ ("No line selected.");
	     else call ioa_ ("Line ^a. ^[TIB at ^o^]", env.tty_name, expr_info.tib_known, expr_info.tib_addr);
	     return;
	end;

	tty_name = operand;
	print_channel_name = "0"b;
	if operand = "-login" | operand = "-login_channel" then do;
	     call user_info_$terminal_data ((""), (""), tty_name, (0), (""));
	     print_channel_name = "1"b;
	end;
	else if operand = "-crash" then do;
	     if ^env.dump_sw then do;
		call ioa_ ("Not current using a dump.");
		go to error_return;
	     end;
	     call find_crashed_line ("0"b);
	     if tty_name = "" then go to error_return;
	     print_channel_name = "1"b;
	end;

	i = cv_oct_check_ (tty_name, code);		/* An octal line number is always for this FNP */
	if code = 0 then fnp = max (1, env.fnp);	/* If we know the FNP, that is */
	else call parse_tty_name_ (tty_name, fnp, ("0"b), (0), (0)); /* Check name, ignoring all but fnp result */
	if fnp < 0 then do;				/* Bad format name */
	     call ioa_ ("Illegal tty name: ^a", tty_name);
	     go to error_return;
	end;

	if (env.fnp > 0) & (env.fnp ^= fnp) then do;	/* If current FNP known, do some checking */
	     if env.fnp_sw then do;			/* Running live fnp's */
		if ^substr (env.fnps_configured, fnp, 1) then do;
		     call ioa_ ("^a is on FNP ^a which is not configured.", tty_name, get_fnp_name_ (fnp));
		     go to error_return;
		end;
		call ioa_ ("Switching to FNP ^a", get_fnp_name_ (fnp));
		call forget_fnp;
		env.fnp = fnp;
	     end;
	     else if env.fdump_sw then do;		/* Running fdump */
		p = addr (env.segp -> fdump.fnp_dump (fnp)); /* Find piece for new fnp */
		if unspec (p -> one_k_words) = "0"b then do;
		     call ioa_ ("^a is on FNP ^a; no data in ^a for FNP ^a",
			tty_name, get_fnp_name_ (fnp), env.ename, get_fnp_name_ (fnp));
		     go to error_return;
		end;
		call ioa_ ("Switching to FNP ^a", get_fnp_name_ (fnp));
		call forget_fnp;
		env.corep = p;
		env.fnp = fnp;
	     end;
	     else do;
		call ioa_ ("^a is on FNP ^a, dump is for FNP ^a", tty_name, get_fnp_name_ (fnp), get_fnp_name_ (env.fnp));
		go to error_return;
	     end;
	end;

	call setup_line_data ("0"b);
	if env.tty_name = "" then go to error_return;
	if print_channel_name then call ioa_ ("Using ^a", env.tty_name);
	return;

/* Procedure to check an argument for a valid FNP tag */

get_tag:	proc;

	     call get_operand_req ("Tag");
tag_join:
	     call parse_fnp_name_ (operand, fnp);
	     if fnp < 0 then do;
		call ioa_ ("Invalid FNP tag: ^a", operand);
		go to error_return;
	     end;
	     tag = operand;
	     return;

get_opt_tag:   entry;

	     call get_operand;
	     if cmd_info.endline then do;
		tag = "";
		return;
	     end;
	     go to tag_join;

	end get_tag;

/* Procedure to check an argument for a pathname */

get_seg:	proc;

	     call get_operand_req ("Pathname");

	     call expand_pathname_ (operand, dir, ename, code);
	     if code ^= 0 then do;
		call com_err_ (code, "", "^a", operand);
		go to error_return;
	     end;

	     call check_star_name_$entry (ename, code);
	     if code = 1 | code = 2 then do;		/* Allow starnames as shorthand */
		areap = get_system_free_area_ ();
		call hcs_$star_ (dir, ename, 3, areap, entry_cnt1, entryp1, namep1, code);
		if code ^= 0 then do;
		     call com_err_ (code, "", "^a^[>^]^a", dir, (dir ^= ">"), ename);
		     go to error_return;
		end;
		if entry_cnt1 > 1 then do;
		     call ioa_ ("^a matches multiple entries in ^a", ename, dir);
		     go to error_return;
		end;
		ename = names1 (entries1.nindex (1));	/* Use first name */
		free entries1;
		free names1;
		entryp1, namep1 = null ();
	     end;

	     call hcs_$initiate (dir, ename, "", 0, 0, segp, code);
	     if segp = null then do;
		call com_err_ (code, "", "^a^[>^]^a", dir, (dir ^= ">"), ename);
		go to error_return;
	     end;
	     return;

	end get_seg;

/* Be sure a required operand is present */

get_operand_req: proc (s);

dcl  s char (*);

	     call get_operand;
	     if ^cmd_info.endline then return;
	     call ioa_ ("^a missing.", s);
	     go to error_return;

	end get_operand_req;

get_operand: proc;

	     call db_fnp_reader_$get_operand (cmd_infop);
	     if cmd_info.error then go to error_return;

	     return;

	end get_operand;

/* Procedure for "forgetting" the current fnp, dump, etc., in preperation for a new one */

forget:	proc;

	     call forget_fnp;
	     env.dump_sw = "0"b;
	     env.fnp_sw = "0"b;
	     env.image_sw = "0"b;
	     env.fdump_sw = "0"b;
	     env.dump_time = 0;
	     if env.segp ^= null () then do;
		call hcs_$terminate_noname (env.segp, code);
		env.segp = null ();
	     end;

	     env.corep = null ();
	     env.fnp = -1;
	     return;

	end forget;

/* Forget data associated with the current FNP. This is used with last drastic environment changes, like when
   changing to a new fnp in an fdump */

forget_fnp: proc;

	     string (expr_info.flags) = "0"b;
	     env.tty_name = "";
	     call db_fnp_disp_cmd_$forget;		/* Forget next buffer address */
	     return;

	end forget_fnp;

/* Procedure to find the current dump in the dump list */

find_current: proc;

	     do dnx = 1 to list_size;
		dnp = list.dnp (dnx);
		if dn.ename = env.ename then return;
	     end;
	     call ioa_ ("Unable to find current dump: ^a", env.ename);
	     go to error_return;

	end find_current;

/* Procedure to convert a dump time back into a clock value */

set_dump_time: proc;

	     on conversion go to return_no_time;
	     call encode_clock_value_ (bin (dn.month), bin (dn.day), 1900 + bin (dn.year), bin (dn.hour),
		bin (dn.min), 0, 0, 0, "   ", env.dump_time, code);
	     if code ^= 0 then env.dump_time = 0;
	     return;
return_no_time:
	     env.dump_time = 0;
	     return;

	end set_dump_time;

/* Get the current version */

get_version: proc;

dcl  i fixed bin;
dcl  test_char bit (9);

	     call fetch (crver, 2, addr (version), "0"b);
	     if code ^= 0 then version = "?";
	     do i = 1 to length (version);
		test_char = unspec (substr (version, i, 1));
		if test_char < "040"b3 | test_char > "176"b3 then version = "?";
	     end;
	     return;

	end get_version;

/* Procedure to edit a time interval */

edit_interval: proc (arg_interval) returns (char (64) var);

dcl  arg_interval fixed bin (71);

dcl  interval fixed bin (71);
dcl (hours, minutes) fixed bin;
dcl  work_string char (64) var;

	     interval = arg_interval + 30000000;
	     hours = divide (interval, 3600000000, 17, 0);
	     interval = interval - 3600000000 * hours;
	     minutes = divide (interval, 60000000, 17, 0);
	     call ioa_$rsnnl ("^[^d hour^[s^]^;^2s^]^[^[, ^]^d min^[s^]^;^3s^]^[seconds^]", work_string, (0),
		(hours ^= 0), hours, (hours ^= 1),
		(minutes ^= 0), (hours ^= 0), minutes, (minutes ^= 1),
		((hours = 0) & (minutes = 0)));
	     return (work_string);

	end edit_interval;

/* Procedure to get a list of dumps */

list_dumps: proc;

dcl  i fixed bin;

	     areap = get_system_free_area_ ();
	     call hcs_$star_ (env.dump_dir, fnp_dump_starname, 3, areap, entry_cnt1, entryp1, namep1, code);
						/* List normal fnp dumps */
	     if (code ^= 0) & (code ^= error_table_$nomatch) then go to list_dumps_error;
	     call hcs_$star_ (env.dump_dir, fdump_starname, 3, areap, entry_cnt2, entryp2, namep2, code);
						/* List fdumps */
	     if (code ^= 0) & (code ^= error_table_$nomatch) then go to list_dumps_error;

	     if (entry_cnt1 + entry_cnt2) = 0 then do;	/* None of either kind */
		call ioa_ ("No dumps in ^a", env.dump_dir);
		go to error_return;
	     end;

	     dntab_size = entry_cnt1 + entry_cnt2;	/* Number of dumps is regular count + fdumps */
	     allocate dntab in (system_area);
	     dnx = 0;
	     do i = 1 to entry_cnt1;			/* Make entries for regular dumps */
		dnx = dnx+1;
		dnp = addr (dntab.dne (dnx));
		dn.ename = names1 (entries1.nindex (i));
		dn.year = substr (dn.ename, 11, 2);
		dn.month = substr (dn.ename, 7, 2);
		dn.day = substr (dn.ename, 9, 2);
		dn.hour = substr (dn.ename, 14, 2);
		dn.min = substr (dn.ename, 16, 2);
		dn.fnp = substr (dn.ename, 5, 1);
		dn.fdump = "0"b;
	     end;

	     do i = 1 to entry_cnt2;			/* Scan each fdump */
		dnx = dnx+1;
		dnp = addr (dntab.dne (dnx));
		dn.ename = names2 (entries2.nindex (i));
		dn.year = substr (dn.ename, 5, 2);
		dn.month = substr (dn.ename, 1, 2);
		dn.day = substr (dn.ename, 3, 2);
		dn.hour = substr (dn.ename, 8, 2);
		dn.min = substr (dn.ename, 10, 2);
		dn.fnp = "";
		dn.fdump = "1"b;
	     end;

	     list_size = dnx;			/* Total dumps */
	     allocate list in (system_area);
	     do i = 1 to list_size;
		list.dnp (i) = addr (dntab.dne (i));
	     end;
	     call sort_items_$char (listp, length (string (dn.sort_key)));
	     return;

list_dumps_error:
	     call com_err_ (code, name, "^a", env.dump_dir);
	     go to error_return;

	end list_dumps;

error_return:
	cmd_info.flush = "1"b;
	call clean_up;
	return;

/* Pick up initial arguments */

setup:	proc;

	     cmd_infop = arg_cmd_infop;
	     expr_infop = arg_expr_infop;
	     envp = cmd_info.envp;
	     return;

	end setup;

setup_constants: proc;

	     if constants_setup then return;
	     crver = db_fnp_sym_util_$get_value (".crver");
	     crldt = db_fnp_sym_util_$get_value (".crldt");
	     crbdt = db_fnp_sym_util_$get_value (".crbdt");
	     crreg = db_fnp_sym_util_$get_value (".crreg");
	     crpte = db_fnp_sym_util_$get_value (".crpte");
	     t_line = db_fnp_sym_util_$get_value ("t.line");
	     constants_setup = "1"b;
	     return;

	end setup_constants;

/* Procedure to scan the config deck for fnp cards */

find_configured_fnps: proc;

%include config_prph_fnp_card;
declare fnpx fixed bin;

	     env.fnps_configured = "0"b;

	     do fnpx = 1 to 8;
		prph_fnp_cardp = null ();
		call config_$find_2 ("prph", "fnp" || get_fnp_name_ (fnpx), prph_fnp_cardp);
		if prph_fnp_cardp ^= null ()
		then substr (env.fnps_configured, fnpx, 1) = "1"b;
	     end;
	     return;

	end find_configured_fnps;

/* Procedure to select the first configured FNP */

find_first_configured_fnp: proc (quiet_sw);

dcl  quiet_sw bit (1);

dcl (i, j) fixed bin;

	     fnp = -1;
	     j = 0;
	     do i = 1 to length (env.fnps_configured);
		if substr (env.fnps_configured, i, 1) then do;
		     if fnp = -1 then fnp = i;
		     j = j + 1;
		end;
	     end;
	     if j = 0 then do;
		call ioa_ ("No FNP's configured.");
		return;
	     end;
	     tag = get_fnp_name_ (fnp);
	     if j > 1 then if ^quiet_sw | (fnp ^= 1) then
		     call ioa_ ("Using FNP ^a", tag);
	     return;

	end find_first_configured_fnp;

/* Called for a dump to find the line casuing the crash */

setup_crashed_line: proc;

	     call find_crashed_line ("1"b);
	     if tty_name ^= "" then call setup_line_data ("1"b);
	     return;

	end setup_crashed_line;

find_crashed_line: proc (quiet_sw);

dcl  quiet_sw bit (1);
dcl (i, base) fixed bin;

	     tty_name = "";
	     call fetch (crreg, 1, addr (mem_word), quiet_sw); /* Get address of saved registers */
	     if code ^= 0 then return;
	     i = bin (mem_word (1));
	     call fetch (i, 1, addr (mem_word), "1"b);	/* Read contents of ic */
	     if code ^= 0 then do;
		if ^quiet_sw then call ioa_ ("Address of saved registers invalid (.crreg = ^o)", i);
		return;
	     end;
	     if mem_word (1) = "0"b then do;
		if ^quiet_sw then call ioa_ ("No fault occured.");
		return;
	     end;
	     call fetch (i + 4, 1, addr (mem_word), quiet_sw); /* Read value of x1 */
	     if code ^= 0 then return;
	     if mem_word (1) & "700001"b3 then do;	/* Known bad bits for a tib address */
bad_x1:		if ^quiet_sw then call ioa_ ("x1 does not point at a tib");
		return;
	     end;
	     i = bin (mem_word (1));
	     call fetch (crpte, 1, addr (mem_word), quiet_sw); /* See if paging being used */
	     if code ^= 0 then return;
	     if mem_word (1) ^= "0"b then do;		/* There is page table */
		call fetch (bin (mem_word (1)), 1, addr (mem_word), quiet_sw); /* Get it */
		if code ^= 0 then return;
		ptwp = addr (mem_word (1));
		if ptw.active then do;
		     base = 32768 - 256 * (ptw.count + 1); /* Start of window */
		     if i >= base then		/* X1 points into window */
			i = (i - base) + 256 * ptw.base_address;
		end;
	     end;
	     call fetch (i + t_line, 1, addr (mem_word), quiet_sw);
	     if code ^= 0 then go to bad_x1;
	     if (mem_word (1) = "0"b) | (mem_word (1) & "776000"b3) then go to bad_x1;
	     call ioa_$rsnnl ("^o", tty_name, (0), bin (mem_word (1)));
	     return;

	end find_crashed_line;

setup_line_data: proc (quiet_sw);

dcl  quiet_sw bit (1);

	     env.tty_name = "";			/* Forget current name */
	     string (expr_info.flags) = "0"b;
	     call db_fnp_util_$get_chan_addrs (env.corep, env.fnp, tty_name, expr_infop, code);
	     if code = error_table_$bad_arg then do;
		if ^quiet_sw then call ioa_ ("^a not configured.", tty_name);
		return;
	     end;
	     else if code ^= 0 then do;
		if ^quiet_sw then call com_err_ (code, "", "Getting data on ^a", tty_name);
		return;
	     end;

	     call db_fnp_util_$cv_chan_name (env.corep, env.fnp, tty_name, ename, (0), code); /* Get canonical tty name */
	     if code = 0 then env.tty_name = ename;
	     else env.tty_name = tty_name;
	     return;

	end setup_line_data;

fetch:	proc (a, l, p, q);

dcl  a fixed bin;					/* Address to read */
dcl  l fixed bin;					/* Length to read */
dcl  p ptr;					/* Where to put it */
dcl  q bit (1);					/* Quiet switch */

	     call db_fnp_memory_$fetch (env.corep, env.fnp, a, l, p, code);
	     if code ^= 0 then
		if ^q then
		     if l = 1 then call com_err_ (code, name, "Unable to read fnp location ^o.", a);
		     else call com_err_ (code, name, "Unable to read fnp locations ^o thru ^o", a, a + l - 1);

	     return;

	end fetch;

/* Cleanup handler */

clean_up:	proc;

	     if listp ^= null then free list;
	     if dntabp ^= null then free dntab;
	     if namep1 ^= null then free names1;
	     if namep2 ^= null then free names2;
	     if entryp1 ^= null then free entries1;
	     if entryp2 ^= null then free entries2;
	     return;

	end clean_up;




%include debug_fnp_data;

     end db_fnp_env_;




		    db_fnp_eval_.pl1                11/15/82  1816.2rew 11/15/82  1502.0      197910



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


/* DB_FNP_EVAL_ - Procedure to evaluate expressions intended to be fnp addresses */

/* Written February 1977 by Larry Johnson */
/* Modified January 1977 by Larry Johnson to accept 'string' as machine instruction format */
/* Modified January 1981 by Robert Coren to evaluate symbols in channel metering areas */

db_fnp_eval_: proc (arg_corep, arg_fnp, arg_expr, arg_expr_infop, arg_caller, arg_result, arg_code);

/* Parameters */

dcl  arg_corep ptr;					/* Pointer to segment containg core image */
dcl  arg_fnp fixed bin;				/* Number of running fnp */
dcl  arg_expr char (*);				/* The expression to evaluate */
dcl  arg_expr_infop ptr;				/* Optional pointer to supplementary information */
dcl  arg_caller char (*);				/* Caller name to go in error messages */
dcl  arg_result fixed bin;				/* The answer */
dcl  arg_code fixed bin (35);

/* Automatic */

dcl  corep ptr;
dcl  fnp fixed bin;
dcl  result fixed bin;
dcl  code fixed bin (35);
dcl  ntoken fixed bin;				/* Number of tokens */
dcl  exprp ptr;					/* Pointer to unparsed part of expression */
dcl  exprl fixed bin;				/* Length of unparsed part */
dcl  expr char (exprl) based (exprp);			/* The unparsed part of expression */
dcl  tstart fixed bin;				/* Starting token in sub-expression */
dcl  tend fixed bin;				/* Last token in sub-expression */
dcl  tcur fixed bin;				/* Current token */
dcl  n_ind fixed bin;				/* Count of indirects in expression */
dcl  n_mult fixed bin;				/* Count of multiplies and divides */
dcl  n_add fixed bin;				/* Count of adds and subtracts */

dcl 1 auto_expr_info like expr_info;
dcl 1 token_list aligned,
    2 entry (255) unal,
      3 token like token;


/* Definition of a token */

dcl  tokenp ptr;

dcl 1 token unaligned based (tokenp),
    2 prev fixed bin (8),				/* Backwards pointer */
    2 next fixed bin (8),				/* Forwards pointer */
    2 type fixed bin (8),				/* Kind of token */
    2 sub fixed bin (8),				/* Sub-type, for some tokens */
    2 val fixed bin (35);

/* Values for token.type */

dcl (start_token init (0),				/* Start of expression */
     leftp_token init (1),				/* Left parenthesis */
     rightp_token init (2),				/* Right parenthesis */
     mult_token init (3),				/* Multiply (sub=1), or divide (sub=2) */
     add_token init (4),				/* Add (sub=1), or subtract (sub=2) */
     ind_token init (5),				/* Indirect thru fnp word */
     sym_token init (6),				/* Symbol or constant */
     end_token init (7))				/* End of expression */
     fixed bin int static options (constant);

/* External stuff */

dcl  ioa_ entry options (variable);
dcl  ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1) aligned, bit (1) aligned);
dcl  com_err_ entry options (variable);
dcl  db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35));
dcl  cu_$arg_list_ptr entry (ptr);
dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  db_fnp_sym_util_$lookup entry (char (*), ptr);
dcl  db_fnp_sym_util_$lookup_user entry (ptr, char (*), ptr);
dcl  db_fnp_opblock_util_$lookup entry (char (*), bit (18), fixed bin (35));
dcl  db_fnp_util_$lookup_module entry (ptr, fixed bin, char (*), fixed bin, fixed bin (35));
dcl  db_fnp_edit_inst_$assemble entry (ptr, fixed bin, char (*), ptr, bit (18), fixed bin (35));

dcl  error_table_$bad_arg ext fixed bin (35);

dcl (addr, divide, hbound, index, length, null, search, string, substr, unspec, verify) builtin;

/* Initialization */

	corep = arg_corep;
	fnp = arg_fnp;
	exprp = addr (arg_expr);
	exprl = length (arg_expr);
	expr_infop = arg_expr_infop;
	if expr_infop = null then do;			/* If no structure, setup dummy */
	     expr_infop = addr (auto_expr_info);
	     string (expr_info.flags) = "0"b;
	     expr_info.user_tablep = null;
	end;
	expr_info.type = type_oct;
	expr_info.len = 1;


/* Now evaluate the expression */

	code = 0;

	if substr (expr, 1, 1) = "'" then do;		/* Special machine instruction format */
	     call eval_inst;
	     go to eval_return;
	end;

	call parse_expr;

	call eval_expr;

eval_return:
	arg_result = result;
	arg_code = 0;
	return;

error_return:					/* If error */
	arg_result = 0;
	arg_code = code;
	return;

/* Procedure to parse the expression */

parse_expr: proc;

dcl  nparen fixed bin;				/* For paren level counting */
dcl  i fixed bin;

	     ntoken = 0;
	     call new_token (start_token);		/* First, start of expr token */

	     nparen = 0;



	     do while (exprl > 0);			/* Loop until end */

		i = index ("()*/+|-,", substr (expr, 1, 1)); /* Check for special character */
		if i = 0 then do;			/* Must be symbol */
		     if sym_or_rightp_or_ind () then go to bad_char;
		     call parse_sym;
		     go to next_token;
		end;
		else go to parse_op (i);		/* Branch, depending on character */

parse_op (1):					/* Left paren */
		if sym_or_rightp_or_ind () then go to bad_char;
		call new_token (leftp_token);
		nparen = nparen + 1;
		call adv (1);
		go to next_token;

parse_op (2):					/* Right paren */
		if token.type = start_token | mult_or_add () then go to bad_char;
		if nparen ^> 0 then do;
		     if exprl = length (arg_expr) then go to bad_char;
		     else call err ("Too many "")"".");
		end;
		call new_token (rightp_token);
		nparen = nparen - 1;
		call adv (1);
		go to next_token;

parse_op (3):					/* "*" - may be multiply or reference to loc counter */
		if sym_or_rightp_or_ind () then do;	/* Multiply */
		     call new_token (mult_token);
		     token.sub = 1;
		end;
		else do;				/* Reference to location counter */
		     if ^expr_info.star_known then call err ("Value of ""*"" is not known.");;
		     call new_token (sym_token);
		     token.val = expr_info.star_addr;
		end;
		call adv (1);
		go to next_token;

parse_op (4):					/* Divide */
		if start_or_leftp () | mult_or_add () then go to bad_char;
		call new_token (mult_token);
		token.sub = 2;
		call adv (1);
		go to next_token;

parse_op (5):					/* Add */
parse_op (6):					/* Add, alternate form ("|") */
parse_op (7):					/* Subtract */
		if start_or_leftp () then call new_token (sym_token); /* Unary, treat as 0+ or 0- */
		else if mult_or_add () then go to bad_char;
		call new_token (add_token);
		if substr (expr, 1, 1) = "-" then token.sub = 2;
		else token.sub = 1;
		call adv (1);
		go to next_token;

parse_op (8):					/* Comma, must be start of ",*" */
		if (exprl < 2) | ((exprl >= 2) & substr (expr, 2, 1) ^= "*") then
		     call err ("Missing ""*"" after "","".");
		if start_or_leftp () | mult_or_add () then go to bad_char;
		call new_token (ind_token);
		call adv (2);
		go to next_token;

next_token:
	     end;

	     if nparen ^= 0 then call err ("Parens do not balance."); /* Must balance in end */

	     if mult_or_add () then call err ("Expression ends badly.");

	     call new_token (end_token);
	     return;

	end parse_expr;

/* Procedure to parse a constant or a symbol name */

parse_sym: proc;

dcl  val fixed bin (35);
dcl  bval bit (36) aligned based (addr (val));
dcl (i, j) fixed bin;
dcl  dec_sw bit (1) init ("0"b);
dcl  opval bit (18);
dcl  tib_meter fixed bin;
dcl  tib_page_base fixed bin;
dcl  meter_orig fixed bin (18) unsigned unaligned;

	     i = verify (expr, "0123456789");		/* Try constant first */
	     if i ^= 1 then do;			/* It is a constant */
		if i = 0 then i = length (expr);	/* Rest of expr is a constant */
		else i = i - 1;
		if i < length (expr) then if substr (expr, i+1, 1) = "." then dec_sw = "1"b; /* Decimal constant */
		if dec_sw then do;
		     val = cv_dec_check_ (substr (expr, 1, i), code);
		     if code ^= 0 then do;
			code = 0;
			call err ("Invalid decimal integer: ""^a"".", substr (expr, 1, i));
		     end;
		     if val < -262144 | val > 262143 then
			call err ("Decimal integer not in range -262144 to 262143: ^a", substr (expr, 1, i));
		     call adv (i+1);
		end;
		else do;				/* Octal number */
		     val = cv_oct_check_ (substr (expr, 1, i), code);
		     if code ^= 0 then do;
			code = 0;
			call err ("Invalid octal integer: ""^a"".", substr (expr, 1, i));
		     end;
		     if substr (bval, 1, 18) ^= "0"b & substr (bval, 1, 18) ^= "777777"b3 then
			call err ("Octal integer not in range -400000 to 377777: ^a", substr (expr, 1, i));
		     call adv (i);
		end;
		if val > 0 then if substr (bval, 19, 1) then /* Really negative */
			substr (bval, 1, 18) = "777777"b3;
		call new_token (sym_token);		/* Set up token for symbol */
		token.val = val;
		return;
	     end;

/* Symbol must be a name */

	     i = search (expr, "()*/+|-,");		/* Look for end */
	     if i = 1 then go to bad_char;
	     if i = 0 then i = length (expr);
	     else i = i - 1;

	     call db_fnp_util_$lookup_module (corep, fnp, substr (expr, 1, i), j, code);
	     if code = 0 then do;
		call new_token (sym_token);
		token.val = j;
		call adv (i);
		return;
	     end;

	     call db_fnp_opblock_util_$lookup (substr (expr, 1, i), opval, code);
	     if code = 0 then do;
		call new_token (sym_token);
		unspec (token.val) = "777777"b3 || opval;
		call adv (i);
		return;
	     end;

	     call db_fnp_edit_inst_$assemble (corep, fnp, substr (expr, 1, i), expr_infop, opval, code);
						/* May symbol is a machine opcode mneumonic */
	     if code = 0 then do;
		call new_token (sym_token);
		if substr (opval, 1, 1) then unspec (token.val) = "777777"b3 || opval;
		else unspec (token.val) = "000000"b3 || opval;
		call adv (i);
		return;
	     end;

	     call db_fnp_sym_util_$lookup_user (expr_info.user_tablep, substr (expr, 1, i), symp);
	     if symp = null then do;
		call db_fnp_sym_util_$lookup (substr (expr, 1, i), symp);
		if symp = null then do;
		     code = 0;
		     call err ("Invalid symbol: ""^a"".", substr (expr, 1, i));
		end;
	     end;

	     code = 0;
	     call new_token (sym_token);
	     token.val = sym.value;
	     if sym.reloc = reloc_tib then		/* Must add in tib */
		if ^expr_info.tib_known then call err ("Illegal use of ""^a"". Address of TIB not known.",
		     substr (expr, 1, i));
		else token.val = token.val + expr_info.tib_addr;
	     else if sym.reloc = reloc_hwcm then
		if ^expr_info.hwcm_known then call err ("Illegal use of ""^a"". Address of HWCM not known.",
		     substr (expr, 1, i));
		else token.val = token.val + expr_info.hwcm_addr;
	     else if sym.reloc = reloc_sfcm then
		if ^expr_info.sfcm_known then call err ("Illegal use of ""^a"". Address of SFCM not known.",
		     substr (expr, 1, i));
		else token.val = token.val + expr_info.sfcm_addr;
	     else if sym.reloc = reloc_meters then	/* add in value of t.metr */
		if ^expr_info.tib_known then call err ("Illegal use of ""^a"". Address of TIB not known.",
		     substr (expr, 1, i));
		else do;
		     call db_fnp_eval_ (corep, fnp, "t.metr", expr_infop, arg_caller, tib_meter, code); /* get value of t.metr */
		     if code ^= 0
		     then do;
			arg_code = code;
			return;
		     end;

		     tib_page_base = 256*(divide (expr_info.tib_addr, 256, 17, 0)); /* allow for possible virtual address */
		     tib_meter = tib_page_base + mod (tib_meter,256);

		     call db_fnp_memory_$fetch (corep, fnp, tib_meter, 1, addr (meter_orig), code);
		     if code ^= 0
		     then do;
			arg_code = code;
			return;
		     end;

		     meter_orig = tib_page_base + mod (meter_orig, 256); /* make sure we have abs. address */
		     token.val = token.val + meter_orig;
		end;

	     expr_info.type = sym.type;
	     expr_info.len = sym.len;
	     call adv (i);
	     return;

	end parse_sym;

/* Procedures which to some comon tests on the previous token */

mult_or_add: proc returns (bit (1));

	     return (token.type = mult_token | token.type = add_token);

	end mult_or_add;

start_or_leftp: proc returns (bit (1));

	     return (token.type = start_token | token.type = leftp_token);

	end start_or_leftp;

sym_or_rightp_or_ind: proc returns (bit (1));

	     return (token.type = sym_token | token.type = rightp_token | token.type = ind_token);

	end sym_or_rightp_or_ind;

/* Procedure to create a new token and trhread it in */

new_token: proc (type);

dcl  type fixed bin;				/* Type of new token */

	     if ntoken = hbound (token_list.entry, 1) then call err ("Expression too long.");
	     if ntoken > 0 then token.next = ntoken + 1;	/* Set pointer in prev token */
	     ntoken = ntoken + 1;
	     tokenp = addr (token_list.entry (ntoken));
	     token.prev = ntoken - 1;
	     token.next = 0;
	     token.type = type;
	     token.sub = 0;
	     token.val = 0;
	     return;

	end new_token;

/* Procedure to advance pointer in expression */

adv:	proc (n);

dcl  n fixed bin;					/* Amount to move */

	     exprp = substraddr (expr, n+1);		/* Adjust pointer */
	     exprl = exprl - n;			/* Adjust length */
	     return;

	end adv;

/* Procedure to evaluate the expression by scanning the list of tokens */
/* The procedure is to find the inner most expression, evaluate it, and
   continue. At the end, there should only be 3 tokens left: the start, the end,
   and one symbol token containing the final value */

eval_expr: proc;

	     do while (ntoken > 3);
		call find_sub_expr;			/* Find some inner expression to work on */
		call eval_sub_expr;			/* And reduce it to a value */
	     end;

	     tokenp = addr (token_list.entry (1));	/* Pointer to start token */
	     tokenp = addr (token_list.entry (token.next)); /* Second token, containing the value */
	     result = token.val;			/* Get the answer */
	     return;

	end eval_expr;


/* Procedure to locate an inner expression to evaluate. This will be either
   a part of the expression delimited by parens, or, if no parens left, the
   entire expression. */
/* The following variables are set for future use:
   tstart - the first token in the expression found
   tend - the last
   n_ind - the number of indirection tokens between tstart and tend
   n_mult - likewise for mult tokens
   n_add - likewise for add tokens */

find_sub_expr: proc;

	     n_ind, n_mult, n_add = 0;
	     tstart, tcur = 1;
	     tokenp = addr (token_list.entry (tstart));

	     do while ((token.type ^= rightp_token) & (token.type ^= end_token));
		if token.type = leftp_token then do;
		     tstart = tcur;			/* Maybe expression will start here */
		     n_ind, n_mult, n_add = 0;	/* Must reset counters for inner level */
		end;
		else if token.type = ind_token then n_ind = n_ind + 1;
		else if token.type = mult_token then n_mult = n_mult + 1;
		else if token.type = add_token then n_add = n_add + 1;
		tcur = token.next;			/* On to next one */
		tokenp = addr (token_list.entry (tcur));
	     end;
	     tend = tcur;

	end find_sub_expr;

/* Procedure to evaluate sub-expression once it has been isolated. */
/* The sub-expression is repeatedly scanned for mult tokens, add tokens, and
   ind tokens, in that order.  Repeated scans are necessary because
   indirect ops must be done before mult or add ops after them, and vice versa */

eval_sub_expr: proc;

	     do while ((n_ind + n_mult + n_add) > 0);
		if n_mult > 0 then call eval_op (mult_token, n_mult);
		if n_add > 0 then call eval_op (add_token, n_add);
		if n_ind > 0 then call eval_ind;
	     end;

	     call del_token (tstart);			/* Delete parens one expression is evaluated */
	     call del_token (tend);
	     return;

	end eval_sub_expr;

/* This procedure scans looking for either mult tokens or add tokens to be
   evaluated. As many are evaluated as possible. The scan stops with either a
   an ind token, or exhausting the count of tokens being handled. */

eval_op:	proc (token_type, token_cnt);

dcl  token_type fixed bin;				/* The kind of token being evaluated, mult or add */
dcl  token_cnt fixed bin;				/* Number still unevaluated in sub-expression */

	     tcur = tstart;
	     tokenp = addr (token_list.entry (tcur));
	     do while ((token.type ^= ind_token) & (token_cnt > 0));
		if token.type = token_type then do;	/* Got one */
		     call compute_op;		/* Go do the arithmetic */
		     token_cnt = token_cnt - 1;
		end;
		tcur = token.next;
		tokenp = addr (token_list.entry (tcur));
	     end;
	     return;				/* Every thing possible is done */

	end eval_op;

/* Procedure called to evalue a mult or add token. Once the arithmetic is done,
   the value is stored in the first sym token. the operator token and the second
   symbol token are deleted. This procedure is called with tcur as the operator
   token being evaluated */

compute_op: proc;

dcl (del1, del2) fixed bin;				/* The two tokens to be deleted */
dcl (val1, val2) fixed bin (35);			/* Values of the two symbols */
dcl  p ptr;

	     del1 = tcur;				/* The operator token will be deleted */
	     del2 = token.next;			/* As well as the second operand */
	     p = addr (token_list.entry (token.next));	/* Pointter to second symbol token */
	     val2 = p -> token.val;
	     p = addr (token_list.entry (token.prev));	/* Pointer to the first symbol */
	     val1 = p -> token.val;
	     if token.type = add_token then do;		/* Add or subtract */
		if token.sub = 1 then val1 = val1 + val2;
		else val1 = val1 - val2;
	     end;
	     else do;				/* Multiply or divide */
		if token.sub = 1 then val1 = val1 * val2;
		else do;
		     if val2 = 0 then call err ("Division by zero.");
		     else val1 = divide (val1, val2, 35, 0);
		end;
	     end;

	     tcur = token.prev;			/* Make first operand the current token */
	     tokenp = addr (token_list.entry (tcur));
	     token.val = val1;			/* Save answer */
	     expr_info.type = type_oct;
	     expr_info.len = 1;
	     call del_token (del1);			/* Delete operator */
	     call del_token (del2);			/* And the sedond operand */
	     return;

	end compute_op;

/* Procedure to scan for and evalute indirections. The will do as many
   indirections as specified, but will not scan past an add or mult token */

eval_ind:	proc;

dcl  bitval bit (36);
dcl 1 word_buf aligned,
    2 val bit (18) unal,
    2 pad bit (18) unal;

	     tcur = tstart;
	     tokenp = addr (token_list.entry (tcur));
	     do while (^mult_or_add () & (n_ind > 0));
		if token.type = ind_token then do;	/* Found one */
		     tcur = token.prev;		/* Back up to look at token with address */
		     tokenp = addr (token_list.entry (tcur));
		     call db_fnp_memory_$fetch (corep, fnp, (token.val), 1, addr (word_buf), code);
		     if code ^= 0 then call err ("Unable to read FNP memory location ^o to do indrection.", token.val);
		     substr (bitval, 19) = word_buf.val; /* Put in right half of word */
		     if substr (word_buf.val, 1, 1) = "0"b then substr (bitval, 1, 18) = "0"b; /* Propagate sign */
		     else substr (bitval, 1, 18) = "777777"b3;
		     unspec (token.val) = bitval;
		     n_ind = n_ind - 1;
		     expr_info.type = type_oct;
		     expr_info.len = 1;
		     call del_token ((token.next));	/* Delete ind token */
		end;
		tcur = token.next;
		tokenp = addr (token_list.entry (tcur));
	     end;

	end eval_ind;

/* Procedure to delete a token by untreading it from the list */

del_token: proc (n);

dcl  n fixed bin;					/* The token to go */
dcl (next, prev) fixed bin;
dcl  p ptr;

	     p = addr (token_list.entry (n));
	     prev = p -> token.prev;
	     next = p -> token.next;
	     if (prev = 0) | (next = 0) then return;	/* Ndver delete start or end */

	     p = addr (token_list.entry (prev));
	     p -> token.next = next;
	     p = addr (token_list.entry (next));
	     p -> token.prev = prev;
	     ntoken = ntoken - 1;
	     return;

	end del_token;

/* Handle an expression in single-quuotes (') as a machine instruction */

eval_inst: proc;

dcl (i, j) fixed bin;
dcl  inst bit (18);
dcl  fb35 fixed bin (35);

	     i = 1;				/* Starting index to assemble */
	     j = length (expr);			/* Length to assemble */
	     if substr (expr, 1, 1) = "'" then do;	/* Strip leading quote */
		i = 2;
		j = j-1;
	     end;
	     if substr (expr, length (expr), 1) = "'" then j = j-1; /* Strip trailing quote */
	     call db_fnp_edit_inst_$assemble (corep, fnp, substr (expr, i, j), expr_infop, inst, code);
	     if code ^= 0 then do;
		if arg_caller ^= "" then call com_err_ (0, arg_caller, "Invalid machine instruction: ^a");
		else call ioa_ ("Invalid machine instruction: ^a", expr);
		go to error_return;
	     end;
	     if substr (inst, 1, 1) then unspec (fb35) = "777777"b3 || inst; /* If negative number */
	     else fb35 = bin (inst);
	     result = fb35;
	     return;

	end eval_inst;

/* Error routines */

bad_char:
	if exprl < length (arg_expr) then call err ("""^a"" after ""^a"" is invalid.",
	     substr (expr, 1, 1), substr (arg_expr, 1, length (arg_expr) - exprl));
	else call err ("""^a"" at beginning is invalid.", substr (expr, 1, 1));


/* General error subroutine */

err:	proc options (variable);

dcl  s char (256);
dcl  p ptr;

	     call cu_$arg_list_ptr (p);
	     call ioa_$general_rs (p, 1, 2, s, (0), "1"b, "0"b);
	     if code ^= 0 | arg_caller ^= "" then
		call com_err_ (code, arg_caller, "Invalid expression: ""^a"". ^a", arg_expr, s);
	     else call ioa_ ("Invalid expression: ""^a"". ^a", arg_expr, s);
	     if code = 0 then code = error_table_$bad_arg;
	     go to error_return;

	end err;

/* Simulate substraddr builtin temporarily */

substraddr: proc (c, n) returns (ptr);

dcl  c char (*);
dcl  n fixed bin;
dcl  ca (n) char (1) unal based (addr (c));

	     return (addr (ca (n)));

	end substraddr;

%include debug_fnp_data;

     end db_fnp_eval_;




		    db_fnp_memory_.pl1              11/15/82  1816.2rew 11/15/82  1449.4       90864



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


db_fnp_memory_: proc;

/* Parameters */

dcl  arg_corep ptr;					/* Address of fnp memory in a segment */
dcl  arg_fnp fixed bin;				/* The fnp number */
dcl  arg_fnp_addr fixed bin;				/* The fnp address to access */
dcl  arg_fnp_len fixed bin;				/* Length of data, in fnp words */
dcl  arg_data_ptr ptr;				/* Addr where data is to be stored */
dcl  arg_code fixed bin (35);
dcl  arg_caller char (*);				/* Name of caller, for command_query_ */
dcl  arg_mode fixed bin;				/* Options for store call -
						   0 = just patch,
						   1 = list changes and patch,
						   2 = list changes, ask if ok, then patch */

/* Automatic */

dcl  corep ptr;
dcl  fnp fixed bin;
dcl  fnp_name char (1);
dcl  code fixed bin (35);
dcl  state fixed bin;
dcl  mode fixed bin;
dcl  i fixed bin;
dcl  data_ptr ptr;
dcl  fnp_addr fixed bin;
dcl  check_buf (32) bit (18) unal;			/* Holds original copy */
dcl  answer char (3) var;				/* Reply from command_query_ */
dcl  fnp_len fixed bin;				/* Length of memory being moved */
dcl  fnp_mem (fnp_len) bit (18) unal based;		/* A piece of fnp memory */
dcl  dir char (168);
dcl  ename char (32);
dcl  replace_acl bit (1);
dcl  save_modes bit (36);

dcl 1 segment_acl (1) aligned,
    2 access_name char (32),
    2 modes bit (36),
    2 zero_pad bit (36),
    2 status_code fixed bin (35);

dcl 1 delete_acl (1) aligned,
    2 access_name char (32),
    2 status_code fixed bin (35);

dcl  dump_seg (0:32767) bit (18) unal based (corep);	/* Declaration of a dump */

dcl 1 fnp_info aligned,				/* Data structure for dump/patch fnp */
    2 fnp_addr fixed bin,
    2 fnp_len fixed bin,
    2 data_ptr ptr,
    2 prev_data_ptr ptr;

/* Constants */

dcl 1 query_info aligned int static options (constant),	/* For command_query_ */
    2 version fixed bin init (2),
    2 yes_or_no bit (1) unal init ("1"b),
    2 supp_name bit (1) unal init ("0"b),
    2 pad bit (34) unal init ("0"b),
    2 code1 fixed bin (35) init (0),
    2 code2 fixed bin (35) init (0);

/* Internal static */

dcl  call_type fixed bin int static init (0);		/* Says which kind of ring0 call to use */
dcl  init_sw bit (1) int static init ("0"b);
dcl  crmem fixed bin int static;

/* External stuff */

dcl  phcs_$tty_order entry (fixed bin, char (*), ptr, fixed bin, fixed bin (35));
dcl  hphcs_$tty_order entry (fixed bin, char (*), ptr, fixed bin, fixed bin (35));
dcl  phcs_$tty_control entry (char (*), char (*), ptr, fixed bin (35));
dcl  hphcs_$tty_control entry (char (*), char (*), ptr, fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  sub_err_ entry options (variable);
dcl  command_query_ entry options (variable);
dcl  hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl  hcs_$list_acl entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin (35));
dcl  hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  hcs_$delete_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  get_group_id_$tag_star entry returns (char (32));
dcl  db_fnp_sym_util_$get_value entry (char (*)) returns (fixed bin);
dcl  get_fnp_name_ entry (fixed bin) returns (char (32));

dcl  error_table_$bad_arg ext fixed bin (35);
dcl  error_table_$unimplemented_version ext fixed bin (35);
dcl  error_table_$moderr ext fixed bin (35);
dcl  error_table_$dev_offset_out_of_bounds ext fixed bin (35);

dcl  linkage_error condition;
dcl  no_write_permission condition;

dcl (addr, min, null, substr) builtin;

/* Entry to fetch fnp memory */

fetch:	entry (arg_corep, arg_fnp, arg_fnp_addr, arg_fnp_len, arg_data_ptr, arg_code);

	corep = arg_corep;				/* Get ptr to memory image (if in segment) */
	fnp_addr = arg_fnp_addr;
	fnp_len = arg_fnp_len;

	if corep = null then do;			/* Dumping a real fnp */
	     fnp = arg_fnp;
	     fnp_name = get_fnp_name_ (fnp);
	     fnp_info.fnp_addr = fnp_addr;
	     fnp_info.fnp_len = arg_fnp_len;
	     fnp_info.data_ptr = arg_data_ptr;
	     fnp_info.prev_data_ptr = null;
	     do while (fnp_len > 0);
		fnp_info.fnp_len = min (fnp_len, 64);
retry_dump_call:
		if call_type = 0 then do;		/* Haven't established which call yet */
		     on linkage_error go to call_1_failed;
		     call phcs_$tty_order (fnp, "dump_fnp", addr (fnp_info), state, code);
		     revert linkage_error;		/* It worked */
		     call_type = 1;
		     go to check_fetch_code;
call_1_failed:	     on linkage_error go to call_2_failed;
		     call phcs_$tty_control (fnp_name, "dump_fnp", addr (fnp_info), code);
		     revert linkage_error;
		     call_type = 2;
		     go to check_fetch_code;
call_2_failed:	     revert linkage_error;
		     call sub_err_ (0, "db_fnp_memory_", "h", null (), (0),
			"No access to phcs_ gate; unable to read FNP memory.");
		     go to retry_dump_call;
		end;
		else if call_type = 1 then call phcs_$tty_order (fnp, "dump_fnp", addr (fnp_info), state, code);
		else call phcs_$tty_control (fnp_name, "dump_fnp", addr (fnp_info), code);
check_fetch_code:
		if code ^= 0 then go to fetch_return;
		fnp_info.fnp_addr = fnp_info.fnp_addr + fnp_info.fnp_len; /* Check next address */
		fnp_info.data_ptr = addr (fnp_info.data_ptr -> fnp_mem (fnp_info.fnp_len + 1));
		fnp_len = fnp_len - fnp_info.fnp_len;
	     end;
	end;
	else do;					/* Dumping from a segment */
	     call check_bounds;
	     if code ^= 0 then go to fetch_return;
	     arg_data_ptr -> fnp_mem = addr (dump_seg (arg_fnp_addr)) -> fnp_mem;
	     code = 0;
	end;

fetch_return:
	arg_code = code;
	return;

/* Entry to store into FNP memory */

store:	entry (arg_corep, arg_fnp, arg_fnp_addr, arg_fnp_len, arg_data_ptr, arg_caller, arg_mode, arg_code);


	corep = arg_corep;
	fnp = arg_fnp;
	fnp_addr = arg_fnp_addr;
	fnp_len = arg_fnp_len;
	mode = arg_mode;
	data_ptr = arg_data_ptr;

	if fnp_len < 1 | fnp_len > 32 then do;
	     code = error_table_$bad_arg;
	     go to store_return;
	end;

	call fetch (corep, fnp, fnp_addr, fnp_len, addr (check_buf), code); /* Get old values */
	if code ^= 0 then go to store_return;

	if mode ^= 0 then do;			/* If reporting needed */
	     do i = 1 to fnp_len;
		call ioa_ ("^6w  ^.3b to ^.3b", fnp_addr + i - 1,
		     check_buf (i), data_ptr -> fnp_mem (i));
	     end;
	     if mode = 2 then do;			/* Must ask for verification */
		call command_query_ (addr (query_info), answer, arg_caller, "Correct?");
		if answer ^= "yes" then do;
		     code = 0;
		     go to store_return;
		end;
	     end;
	end;

	if corep ^= null then do;			/* Patching a segment */
	     on no_write_permission go to force_access;
	     addr (dump_seg (fnp_addr)) -> fnp_mem = data_ptr -> fnp_mem;
	     revert no_write_permission;
	     code = 0;
	     go to store_return;

force_access:  revert no_write_permission;
	     call hcs_$fs_get_path_name (corep, dir, (0), ename, code); /* Get seg name, needed for acl primitives */
	     if code ^= 0 then go to store_return;
	     segment_acl.access_name (1) = get_group_id_$tag_star (); /* Get my current acl entry */
	     segment_acl.zero_pad (1) = "0"b;
	     call hcs_$list_acl (dir, ename, null (), (null ()), addr (segment_acl), (1), code);
	     if code ^= 0 then go to store_return;
	     if segment_acl.status_code (1) = 0 then do;	/* I did have an entry */
		save_modes = segment_acl.modes (1);	/* Save them */
		replace_acl = "1"b;			/* Remember to put them back */
	     end;
	     else replace_acl = "0"b;			/* No acl to replace */
	     segment_acl.modes (1) = "101"b;		/* Give rw access to me */
	     segment_acl.zero_pad (1) = "0"b;
	     call hcs_$add_acl_entries (dir, ename, addr (segment_acl), 1, code);
	     if code ^= 0 then go to store_return;
	     on no_write_permission begin;		/* Ready to begin, but be careful */
		code = error_table_$moderr;
		go to cleanup_acl;
	     end;

	     addr (dump_seg (fnp_addr)) -> fnp_mem = data_ptr -> fnp_mem; /* Try again */
	     code = 0;				/* It worked */
cleanup_acl:   revert no_write_permission;
	     if replace_acl then do;			/* Put back old access */
		segment_acl.modes (1) = save_modes;
		segment_acl.zero_pad (1) = "0"b;
		call hcs_$add_acl_entries (dir, ename, addr (segment_acl), 1, (0));
	     end;
	     else do;
		delete_acl.access_name (1) = segment_acl.access_name (1);
		call hcs_$delete_acl_entries (dir, ename, addr (delete_acl), 1, (0));
	     end;
	end;

	else do;					/* Patching a real FNP */
	     fnp_name = get_fnp_name_ (fnp);
	     fnp_info.fnp_addr = fnp_addr;
	     fnp_info.fnp_len = fnp_len;
	     fnp_info.data_ptr = data_ptr;
	     fnp_info.prev_data_ptr = addr (check_buf);
	     if call_type = 1 then call hphcs_$tty_order (fnp, "patch_fnp", addr (fnp_info), state, code);
	     else if call_type = 2 then call hphcs_$tty_control (fnp_name, "patch_fnp", addr (fnp_info), code);
	     else code = error_table_$unimplemented_version; /* Can't happen */
	end;

store_return: arg_code = code;
	return;


/* Internal procedure to check that an address and length is valid. This is only used for accesses to segments */

check_bounds: proc;

dcl  n fixed bin (18);

	     if ^init_sw then do;
		crmem = db_fnp_sym_util_$get_value (".crmem");
		init_sw = "1"b;
	     end;

	     if fnp_addr < 0 | fnp_len <= 0 then do;
		code = error_table_$bad_arg;
		return;
	     end;

	     n = bin (dump_seg (crmem), 18);
	     if n < 32767 | mod (n+1, 32768) ^= 0
	     then n = 262143;			/* Assume 256k for clobbered seg */

	     if fnp_addr > n | (fnp_addr + fnp_len - 1) > n then do;
		code = error_table_$dev_offset_out_of_bounds;
		return;
	     end;

	     code = 0;
	     return;

	end check_bounds;

     end db_fnp_memory_;




		    db_fnp_opblock_util_.pl1        11/15/82  1816.2rew 11/15/82  1502.0       36036



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


/* DB_FNP_OPBLOCK_UTIL_ - Procedure to display fnp memory in opblock format */

/* Written March 1977 by Larry Johnson */

db_fnp_opblock_util_: proc;

/* Parameters */

dcl  arg_corep ptr;					/* Pointer to segment contining core image */
dcl  arg_fnp fixed bin;				/* Number of a running fnp */
dcl  arg_fnp_addr fixed bin;				/* The starting address being displayed */
dcl  arg_fnp_len fixed bin;				/* The number of words */
dcl  arg_data_ptr ptr;				/* Pointer to the words to display */
dcl  arg_code fixed bin (35);
dcl  arg_opname char (*);
dcl  arg_opval bit (18);

/* Automatic */

dcl  corep ptr;
dcl  fnp fixed bin;
dcl  fnp_addr fixed bin;
dcl  fnp_len fixed bin;
dcl  data_ptr ptr;
dcl  code fixed bin (35);
dcl  i fixed bin;
dcl  edited_addr char (32) var;
dcl  opblock_addr char (32) var;
dcl  opval bit (18);
dcl  opname char (6);

dcl  fnp_mem (fnp_len) bit (18) unal based (data_ptr);


/* External stuff */

dcl  ioa_ entry options (variable);
dcl  db_fnp_util_$edit_module_addr entry (ptr, fixed bin, fixed bin, char (*) var, fixed bin (35));

dcl  error_table_$noentry ext fixed bin (35);

dcl (addr, bin, bit, hbound, lbound, rtrim, substr) builtin;


/* Entry to display memory in opblock format */

display:	entry (arg_corep, arg_fnp, arg_fnp_addr, arg_fnp_len, arg_data_ptr, arg_code);

	corep = arg_corep;
	fnp = arg_fnp;
	fnp_addr = arg_fnp_addr;
	fnp_len = arg_fnp_len;
	data_ptr = arg_data_ptr;
	opblock_tablep = addr (db_fnp_opblocks_$);

/* Loop thru all the words */

	do i = 1 to fnp_len;
	     if substr (fnp_mem (i), 1, 9) = "777"b3 then do;
		call get_name (fnp_mem (i), opname);
		edited_addr = rtrim (opname);
	     end;
	     else do;
		call db_fnp_util_$edit_module_addr (corep, fnp, bin (fnp_mem (i)), edited_addr, code);
		if code ^= 0 then edited_addr = "";
		else edited_addr = "  " || edited_addr;
	     end;
	     call db_fnp_util_$edit_module_addr (corep, fnp, fnp_addr, opblock_addr, code);
	     if code ^= 0 then opblock_addr = "";
	     call ioa_ ("^5w ^13a  ^.3b  ^a", fnp_addr, opblock_addr, fnp_mem (i), edited_addr);
	     fnp_addr = fnp_addr + 1;
	end;

	arg_code = 0;
	return;


/* Entry to lookup a symbol and returns its value as an opblock number */

lookup:	entry (arg_opname, arg_opval, arg_code);

	opblock_tablep = addr (db_fnp_opblocks_$);
	do i = lbound (opblock_table.name, 1) to hbound (opblock_table.name, 1);
	     if opblock_table.name (i) = arg_opname then do;
		substr (opval, 1, 9) = "777"b3;
		substr (opval, 10, 9) = bit (bin (i, 9), 9);
		arg_opval = opval;
		arg_code = 0;
		return;
	     end;
	end;
	arg_opval = "0"b;
	arg_code = error_table_$noentry;
	return;


/* Entry that given an opblock, returns its name */

get_name:	entry (arg_opval, arg_opname);

	opval = arg_opval;
	arg_opname = "";

	opblock_tablep = addr (db_fnp_opblocks_$);
	if substr (opval, 1, 9) ^= "777"b3 then return;
	i = bin (substr (opval, 10, 9));
	if i < lbound (opblock_table.name, 1) | i > hbound (opblock_table.name, 1) then return;
	arg_opname = opblock_table.name (i);
	return;

/* Debugging entry that will print the opblock table. This is just used as a
   command to check that the procedure that constructs the table works */
/* This entry is not retained. */

print_table: entry;

	opblock_tablep = addr (db_fnp_opblocks_$);
	do i = lbound (opblock_table.name, 1) to hbound (opblock_table.name, 1);
	     call ioa_ ("^2o ^a", i, opblock_table.name (i));
	end;
	return;

%include debug_fnp_data;

     end db_fnp_opblock_util_;




		    db_fnp_opblocks_.cds            11/15/82  1816.2rew 11/15/82  1535.7       73548



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


/* DB_FNP_OPBLOCKS_ - Procedure to create a table of interpreter opblock names */
/* The table is constructed by scanning the macros.map355 source file */

/* Written March 1977 by Larry Johnson */
/* Modified by R Holmstedt to use the new library >ldd>mcs. */
db_fnp_opblocks_: proc;

/* Automatic */

dcl  segp ptr;					/* Pointer to entire macro segment */
dcl  segl fixed bin;				/* Its length */
dcl  restp ptr;					/* Pointer to unscanned (rest of) segment */
dcl  restl fixed bin;				/* Its length */
dcl  max_cnt fixed bin;				/* Max number of opblocks found */
dcl  i fixed bin;
dcl  opname char (6);
dcl  ptr_array (1) ptr;				/* For get_temp_segments_ */
dcl  linep ptr;					/* Pointer to current line */
dcl  linel fixed bin;				/* Its length */
dcl  code fixed bin (35);
dcl  bit_count fixed bin (24);
dcl  dir char (168);
dcl 1 cds like cds_args automatic;

dcl  line char (linel) based (linep);
dcl  rest char (restl) based (restp);

/* Constants */

dcl  white_space char (2) int static options (constant) init (" 	"); /* Space and tab */
dcl  nl char (1) int static options (constant) init ("
");
dcl  name char (16) int static options (constant) init ("db_fnp_opblocks_");
dcl  exclude_all char (32) int static options (constant) init ("**");
dcl  macro_name char (13) int static options (constant) init ("macros.map355");

/* External stuff */

dcl  com_err_ entry options (variable);
dcl  ioa_ entry options (variable);
dcl  cv_oct_ entry (char (*)) returns (fixed bin (35));
dcl  get_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35));
dcl  release_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35));
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  get_wdir_ entry returns (char (168));
dcl  create_data_segment_ entry (ptr, fixed bin (35));

dcl  error_table_$noentry ext fixed bin (35);

dcl  cleanup condition;

dcl (addr, divide, index, max, null, search, size, string, substr, verify) builtin;


/* Initialization */

	ptr_array = null;
	segp = null;
	on cleanup call clean_up;

	call init_macro_seg;			/* This locates the macro segment */

hunt_opstart:					/* Must find the line *++opstart */
	call get_line;
	if linep = null then do;			/* End of file */
	     call com_err_ (0, name, "No *++opstart statement in ^a^[>^]^a", dir, dir ^= ">", macro_name);
	     go to done;
	end;
	if linel < 10 then go to hunt_opstart;
	if substr (line, 1, 10) ^= "*++opstart" then go to hunt_opstart;

/* Found start of opblock section */

	call get_temp_segments_ (name, ptr_array, code);
	if code ^= 0 then do;
	     call com_err_ (code, name, "Unable to get temp segment");
	     go to done;
	end;
	opblock_tablep = ptr_array (1);
	max_cnt = -1;

/* Now scan for maccros */

hunt_macro:
	call get_line;
	if linep = null then go to done_scan;		/* End of segment */
	if substr (line, 1, 1) = "*" then go to hunt_macro; /* Skip comments */
	i = search (line, white_space);		/* Find first white space */
	if (i = 0) | (i = 1) then go to hunt_macro;	/* Ignore lines with no label, or no white space */
	opname = substr (line, 1, i-1);		/* Save label */
	call adv_line (i);				/* Skip over label */
	call skip_white_space;			/* And any trailing white space */
	i = search (line, white_space);		/* Look for end of opcode */
	if i = 0 then i = linel;
	else i = i-1;
	if i ^= 5 then go to hunt_macro;		/* Cant be "macro" */
	if substr (line, 1, 5) ^= "macro" then go to hunt_macro;

/* Found start of a macro */

	call get_line;				/* Read next line */
	if linep = null then go to done_scan;
	call skip_white_space;
	if linel < 3 then go to hunt_macro;		/* Too short to say "oct" */
	if substr (line, 1, 3) ^= "oct" then go to hunt_macro;
	call adv_line (3);
	call skip_white_space;
	if linel < 6 then go to hunt_macro;		/* Too short to say 777*** */
	if substr (line, 1, 3) ^= "777" then go to hunt_macro;
	if verify (substr (line, 4, 3), "01234567") ^= 0 then go to hunt_macro;

/* A real opblock macro was found */

	call store (opname, cv_oct_ (substr (line, 4, 3)));
	go to hunt_macro;				/* Back for next */

/* Come here at end of segment */
done_scan:
	if max_cnt = -1 then do;
	     call com_err_ (0, name, "No opblocks defined in ^a^[>^]^a", dir, dir ^= ">", macro_name);
	     go to done;
	end;

/* Now create the data segment */

	cds.p (1) = opblock_tablep;
	cds.len (1) = size (opblock_table);
	cds.struct_name (1) = "opblock_table";
	cds.p (2) = null;
	cds.len (2) = 0;
	cds.struct_name (2) = "";
	cds.seg_name = name;
	cds.num_exclude_names = 1;
	cds.exclude_array_ptr = addr (exclude_all);
	string (cds.switches) = "0"b;
	cds.have_text = "1"b;
	call create_data_segment_ (addr (cds), code);
	if code ^= 0 then call com_err_ (code, name, "From create_data_segment_");

done:	call clean_up;
	return;

/* Procedure to initiate the macro source segment. It looks first in the working directory,
   then in >ldd>mcs>info */

init_macro_seg: proc;

	     dir = get_wdir_ ();
	     call hcs_$initiate_count (dir, macro_name, "", bit_count, 0, segp, code);
	     if segp = null then do;
		if code ^= error_table_$noentry then do;
macro_seg_err:	     call com_err_ (code, name, "^a^[>^]^a", dir, dir ^= ">", macro_name);
		     go to done;
		end;
		dir = ">ldd>mcs>info";		/* Try library */
		call hcs_$initiate_count (dir, macro_name, "", bit_count, 0, segp, code);
		if segp = null then go to macro_seg_err;
	     end;

	     call ioa_ ("^a: Using ^a^[>^]^a", name, dir, (dir ^= ">"), macro_name);

	     segl = divide (bit_count, 9, 17, 0);
	     restp = segp;
	     restl = segl;
	     return;

	end init_macro_seg;

/* Procedure to isolate the next line in the source */

get_line:	proc;

dcl  i fixed bin;

get_next_line:
	     if restl = 0 then do;			/* End of file */
		linep = null;
		return;
	     end;

	     i = index (rest, nl);
	     if i = 0 then i, linel = restl;		/* No more newlines */
	     else linel = i-1;
	     linep = restp;
	     restp = substraddr (rest, i+1);
	     restl = restl - i;
	     if linel = 0 then go to get_next_line;	/* Ignor empty lines */
	     return;

	end get_line;

/* Procedure called while pasring line to move pointer down the line */

adv_line:	proc (n);

dcl  n fixed bin;					/* How far too move */

	     linep = substraddr (line, n+1);
	     linel = linel - n;
	     return;

	end adv_line;

/* Procedure to skip over any white space */

skip_white_space: proc;

dcl  i fixed bin;

	     i = verify (line, white_space);		/* Count white space charactrs */
	     if i = 0 then i = linel;			/* All white line */
	     else i = i - 1;
	     call adv_line (i);
	     return;

	end skip_white_space;

/* Procedure to store a new entry in the table */

store:	proc (opn, n);

dcl  opn char (6);					/* Name of block */
dcl  n fixed bin;					/* Its number */

dcl  i fixed bin;

	     do i = (max_cnt + 1) to (n - 1);		/* Fill in any skipped entries */
		opblock_table.name (i) = "**??**";
	     end;

	     opblock_table.name (n) = opn;
	     max_cnt = max (max_cnt, n);
	     opblock_table.cnt = max_cnt;
	     return;

	end store;

/* Cleanup handler */

clean_up:	proc;

	     if segp ^= null then call hcs_$terminate_noname (segp, code);
	     if ptr_array (1) ^= null then call release_temp_segments_ (name, ptr_array, code);
	     return;

	end clean_up;

/* Simulate substraddr builtin temporarily */

substraddr: proc (c, n) returns (ptr);

dcl  c char (*);
dcl  n fixed bin;
dcl  ca (n) char (1) unal based (addr (c));

	     return (addr (ca (n)));

	end substraddr;

%include debug_fnp_data;

%include cds_args;

     end db_fnp_opblocks_;




		    db_fnp_opcodes_.cds             11/15/82  1816.2rew 11/15/82  1535.9       62847



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


/* DB_FNP_OPCODES_ - Procedure that defines a table of FNP opcodes */

/* Written February 1977 by Larry Johnson */

db_fnp_opcodes_: proc;

/* Automatic */

dcl  code fixed bin (35);
dcl  ptr_array (1) ptr;
dcl 1 cds like cds_args automatic;

/* Constants */

dcl  name char (15) int static options (constant) init ("db_fnp_opcodes_");
dcl  exclude_all char (32) int static options (constant) init ("**");

/* External */

dcl  get_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35));
dcl  release_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35));
dcl  create_data_segment_ entry (ptr, fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  cv_oct_ entry (char (*)) returns (fixed bin (35));

dcl (addr, null, translate) builtin;

dcl  cleanup condition;


/* Setup temp segment */

	ptr_array = null;
	on cleanup call clean_up;
	call get_temp_segments_ (name, ptr_array, code);
	if code ^= 0 then do;
	     call com_err_ (code, name, "Unable to get temp segment.");
	     return;
	end;

/* Fill the opcode table */

	optablep = ptr_array (1);
	optable.cnt = 0;
	call build_table;

/* Now create the data segment */

	cds.p (1) = optablep;
	cds.len (1) = size (optable);
	cds.struct_name (1) = "optable";
	cds.p (2) = null;
	cds.len (2) = 0;
	cds.struct_name (2) = "";
	cds.seg_name = name;
	cds.num_exclude_names = 1;
	cds.exclude_array_ptr = addr (exclude_all);
	string (cds.switches) = "0"b;
	cds.have_text = "1"b;
	call create_data_segment_ (addr (cds), code);
	if code ^= 0 then call com_err_ (name, code);
	call clean_up;
	return;


/* Procedure to fill the opcode table */

build_table: proc;

	     call store (0, "ada   ", "X06X");
	     call store (0, "adcx1 ", "X42X");
	     call store (0, "adcx2 ", "X02X");
	     call store (0, "adcx3 ", "X40X");
	     call store (0, "adq   ", "X46X");
	     call store (0, "ana   ", "X34X");
	     call store (0, "ansa  ", "X32X");
	     call store (0, "aos   ", "X76X");
	     call store (0, "asa   ", "X16X");
	     call store (0, "cana  ", "X31X");
	     call store (0, "cioc  ", "X60X");
	     call store (0, "cmpa  ", "X27X");
	     call store (0, "cmpq  ", "X67X");
	     call store (0, "cmpx1 ", "X63X");
	     call store (0, "cmpx2 ", "X23X");
	     call store (0, "cmpx3 ", "X61X");
	     call store (0, "dvf   ", "X21X");
	     call store (0, "era   ", "X35X");
	     call store (0, "ersa  ", "X62X");
	     call store (0, "lda   ", "X07X");
	     call store (0, "ldex  ", "X30X");
	     call store (0, "ldi   ", "X44X");
	     call store (0, "ldq   ", "X47X");
	     call store (0, "ldx1  ", "X43X");
	     call store (0, "ldx2  ", "X03X");
	     call store (0, "ldx3  ", "X41X");
	     call store (0, "mpf   ", "X01X");
	     call store (0, "ora   ", "X37X");
	     call store (0, "orsa  ", "X72X");
	     call store (0, "sba   ", "X26X");
	     call store (0, "sbq   ", "X66X");
	     call store (0, "ssa   ", "X36X");
	     call store (0, "sta   ", "X17X");
	     call store (0, "stex  ", "X70X");
	     call store (0, "sti   ", "X54X");
	     call store (0, "stq   ", "X57X");
	     call store (0, "stx1  ", "X53X");
	     call store (0, "stx2  ", "X13X");
	     call store (0, "stx3  ", "X50X");
	     call store (0, "stz   ", "X56X");
	     call store (0, "szn   ", "X20X");
	     call store (0, "tmi   ", "X75X");
	     call store (0, "tnc   ", "X45X");
	     call store (0, "tnz   ", "X64X");
	     call store (0, "tov   ", "X55X");
	     call store (0, "tpl   ", "X65X");
	     call store (0, "tra   ", "X71X");
	     call store (0, "tsy   ", "X10X");
	     call store (0, "tze   ", "X74X");
	     call store (0, "adaq  ", "X15X");
	     call store (0, "ldaq  ", "X04X");
	     call store (0, "sbaq  ", "X24X");
	     call store (0, "staq  ", "X14X");
	     call store (1, "iaa   ", "773X");
	     call store (2, "iacx1 ", "173X");
	     call store (2, "iacx2 ", "273X");
	     call store (2, "iacx3 ", "373X");
	     call store (1, "iana  ", "022X");
	     call store (1, "iaq   ", "573X");
	     call store (1, "icana ", "222X");
	     call store (1, "icmpa ", "422X");
	     call store (1, "iera  ", "322X");
	     call store (1, "ila   ", "673X");
	     call store (1, "ilq   ", "473X");
	     call store (1, "iora  ", "122X");
	     call store (1, "sel   ", "073X");
	     call store (1, "rier  ", "012X");
	     call store (1, "ria   ", "412X");
	     call store (1, "sier  ", "052X");
	     call store (1, "sic   ", "452X");
	     call store (3, "alp   ", "3336");
	     call store (3, "alr   ", "2336");
	     call store (3, "als   ", "0336");
	     call store (3, "arl   ", "2337");
	     call store (3, "ars   ", "0337");
	     call store (3, "llr   ", "2334");
	     call store (3, "lls   ", "0334");
	     call store (3, "lrl   ", "2335");
	     call store (3, "lrs   ", "0335");
	     call store (3, "qlp   ", "7336");
	     call store (3, "qlr   ", "6336");
	     call store (3, "qls   ", "4336");
	     call store (3, "qrl   ", "6337");
	     call store (3, "qrs   ", "4337");
	     call store (4, "caq   ", "6333");
	     call store (4, "cax1  ", "4332");
	     call store (4, "cax2  ", "0332");
	     call store (4, "cax3  ", "4333");
	     call store (4, "cqa   ", "7333");
	     call store (4, "cx1a  ", "2332");
	     call store (4, "cx2a  ", "3332");
	     call store (4, "cx3a  ", "3333");
	     call store (4, "dis   ", "4331");
	     call store (4, "eni   ", "7331");
	     call store (4, "inh   ", "3331");
	     call store (4, "nop   ", "2331");
	     call store (4, "nrm   ", "1336");
	     call store (4, "nrml  ", "1334");

	     return;

	end build_table;


/* Procedure to put one entry in the table */

store:	proc (n, name, code);

dcl  n fixed bin;					/* Opcode type */
dcl  name char (6);					/* Name of opcode */
dcl  code char (4);					/* Opcode - X means dont care */

dcl  temp char (4);

	     optable.cnt = optable.cnt + 1;
	     opp = addr (optable.entry (optable.cnt));

	     op.name = name;
	     op.type = n;

	     temp = translate (code, "0", "X");		/* Replace xes by zeroes to get opcode */
	     op.code = bit (bin (cv_oct_ (temp), 12), 12);

	     temp = translate (code, "077777777", "X01234567"); /* Get mask for finding opcode */
	     op.mask = bit (bin (cv_oct_ (temp), 12), 12);

	     return;

	end store;


clean_up:	proc;

	     if ptr_array (1) ^= null then call release_temp_segments_ (name, ptr_array, code);
	     return;

	end clean_up;

%include debug_fnp_data;

%include cds_args;
     end db_fnp_opcodes_;




		    db_fnp_reader_.pl1              11/15/82  1816.2rew 11/15/82  1502.1       84159



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


/* DB_FNP_READER_ - Contains entries for reading and parsing debug_fnp commands */

/* Written February 1977 by Larry Johnson */
/* Rewritten January 1978 by Larry Johnson to support multiple commands on a line */

db_fnp_reader_: proc;

/* Arguments */

dcl  arg_cmd_infop ptr;				/* Pointer to command data */

/* Automatic */

dcl  code fixed bin (35);
dcl  inlen fixed bin (21);
dcl  i fixed bin;
dcl  have_cmd_start bit (1);

dcl  next_char char (1) based (cmd_info.commandp);

/* Constants */

dcl  name char (14) int static options (constant) init ("db_fnp_reader_");
dcl  nl char (1) int static options (constant) init ("
");

/* External stuff */

dcl  iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  sub_err_ entry options (variable);
dcl  ioa_ entry options (variable);

dcl  iox_$user_input ext ptr;

dcl (addr, index, length, null, search, substr, verify) builtin;

/* Entry to read command line */

get_command: entry (arg_cmd_infop);

	cmd_infop = arg_cmd_infop;

	have_cmd_start = "0"b;
get_command_retry:
	cmd_info.endline, cmd_info.error, cmd_info.opstring = "0"b;

/* Find first character in command name */

get_command_startx:
	go to get_command_start (next_char_type ());
get_command_start (0):				/* Data char */
	if have_cmd_start then go to get_command_name;	/* Good start */
get_command_start (4):				/* White space */
	call skip_char;				/* Flush till command starts */
	go to get_command_startx;
get_command_start (1):				/* Quote */
get_command_start (2):				/* Apostrophe */
	go to bad_command_char;			/* These are invalid */
get_command_start (3):				/* Semi-colon */
	call skip_char;
	have_cmd_start = "1"b;			/* Next char will start command name */
	go to get_command_startx;
get_command_start (5):				/* End of line */
	call iox_$get_line (iox_$user_input, addr (cmd_info.inbuf), length (cmd_info.inbuf), inlen, code);
	if code ^= 0 then do;
	     cmd_info.flush = "1"b;
	     call sub_err_ (code, name, "h", null, (0), "Unable to read from user_input");
	     go to get_command_retry;
	end;
	if inlen > 0 then if substr (cmd_info.inbuf, inlen, 1) = nl then inlen = inlen - 1;
	cmd_info.commandp = addr (cmd_info.inbuf);	/* Start new command scan */
	cmd_info.commandl = inlen;
	have_cmd_start = "1"b;			/* Next char can start command */
	cmd_info.flush = "0"b;
	go to get_command_startx;

/* Count characters in command name */

get_command_name:
	cmd_info.operandp = cmd_info.commandp;		/* Start of name */
	cmd_info.operandl = 0;
get_command_charx:
	go to get_command_char (next_char_type ());
get_command_char (0):				/* Data char */
	cmd_info.operandl = cmd_info.operandl + 1;	/* Include in name */
	call skip_char;
	if cmd_info.operandl = 1 then			/* If first character */
	     if operand = "=" then return;		/* Don't required whitespace after '=' command */
	go to get_command_charx;
get_command_char (1):				/* Quote */
get_command_char (2):				/* Apostrophe */
	go to bad_command_char;
get_command_char (3):				/* Semi-colon */
get_command_char (4):				/* White space */
get_command_char (5):				/* End of line */
	if cmd_info.operandl = 0 then go to get_command_retry; /* Start all over if null command */
	else return;				/* Otherwise command name is now found */

bad_command_char:
	call ioa_ ("Invalid ^a in command name.", next_char);
	cmd_info.flush = "1"b;
	go to get_command_retry;

/* Entry to get one operand from command line */

get_operand: entry (arg_cmd_infop);

	cmd_infop = arg_cmd_infop;
	cmd_info.opstring, cmd_info.endline, cmd_info.error = "0"b;
	cmd_info.operandp = null;
	cmd_info.operandl = 0;

/* Find start of an operand */

get_operand_startx:
	go to get_operand_start (next_char_type ());
get_operand_start (0):				/* Data char */
	cmd_info.operandp = cmd_info.commandp;		/* Operand starts here */
	go to get_operand_charx;
get_operand_start (1):				/* Quote */
	go to get_operand_quote;			/* Handel quoted operand */
get_operand_start (2):				/* Apostrophe */
	go to get_operand_apost;			/* Handle apostrophed operand */
get_operand_start (3):				/* Semi-colon */
get_operand_start (5):				/* End of line */
	cmd_info.endline = "1"b;			/* No more operands */
	return;
get_operand_start (4):				/* White space */
	call skip_char;
	go to get_operand_startx;			/* Keep looking */

/* Regular vanilla operand. count its characters */

get_operand_charx:
	go to get_operand_char (next_char_type ());
get_operand_char (0):				/* Data char */
	cmd_info.operandl = cmd_info.operandl + 1;	/* Operand 1 longer */
	call skip_char;
	go to get_operand_charx;
get_operand_char (1):				/* Quote */
get_operand_char (2):				/* Apostrophe */
	call ioa_ ("Invalid ^a in middle of operand", next_char);
	go to operand_err;
get_operand_char (3):				/* Semi colon */
get_operand_char (4):				/* White space */
get_operand_char (5):				/* End of line */
	return;					/* All indicate end of operand */

/* Here when operand starts with quuote. A dequoted version is reconstructed. */

get_operand_quote:
	cmd_info.operandp = addr (cmd_info.opbuf);	/* Will build unquoted string here */
	cmd_info.opstring = "1"b;
	call skip_char;
get_quote_charx:
	go to get_quote_char (next_char_type ());
get_quote_char (0):					/* Data char */
get_quote_char (2):					/* Apostrophe */
get_quote_char (3):					/* Semi colon */
get_quote_char (4):					/* White space */
	cmd_info.operandl = cmd_info.operandl + 1;	/* All are operand characters */
	substr (operand, cmd_info.operandl, 1) = next_char;
	call skip_char;
	go to get_quote_charx;
get_quote_char (5):					/* End of line */
	call ioa_ ("Unmatched quotes");
	go to operand_err;
get_quote_char (1):					/* Quote */
	call skip_char;				/* May be double quote or end of string */

/* Be sure quoted string terminates correctly */

	go to char_after_quote (next_char_type ());
char_after_quote (0):				/* Data char */
char_after_quote (2):				/* Apostrophe */
	call ioa_ ("Invalid ^a after quoted string", next_char);
	go to operand_err;
char_after_quote (1):				/* Quote */
	go to get_quote_char (0);			/* Treat as quote data char */
char_after_quote (3):				/* Semi colon */
char_after_quote (4):				/* White space */
char_after_quote (5):				/* End of line */
	return;					/* All are valid end of quoted string */

/* Here when operand starts with apostrophe. count its characters */

get_operand_apost:
	cmd_info.operandl = 1;			/* Include apostrophe in operand */
	cmd_info.operandp = cmd_info.commandp;
	call skip_char;
get_apost_charx:
	go to get_apost_char (next_char_type ());
get_apost_char (0):					/* Data char */
get_apost_char (4):					/* White space */
	cmd_info.operandl = cmd_info.operandl + 1;	/* Treat as data */
	call skip_char;
	go to get_apost_charx;
get_apost_char (1):					/* Quote */
get_apost_char (3):					/* Semi colon */
	call ioa_ ("Invalid ^a in apostrophed string", next_char);
	go to operand_err;
get_apost_char (5):					/* End of line */
	call ioa_ ("Unmatched apostrophes");
	go to operand_err;
get_apost_char (2):					/* Should be closing apostrophe */
	cmd_info.operandl = cmd_info.operandl + 1;
	call skip_char;

/* Be sure qpostrophed string ends correctly */

	go to char_after_apost (next_char_type ());
char_after_apost (0):				/* Data char */
char_after_apost (1):				/* Quote */
char_after_apost (2):				/* Apostrophe */
	call ioa_ ("Invalid ^a after apostrophed string", next_char);
	go to operand_err;
char_after_apost (3):				/* Sime colon */
char_after_apost (4):				/* White space */
char_after_apost (5):				/* End of line */
	return;					/* All valid ends of apostrophed operand */

/* Here when some error deteched in the operand */

operand_err:
	cmd_info.error = "1"b;
	cmd_info.flush = "1"b;
	return;

/* Function which returns a code indicating the type of the next character on the command line */
/* Codes are:
   0 = data character
   1 = quote
   2 = apostrophe
   3 = semi-colon
   4 = white space
   5 = end of line */

next_char_type: proc returns (fixed bin);

	     if cmd_info.flush then return (5);		/* End of line */
	     if cmd_info.commandl = 0 then return (5);
	     if next_char = """" then return (1);
	     if next_char = "'" then return (2);
	     if next_char = ";" then return (3);
	     if next_char = " " | next_char = "	" | next_char = nl then return (4);
	     if unspec (next_char) = "014"b3 then return (4);
	     return (0);				/* Must be data */

	end next_char_type;


/* Skip next char in input stream */

skip_char: proc;

	     cmd_info.commandp = substraddr (command, 2);
	     cmd_info.commandl = cmd_info.commandl - 1;
	     return;

	end skip_char;

/* Simulate substraddr builtin temporarily */

substraddr: proc (c, n) returns (ptr);

dcl  c char (*);
dcl  n fixed bin;
dcl  ca (n) char (1) unal based (addr (c));

	     return (addr (ca (n)));

	end substraddr;

%include debug_fnp_data;
     end db_fnp_reader_;




		    db_fnp_scheduler_.pl1           11/15/82  1816.2rew 11/15/82  1449.4      218736



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


/* DB_FNP_SCHEDULER_ - Implements various command related to the scheduler */

/* Written January 1979 by Larry Johnson */
/* Modified December 1981 by Robert Coren for revised idle meters */
/* Modified March 1982 by Robert Coren to add meters for time spent in buffer management */

/* format: style4,delnl,insnl,^ifthendo */
db_fnp_scheduler_:
     proc;

/* Parameters */

dcl  arg_corep ptr;
dcl  arg_fnp fixed bin;
dcl  arg_expr_infop ptr;
dcl  arg_cmd_infop ptr;
dcl  arg_code fixed bin (35);

/* Automatic */

dcl  corep ptr;
dcl  fnp fixed bin;
dcl  theoretical_max fixed bin (35);
dcl  x float bin;
dcl  total_count fixed bin (71);
dcl  (i, j) fixed bin;
dcl  min_j fixed bin;
dcl  mix_offset fixed bin;
dcl  offset fixed bin;
dcl  module_counts (50) fixed bin (71);
dcl  icmdat_addr fixed bin;
dcl  icmdat_addr_known bit (1) init ("0"b);
dcl  skdata_addr fixed bin;
dcl  code fixed bin (35);
dcl  buf_meter_addr fixed bin;
dcl  data_high fixed bin;
dcl  datap ptr init (null);
dcl  table_base fixed bin;
dcl  table_mult fixed bin;
dcl  min_offset fixed bin;
dcl  ic_addr fixed bin;
dcl  line_length fixed bin;
dcl  hist_len fixed bin;
dcl  max_hits fixed bin (35);
dcl  scale float bin;
dcl  edited_addr char (32) var;
dcl  fraction_to_print float bin;
dcl  hits_removed fixed bin (71);
dcl  hits_to_remove fixed bin (71);
dcl  min_hits fixed bin (35);
dcl  n_min_hits fixed bin;
dcl  fnp_word (1) fixed bin (17) unal;
dcl  something_printed bit (1);
dcl  first_exec_found bit (1);
dcl  dsptabp ptr;
dcl  savtabp ptr;
dcl  skdata_count fixed bin;
dcl  sched_dsptabp ptr init (null);
dcl  sched_savtabp ptr init (null);
dcl  reset_sw bit (1);
dcl  delta_cycles fixed bin (35);
dcl  delta_idle_count fixed bin (35);
dcl  alloc_time fixed bin (35);
dcl  alloc_updates fixed bin (35);
dcl  alloc_more_than_1 fixed bin (35);
dcl  free_time fixed bin (35);
dcl  free_updates fixed bin (35);
dcl  free_more_than_1 fixed bin (35);
dcl  total_time fixed bin (35);
dcl  avg_alloc_time float bin;
dcl  avg_free_time float bin;
dcl  avg_all_time float bin;
dcl  pct_alloc float bin;
dcl  pct_free float bin;
dcl  pct_alloc_non_idle float bin;
dcl  pct_free_non_idle float bin;
dcl  idle_fraction float bin;

dcl  1 modch aligned,
       2 nmodules fixed bin,
       2 entries (50),
         3 name char (4),
         3 address fixed bin;

dcl  1 skdata,					/* Format of data block in scheduler, pointed to by .crskd */
       2 total_idle_count bit (36),			/* Cumulative total of idle count */
       2 idle_increments bit (36),			/* Number of increments to idle counter */
       2 max_idle_count bit (36),			/* Maximum value of idle counter */
       2 min_idle_count bit (36),			/* Minimum value of idle counter */
       2 interval bit (18),				/* Number of millisecond to start timer with */
       2 icmdat_addr bit (18),			/* Address of icmdat in ic_sampler module */
       2 count bit (18),				/* Number of master dispatcher levels */
       2 dsptab_addr bit (18),			/* Address of master dispatcher table */
       2 savtab_addr bit (18);			/* Address of master dispatcher save area */

dcl  1 icmdat,					/* Format of data block in ic_sampler */
       2 action bit (18),				/* Set code here to request action */
       2 confirm bit (18),				/* Result of action reported here */
       2 enable bit (18),				/* If non-zero, ic_sampling enabled */
       2 table_addr bit (18),				/* Address of table of results */
       2 table_len bit (18),				/* Length of table in words */
       2 shift bit (18),				/* Amount addresses are shifted before counting */
       2 base bit (18),				/* Lowest address monitored */
       2 pad bit (18),
       2 out_of_range bit (36),			/* Count of ic's out of bucket range */
       2 discnt bit (36);				/* Count of ic's and scheduler dis instruction */

dcl  1 buf_meters aligned,
       2 allocate like subr_time_meters,
       2 free like subr_time_meters;

/* Based */

dcl  system_area area based (areap);
dcl  data (0:data_high) bit (36) based (datap);

dcl  1 sched_dsptab unal based (sched_dsptabp),		/* Master dispatchers control table */
       2 dsptab (skdata_count) unal like dsptab;

dcl  1 dsptab unal based (dsptabp),
       2 request bit (1),				/* Level requested to run */
       2 execution bit (1),				/* Level in execution, or interrupted */
       2 secondary_entry_present bit (1),
       2 suppression bit (15),
       2 primary_entry bit (18),
       2 secondary_entry bit (18),
       2 request_count bit (18);

dcl  1 sched_savtab unal based (sched_savtabp),		/* Master dispatchers register save area */
       2 savtab (skdata_count) unal like savtab;

dcl  1 savtab unal based (savtabp),
       2 x1 bit (18),
       2 x2 bit (18),
       2 x3 bit (18),
       2 a bit (18),
       2 q bit (18),
       2 ind bit (18),
       2 ic bit (18),
       2 pad bit (18);

dcl  1 subr_time_meters based aligned,
       2 total_time fixed bin (35),
       2 increments fixed bin (35),
       2 instances_over_1 fixed bin (35),
       2 maximum_time fixed bin;

/* External */

dcl  ioa_ entry options (variable);
dcl  com_err_ entry options (variable);
dcl  sub_err_ entry options (variable);
dcl  get_system_free_area_ entry returns (ptr);
dcl  timer_manager_$sleep entry (fixed bin (71), bit (2));
dcl  get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin);
dcl  db_fnp_sym_util_$get_value entry (char (*)) returns (fixed bin);
dcl  db_fnp_util_$get_special_modch entry (ptr, fixed bin, ptr, fixed bin (35));
dcl  db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35));
dcl  db_fnp_memory_$store entry (ptr, fixed bin, fixed bin, fixed bin, ptr, char (*), fixed bin, fixed bin (35));
dcl  db_fnp_reader_$get_operand entry (ptr);
dcl  db_fnp_util_$edit_module_addr_force entry (ptr, fixed bin, fixed bin, char (*) var, fixed bin (35));

dcl  iox_$user_output ext ptr;
dcl  error_table_$unimplemented_version ext fixed bin (35);

dcl  cleanup condition;
dcl  conversion condition;

dcl  (addr, bin, bit, divide, fixed, float, hbound, lbound, length, max, min, null, string) builtin;

/* Static */

dcl  crskd fixed bin int static;
dcl  crbtm fixed bin int static;
dcl  etmb fixed bin int static;
dcl  areap ptr int static init (null);
dcl  constants_setup bit (1) int static init ("0"b);
dcl  saved_idle_increments (8) fixed bin (35) int static init ((8) 0);
dcl  saved_idle_count (8) fixed bin (35) int static init ((8) 0);

dcl  1 saved_buf_meters (8) aligned internal static like buf_meters;

/* Constants */

dcl  name char (17) int static options (constant) init ("db_fnp_scheduler_");

dcl  mdisp_desc (7) char (20) int static options (constant) init (
						/* Names of master dispatcher levels */
	"lsla", "dia terminate", "dia special", "hsla", "interval timer", "console", "secondary dispatcher");

dcl  state_msgs (0:7) char (32) int static options (constant) init (
						/* State descriptions derived from some bits */
						/* Req exec first_exec_fnd */
	"",					/* 0   0    0 */
	"",					/* 0   0    1 */
	"In execution",				/* 0   1    0 */
	"Interrupt",				/* 0   1    1 */
	"Requested",				/* 1   0    0 */
	"Requested",				/* 1   0    1 */
	"Requested, in execution",			/* 1   1    0 */
	"Requested, interrupted");			/* 1   1    1 */

/* Entry to read and print the idle time accumulated in the fnp */

idle_time:
     entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;

	call get_operand;
	if cmd_info.endline
	then reset_sw = "0"b;
	else if operand = "-reset" | operand = "-rs"
	then do;
	     if corep ^= null ()
	     then do;
		call ioa_ ("Option -reset only allowed on running FNP.");
		go to error_return;
	     end;
	     reset_sw = "1"b;
	end;
	else do;
	     call ioa_ ("Invalid operand: ^a", operand);
	     go to error_return;
	end;

	call read_skdata;

	call fetch (crbtm, 1, addr (fnp_word));
	buf_meter_addr = bin (fnp_word (1));
	if buf_meter_addr = 0
	then do;
	     call ioa_ ("Buffer management meters not available.");
	     return;
	end;

	call fetch (buf_meter_addr, 16, addr (buf_meters));

	if corep = null ()
	then do;					/* Live fnp */
	     delta_cycles = bin (skdata.idle_increments) - saved_idle_increments (fnp);
	     delta_idle_count = bin (skdata.total_idle_count) - saved_idle_count (fnp);
	     alloc_time = buf_meters.allocate.total_time - saved_buf_meters (fnp).allocate.total_time;
	     alloc_updates = buf_meters.allocate.increments - saved_buf_meters (fnp).allocate.increments;
	     alloc_more_than_1 =
		buf_meters.allocate.instances_over_1 - saved_buf_meters (fnp).allocate.instances_over_1;
	     free_time = buf_meters.free.total_time - saved_buf_meters (fnp).free.total_time;
	     free_updates = buf_meters.free.increments - saved_buf_meters (fnp).free.increments;
	     free_more_than_1 = buf_meters.free.instances_over_1 - saved_buf_meters (fnp).free.instances_over_1;
	end;
	else do;
	     delta_cycles = bin (skdata.idle_increments);
	     delta_idle_count = bin (skdata.total_idle_count);
	     alloc_time = buf_meters.allocate.total_time;
	     alloc_updates = buf_meters.allocate.increments;
	     alloc_more_than_1 = buf_meters.allocate.instances_over_1;
	     free_time = buf_meters.free.total_time;
	     free_updates = buf_meters.free.increments;
	     free_more_than_1 = buf_meters.free.instances_over_1;
	end;
	theoretical_max = delta_cycles * bin (skdata.max_idle_count, 36);
	if theoretical_max = 0
	then call ioa_ ("No samples");
	else do;
	     idle_fraction = float (delta_idle_count) / float (theoretical_max);
	     call ioa_ ("Idle time: ^.1f%", 1.0e2 * idle_fraction);
	end;

	total_time = delta_cycles * 1000;
	avg_alloc_time = float (alloc_time) / float (alloc_updates);
	avg_free_time = float (free_time) / float (free_updates);
	avg_all_time = float (alloc_time + free_time) / float (alloc_updates + free_updates);
	pct_alloc = 1.0e2 * float (alloc_time) / float (total_time);
	pct_free = 1.0e2 * float (free_time) / float (total_time);
	pct_alloc_non_idle = pct_alloc / (1.0 - idle_fraction);
	pct_free_non_idle = pct_free / (1.0 - idle_fraction);

	call ioa_ ("Time in buffer management routines^/^32tallocate^44tfree^53ttotal");
	call ioa_ ("Average time per call (msec.)^35t^4.1f^44t^4.1f^54t^4.1f", avg_alloc_time, avg_free_time,
	     avg_all_time);
	call ioa_ ("Percent of FNP^35t^4.1f^44t^4.1f^54t^4.1f", pct_alloc, pct_free, pct_alloc + pct_free);
	call ioa_ ("Percent of non-idle^35t^4.1f^44t^4.1f^54t^4.1f", pct_alloc_non_idle, pct_free_non_idle,
	     pct_alloc_non_idle + pct_free_non_idle);
	call ioa_ ("Percent of calls > 1 msec.^35t^4.1f^44t^4.1f^54t^4.1f",
	     1.0e2 * float (alloc_more_than_1) / float (alloc_updates),
	     1.0e2 * float (free_more_than_1) / float (free_updates),
	     1.0e2 * float (alloc_more_than_1 + free_more_than_1) / float (alloc_updates + free_updates));
	call ioa_ ("Maximum single call (msec.)^35t^4d^44t^4d", buf_meters.allocate.maximum_time,
	     buf_meters.free.maximum_time);

	if reset_sw
	then do;
	     saved_idle_increments (fnp) = bin (skdata.idle_increments);
	     saved_idle_count (fnp) = bin (skdata.total_idle_count);
	     saved_buf_meters (fnp) = buf_meters;
	end;

	return;

/* SAMPLE_TIME Command - Sets or prints the scheduler sampling interval */

sample_time:
     entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;

	call get_operand;
	if cmd_info.endline
	then do;					/* No operands - so print it */
	     call read_skdata;
	     call ioa_ ("Sample interval: ^d msec.", bin (skdata.interval));
	     return;
	end;

	on conversion go to bad_interval;
	i = bin (operand);				/* Get new time */
	if i < 1 | i > 1000
	then do;
bad_interval:
	     call ioa_ ("Bad sample interval: ^a", operand);
	     go to error_return;
	end;

	if corep ^= null ()
	then do;
	     call ioa_ ("Sample time can only be set on running FNP.");
	     go to error_return;
	end;

	call read_skdata;				/* Just to be sure its the right scheduler */
	fnp_word (1) = -i;				/* elapsed timer counts up, so this has to be negative */
	call store (skdata_addr + fnp_offset (addr (skdata), addr (skdata.interval)), 1, addr (fnp_word));
	return;

/* IC_SAMPLE Command - Summarize data in various ways */

ic_sample:
     entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;
	call get_operand;
	if cmd_info.endline
	then do;
	     call ioa_ ("Argument missing.");
	     go to error_return;
	end;

	if operand = "start"
	then call perform_action (1);
	else if operand = "stop"
	then call perform_action (2);
	else if operand = "reset"
	then call perform_action (3);
	else if operand = "module"
	then go to ic_sample_module;
	else if operand = "histogram" | operand = "hist"
	then go to ic_sample_hist;
	else do;
	     call ioa_ ("Unrecognized option: ^a", operand);
	     go to error_return;
	end;
	return;

/* Summarize data by module */

ic_sample_module:
	on cleanup call clean_up;
	modch.nmodules = hbound (modch.entries, 1);
	call db_fnp_util_$get_special_modch (corep, fnp, addr (modch), code);
	if code ^= 0
	then do;
	     call com_err_ (code, name, "Unable to get module chain.");
	     go to error_return;
	end;

	call read_data;

	module_counts (*) = 0;
	total_count = bin (icmdat.discnt) + bin (icmdat.out_of_range);

	do i = lbound (data, 1) to hbound (data, 1);	/* Check each entry */
	     if data (i) ^= "0"b
	     then do;
		total_count = total_count + bin (data (i));
		ic_addr = i * table_mult + table_base;	/* Address represented by bucket */
		min_offset = 100000;
		min_j = -1;
		do j = 1 to modch.nmodules;		/* Find which module it is in */
		     offset = ic_addr - modch.address (j);
		     if offset >= 0 & offset < min_offset
		     then do;
			min_offset = offset;
			min_j = j;
		     end;
		end;
		if min_j > 0
		then module_counts (min_j) = module_counts (min_j) + bin (data (i));
	     end;
	end;

	if total_count = 0
	then do;
	     call ioa_ ("No data collected.");
	     go to ic_sample_module_return;
	end;
	do i = 1 to modch.nmodules;
	     if module_counts (i) > 0
	     then call ioa_ ("^6a^5.1f%", modch.name (i), 1.00e2 * float (module_counts (i)) / float (total_count));
	end;

	if icmdat.out_of_range ^= "0"b
	then call ioa_ ("^/^6a^5.1f%", "orange", 1.00e2 * float (bin (icmdat.out_of_range)) / float (total_count));

	call ioa_ ("^/^6a^5.1f%", "idle", 1.00e2 * float (bin (icmdat.discnt)) / float (total_count));

ic_sample_module_return:
	call clean_up;
	return;

/* Print a histogram of all data buckets */

ic_sample_hist:
	call get_operand;
	if cmd_info.endline
	then fraction_to_print = 1.0;			/* Print entire histogram */
	else do;
	     on conversion go to bad_fraction;
	     fraction_to_print = float (operand);
	     if fraction_to_print < 0.0 | fraction_to_print > 1.0
	     then do;
bad_fraction:
		call ioa_ ("Invalid fraction to print: ^a", operand);
		go to error_return;
	     end;
	end;

	on cleanup call clean_up;

	call read_data;

	line_length = get_line_length_$switch (iox_$user_output, code);
	if code ^= 0
	then line_length = 132;
	if line_length < 20
	then do;
	     call ioa_ ("Line length (^d) is too short.", line_length);
	     go to ic_sample_hist_return;
	end;
	hist_len = line_length - 18;			/* Amount of line available for chart */

	max_hits = 0;				/* Find largest bucket */
	total_count = 0;
	do i = lbound (data, 1) to hbound (data, 1);
	     if bin (data (i)) > max_hits
	     then max_hits = bin (data (i));
	     total_count = total_count + bin (data (i));
	end;

	if max_hits = 0
	then do;
	     call ioa_ ("No data collected.");
	     go to ic_sample_hist_return;
	end;
	scale = float (max_hits) / float (hist_len);

	if fraction_to_print < 1.0
	then do;					/* Must trim small buckets */
	     hits_to_remove = (1.0 - fraction_to_print) * float (total_count);
	     hits_removed = 0;
	     do while (hits_removed < hits_to_remove);
		min_hits = max_hits;		/* First, find smallest number */
		n_min_hits = 0;
		do i = lbound (data, 1) to hbound (data, 1);
		     if data (i) ^= "0"b
		     then if bin (data (i)) < min_hits
			then do;
			     min_hits = bin (data (i));
			     n_min_hits = 1;
			end;
			else if bin (data (i)) = min_hits
			then n_min_hits = n_min_hits + 1;
		end;
		hits_removed = hits_removed + n_min_hits * min_hits;
		if hits_removed <= hits_to_remove
		then				/* Remove all instances of the minimum */
		     do i = lbound (data, 1) to hbound (data, 1);
						/* Unless it would go over limit */
		     if bin (data (i)) = min_hits
		     then data (i) = "0"b;
		end;
	     end;
	end;

	do i = lbound (data, 1) to hbound (data, 1);
	     if data (i) ^= "0"b
	     then do;
		j = fixed (float (bin (data (i))) / scale);
		j = min (max (1, j), hist_len);	/* Keep it in range */
		ic_addr = table_base + i * table_mult;
		call db_fnp_util_$edit_module_addr_force (corep, fnp, ic_addr, edited_addr, code);
		if code ^= 0
		then do;
		     call com_err_ (code, name, "Unable to convert address ^o.", ic_addr);
		     go to ic_sample_hist_return;
		end;
		x = 1.00e2 * float (bin (data (i))) / float (total_count);
		call ioa_ ("^12a^5.1f ^v(*^)", edited_addr, x, j);
	     end;
	end;

ic_sample_hist_return:
	call clean_up;
	return;

/* MDISP_DATA - Command to print master dispatcher data bases */

mdisp_data:
     entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;
	on cleanup call clean_up;

	call read_skdata;
	skdata_count = bin (skdata.count);		/* Number of dispatcher levels */
	allocate sched_dsptab in (system_area);
	allocate sched_savtab in (system_area);

	i = divide (length (string (sched_dsptab)), 18, 17, 0);
	call fetch (bin (skdata.dsptab_addr), i, sched_dsptabp);
	i = divide (length (string (sched_savtab)), 18, 17, 0);
	call fetch (bin (skdata.savtab_addr), i, sched_savtabp);

	first_exec_found = "0"b;			/* Remember previous instances of dsptab.exec */
	something_printed = "0"b;
	do i = 1 to skdata_count;
	     dsptabp = addr (sched_dsptab.dsptab (i));
	     if dsptab.request | dsptab.execution
	     then do;
		savtabp = addr (sched_savtab.savtab (i));
		something_printed = "1"b;
		call ioa_ ("Level ^d: ^a", i, mdisp_desc (i));
		j = bin (dsptab.request || dsptab.execution || first_exec_found);
						/* Compute msg index */
		call ioa_ (" ^a", state_msgs (j));
		if dsptab.execution & first_exec_found
		then do;				/* Found interrupted level */
		     call ioa_ ("  aq ^.3b ^.3b", savtab.a, savtab.q);
		     call ioa_ ("  x1 ^.3b", savtab.x1);
		     call ioa_ ("  x2 ^.3b", savtab.x2);
		     call ioa_ ("  x3 ^.3b", savtab.x3);
		     call ioa_ ("  i  ^.3b", savtab.ind);
		     call ioa_ ("  ic ^.3b", savtab.ic);
		end;
		if dsptab.execution
		then first_exec_found = "1"b;
	     end;
	end;

	if ^something_printed
	then call ioa_ ("FNP was idling");
	call clean_up;
	return;

/* Setup arguments */

setup:
     proc;

	corep = arg_corep;
	fnp = arg_fnp;
	expr_infop = arg_expr_infop;
	cmd_infop = arg_cmd_infop;
	call setup_constants;
	return;

     end setup;

setup_constants:
     proc;

	if constants_setup
	then return;

	crskd = db_fnp_sym_util_$get_value (".crskd");
	crbtm = db_fnp_sym_util_$get_value (".crbtm");
	etmb = db_fnp_sym_util_$get_value ("etmb");
	areap = get_system_free_area_ ();
	unspec (saved_buf_meters) = "0"b;
	constants_setup = "1"b;
	return;

     end setup_constants;

clean_up:
     proc;

	if datap ^= null ()
	then free data;
	if sched_dsptabp ^= null ()
	then free sched_dsptab;
	if sched_savtabp ^= null ()
	then free sched_savtab;
	return;

     end clean_up;

error_return:					/* Non-local error exit */
	call clean_up;
	cmd_info.flush = "1"b;
	return;

/* Read and write memory words */

fetch:
     proc (a, n, p);

dcl  a fixed bin;
dcl  n fixed bin;
dcl  p ptr;

	call db_fnp_memory_$fetch (corep, fnp, a, n, p, code);
	if code = 0
	then return;
	if n = 1
	then call com_err_ (code, name, "Unable to read location ^o.", a);
	else call com_err_ (code, name, "Unable to read locations ^o thru ^o", a, a + n - 1);
	go to error_return;

store:
     entry (a, n, p);

	call db_fnp_memory_$store (corep, fnp, a, n, p, name, 0, code);
	if code = 0
	then return;
	if n = 1
	then call com_err_ (code, name, "Unable to write location ^o.", a);
	else call com_err_ (code, name, "Unable to write locations ^o thru ^o", a, a + n - 1);
	go to error_return;

     end fetch;

/* Get next operand from command line */

get_operand:
     proc;

	call db_fnp_reader_$get_operand (cmd_infop);
	if cmd_info.error
	then go to error_return;
	return;

     end get_operand;

/* Read data block in scheduler module */

read_skdata:
     proc;

dcl  i fixed bin;
dcl  fnp_word (1) bit (18) unal;

	call fetch (crskd, 1, addr (fnp_word));
	skdata_addr = bin (fnp_word (1));		/* Address of table */
	if skdata_addr = 0
	then do;
	     call ioa_ ("Scheduler data not found.");	/* Probably old core image */
	     go to error_return;
	end;
	i = divide (length (string (skdata)), 18, 17, 0); /* Number of fnp words to read */
	call fetch (skdata_addr, i, addr (skdata));
	icmdat_addr = bin (skdata.icmdat_addr);
	icmdat_addr_known = "1"b;
	return;

     end read_skdata;

/* Read data table in ic_sampler module */

read_icmdat:
     proc;

dcl  i fixed bin;
dcl  fnp_word (1) bit (18) unal;

	if ^icmdat_addr_known
	then call read_skdata;
	if icmdat_addr = 0
	then do;
	     call ioa_ ("IC sampling module not configured.");
	     go to error_return;
	end;

	i = divide (length (string (icmdat)), 18, 17, 0);
	call fetch (icmdat_addr, i, addr (icmdat));
	return;

     end read_icmdat;

/* Read the acutal table of ic samples */

read_data:
     proc;

	call read_icmdat;
	if icmdat.table_addr = "0"b | icmdat.table_len = "0"b
	then do;
	     call ioa_ ("No ic sample table found.");
	     go to error_return;
	end;

	data_high = divide (bin (icmdat.table_len), 2, 17, 0) - 1;
	allocate data in (system_area);
	call fetch (bin (icmdat.table_addr), bin (icmdat.table_len), datap);
	table_base = bin (icmdat.base);
	table_mult = 2 ** bin (icmdat.shift);
	return;

     end read_data;

/* Procedure to perform an order to the ic_sampler module */
/* We store an action for it to do, and wait for it to notice it */

perform_action:
     proc (act);

dcl  act fixed bin;

dcl  i fixed bin;
dcl  fnp_word (1) bit (18) unal;

	if corep ^= null ()
	then do;
	     call ioa_ ("Only valid on running FNP.");
	     go to error_return;
	end;

	call read_icmdat;
	fnp_word (1) = "0"b;			/* Reset the conformation word */
	call store (icmdat_addr + fnp_offset (addr (icmdat), addr (icmdat.confirm)), 1, addr (fnp_word));
	fnp_word (1) = bit (bin (act, 18), 18);		/* Set action */
	call store (icmdat_addr + fnp_offset (addr (icmdat), addr (icmdat.action)), 1, addr (fnp_word));
	call fetch (etmb, 1, addr (fnp_word));		/* Read remaining time in timer */
	i = min (1000, 262144 - bin (fnp_word (1)));	/* Compute sleep time */
	call timer_manager_$sleep (1000 * (i + 50), "10"b);
	call read_icmdat;
	if icmdat.confirm = "000001"b3
	then return;				/* It worked */
	if icmdat.confirm = "000000"b3
	then do;
	     call ioa_ ("FNP did not respond to action ^d.", act);
	     go to error_return;
	end;
	call ioa_ ("FNP gave error confirmation ^d.", bin (icmdat.confirm));
	go to error_return;

     end perform_action;

/* Procedure that computes the offset between two Multics pointers in terms of
   18-bit FNP words. */

fnp_offset:
     proc (p1, p2) returns (fixed bin);

dcl  (p1, p2) ptr;
dcl  fnp_mem (0:127) bit (18) unal based (p1);		/* A piece of FNP memory */
dcl  i fixed bin;

	do i = lbound (fnp_mem, 1) to hbound (fnp_mem, 1);
	     if addr (fnp_mem (i)) = p2
	     then return (i);
	end;
	call sub_err_ (code, name, "s", null (), (0), "Unable to compute the offset between ^p and ^p", p1, p2);
	return (100000);

     end fnp_offset;

%include debug_fnp_data;

     end db_fnp_scheduler_;




		    db_fnp_sym_util_.pl1            11/15/82  1816.2rew 11/15/82  1502.2       80082



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


/* DB_FNP_SYM_UTIL_ - Manages debug_fnp symbol tables */

/* Written February 1977 by Larry Johnson */
/* Modified August 1979 by Larry Johnson for apropos command */

db_fnp_sym_util_: proc;

/* Arguments */

dcl  arg_sym char (*);
dcl  arg_symp ptr;
dcl  arg_user_tablep ptr;
dcl  arg_expr_infop ptr;
dcl  arg_corep ptr;
dcl  arg_fnp fixed bin;
dcl  arg_cmd_infop ptr;
dcl  arg_member char (*);
dcl  arg_value fixed bin;

/* Automatic */

dcl (i, j) fixed bin;
dcl  req bit (1) init ("0"b);
dcl  set_sym_name char (6);
dcl  set_sym_value fixed bin;
dcl  code fixed bin (35);
dcl  apropos_listp ptr;
dcl  apr_cnt fixed bin;
dcl  found bit (1);

/* Based */

dcl  apropos_list (32) char (32) var based (apropos_listp);
dcl  based_area area based;

/* Constants */

dcl  name char (16) int static options (constant) init ("db_fnp_sym_util_");

/* External */

dcl  sub_err_ entry options (variable);
dcl  ioa_ entry options (variable);
dcl  db_fnp_reader_$get_operand entry (ptr);
dcl  db_fnp_eval_ entry (ptr, fixed bin, char (*), ptr, char (*), fixed bin, fixed bin (35));
dcl  get_system_free_area_ entry returns (ptr);

dcl  cleanup condition;

dcl (addr, addrel, hbound, index, null, unspec) builtin;

/* Entry to lookup a name in the standard symbol table */

lookup:	entry (arg_sym, arg_symp);


lookup_start:
	symbol_tablep = addr (db_fnp_symbols_$db_fnp_symbols_);

lookup_join:
	do i = 1 to symbol_table.cnt;
	     symp = addr (symbol_table.entry (i));
	     if arg_sym = sym.name then do;
		arg_symp = symp;
		return;
	     end;
	end;
	if req then call sub_err_ (0, name, "s", null, (0), "Unable to get value for FNP symbol ""^a"".", arg_sym);
	arg_symp = null;				/* Convertion meaning not found */
	return;


/* This entry is called by people who wont take no for an answer */

lookup_req: entry (arg_sym, arg_symp);

	req = "1"b;
	go to lookup_start;


/* Entry to lookup symbol in users symbol table */

lookup_user: entry (arg_user_tablep, arg_sym, arg_symp);

	symbol_tablep = arg_user_tablep;
	if symbol_tablep = null then do;
	     arg_symp = null;
	     return;
	end;
	else go to lookup_join;


/* Functions for returns values and lengths. these are not allowed to fail */

get_value: entry (arg_sym) returns (fixed bin);

	call lookup_req (arg_sym, symp);
	return (sym.value);

get_length: entry (arg_sym) returns (fixed bin);

	call lookup_req (arg_sym, symp);
	return (sym.len);

/* This entry, given a flag type and a value, returns the symbol that matches both */

lookup_member: entry (arg_value, arg_member, arg_sym);

	symbol_tablep = addr (db_fnp_symbols_$db_fnp_symbols_);
	do i = 1 to symbol_table.cnt;
	     symp = addr (symbol_table.entry (i));
	     if sym.flag_mem = arg_member then
		if sym.value = arg_value then do;
		     arg_sym = sym.name;
		     return;
		end;
	end;
	arg_sym = "";
	return;

/* Entry to implement the set command */

set_command: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	cmd_infop = arg_cmd_infop;
	expr_infop = arg_expr_infop;

	call db_fnp_reader_$get_operand (cmd_infop);
	if cmd_info.error then go to error_return;
	if cmd_info.endline then do;
	     call ioa_ ("Symbol missing.");
	     go to error_return;
	end;
	set_sym_name = operand;
	if set_sym_name ^= operand then do;
	     call ioa_ ("Symbol name too long: ^a", operand);
	     go to error_return;
	end;
	call db_fnp_reader_$get_operand (cmd_infop);
	if cmd_info.error then go to error_return;
	if cmd_info.endline then do;
	     call ioa_ ("Value missing.");
	     go to error_return;
	end;
	call db_fnp_eval_ (arg_corep, arg_fnp, operand, expr_infop, "", set_sym_value, code);
	if code ^= 0 then go to error_return;

	if set_sym_name = "*" then do;		/* Check for standard names */
	     expr_info.star_addr = set_sym_value;
	     expr_info.star_known = "1"b;
	     return;
	end;
	else if set_sym_name = "tib" then do;
	     expr_info.tib_addr = set_sym_value;
	     expr_info.tib_known = "1"b;
	     return;
	end;
	else if set_sym_name = "hwcm" then do;
	     expr_info.hwcm_addr = set_sym_value;
	     expr_info.hwcm_known = "1"b;
	     return;
	end;
	else if set_sym_name = "sfcm" then do;
	     expr_info.sfcm_addr = set_sym_value;
	     expr_info.sfcm_known = "1"b;
	     return;
	end;


/* User defined symbol */

	symbol_tablep = expr_info.user_tablep;
	do i = 1 to symbol_table.cnt;			/* See if already there */
	     symp = addr (symbol_table.entry (i));
	     if sym.name = set_sym_name then go to store_sym;
	end;

	if symbol_table.cnt ^< symbol_table.maxcnt then do; /* See if room */
	     call ioa_ ("Symbol table full.");
	     go to error_return;
	end;

	symbol_table.cnt = symbol_table.cnt + 1;
	i = symbol_table.cnt;

store_sym:
	symp = addr (symbol_table.entry (i));
	unspec (sym) = "0"b;
	sym.name = set_sym_name;
	sym.value = set_sym_value;
	sym.len = expr_info.len;
	sym.type = expr_info.type;
	sym.reloc = reloc_abs;
	sym.flag_mem = "";
	return;

/* Entry to implement the explain command */

explain:	entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	cmd_infop = arg_cmd_infop;
	call db_fnp_reader_$get_operand (cmd_infop);
	if cmd_info.error then go to error_return;
	if cmd_info.endline then do;
	     call ioa_ ("Symbol missing");
	     go to error_return;
	end;
	do while (^cmd_info.endline);
	     call lookup (operand, symp);
	     if symp = null then call ioa_ ("Symbol ""^a"" undefined.", operand);
	     else if sym.explain = "0"b then call ioa_ ("Symbol ""^a"" has no explanation.", operand);
	     else do;
		exptextp = addrel (addr (db_fnp_symbols_$db_fnp_symbols_), sym.explain);
		call ioa_ ("""^a""^[ (in ^a)^;^s^] = ^a", operand,
		     (sym.flag_mem ^= ""), sym.flag_mem, exptext.data);
	     end;
	     call db_fnp_reader_$get_operand (cmd_infop);
	     if cmd_info.error then go to error_return;
	end;
	return;
error_return:
	cmd_info.flush = "1"b;
	return;

/* Implement apropos command. print symbols whose explanation contains
   the string given */

apropos:	entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	cmd_infop = arg_cmd_infop;
	apropos_listp = null ();
	on cleanup call apropos_cleanup;
	allocate apropos_list in (get_system_free_area_ () -> based_area);

	call db_fnp_reader_$get_operand (cmd_infop);
	if cmd_info.error then go to apropos_error;
	if cmd_info.endline then do;
	     call ioa_ ("Argument missing.");
	     go to apropos_error;
	end;
	apr_cnt = 0;
	do while (^cmd_info.endline);
	     if apr_cnt = hbound (apropos_list, 1) then do;
		call ioa_ ("Too many arguments");
		go to apropos_error;
	     end;
	     apr_cnt = apr_cnt + 1;
	     apropos_list (apr_cnt) = operand;
	     call db_fnp_reader_$get_operand (cmd_infop);
	     if cmd_info.error then go to apropos_error;
	end;

	symbol_tablep = addr (db_fnp_symbols_$db_fnp_symbols_);
	found = "0"b;
	do i = 1 to symbol_table.cnt;
	     symp = addr (symbol_table.entry (i));
	     if sym.explain ^= "0"b then do;
		exptextp = addrel (symbol_tablep, sym.explain);
		do j = 1 to apr_cnt;
		     if index (exptext.data, apropos_list (j)) ^= 0 then do;
			found = "1"b;
			call ioa_ ("""^a""^[ (in ^a)^;^s^] = ^a", sym.name,
			     (sym.flag_mem ^= ""), sym.flag_mem, exptext.data);
			go to next_apropos;
		     end;
		end;
	     end;
next_apropos:
	end;
	if ^found then do;
	     call ioa_ ("No symbols found.");
	     go to apropos_error;
	end;

	call apropos_cleanup;
	return;
apropos_error:
	call apropos_cleanup;
	go to error_return;

apropos_cleanup: proc;

	     if apropos_listp ^= null () then free apropos_list;
	     return;

	end apropos_cleanup;

/* This entry is a debuging entry to display the symbol table. It is called as a Multics command. */

db_fnp_dump_symbols: entry;

	symbol_tablep = addr (db_fnp_symbols_$db_fnp_symbols_);
	if symbol_table.cnt = 0 then do;
	     call ioa_ ("No symbols.");
	     return;
	end;

	call ioa_ ("NAME    VALUE  LEN RELOC  TYPE   FLAG     EXPLANATION^/");

	do i = 1 to symbol_table.cnt;
	     symp = addr (symbol_table.entry (i));
	     exptextp = addrel (symbol_tablep, sym.explain);
	     call ioa_ ("^6a^7o^5o  ^[    ^;tib ^;hwcm^;sfcm^;meters^]  ^6a ^8a ^[^a^;^s^]", sym.name, sym.value, sym.len,
		sym.reloc + 1, short_type_names (sym.type), sym.flag_mem, (sym.explain ^= "0"b), exptext.data);
	end;
	call ioa_ ("^/^d symbol^[s^].^/", symbol_table.cnt, symbol_table.cnt ^= 1);
	return;

%include debug_fnp_data;

     end db_fnp_sym_util_;




		    db_fnp_symbols_.cds             02/03/86  1012.8rew 02/03/86  0924.6      284121



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


/* DB_FNP_SYMBOLS_ - Procedure to create a symbol table for debug_fnp */
/* The table is constructed by scanning the macros.map355 source file */

/* Written February 1978 by Larry Johnson to replace the old, canned symbol table */
/* Modified by R Holmstedt 6/81 to use the new library path >ldd>mcs. */
db_fnp_symbols_: proc;

/* Automatic */

dcl  segp ptr;					/* Pointer to entire macro segment */
dcl  segl fixed bin;				/* Its length */
dcl  restp ptr;					/* Pointer to unscanned (rest of) segment */
dcl  restl fixed bin;				/* Its length */
dcl  ptr_array (2) ptr;				/* For get_temp_segments_ */
dcl  linep ptr;					/* Pointer to current line */
dcl  linel fixed bin;				/* Its length */
dcl  code fixed bin (35);
dcl  bit_count fixed bin (24);
dcl  dir char (168);
dcl  lineno fixed bin init (0);			/* Current line number, for errors */
dcl  end_of_line bit (1);
dcl  reloc_type fixed bin;
dcl  wordp ptr;
dcl  wordl fixed bin;
dcl  sym_offset fixed bin;
dcl  label char (6);
dcl  flag_type char (6);
dcl  n_exp_words fixed bin init (0);			/* Number of words used in explanations */
dcl  explain_seg_ptr ptr;

dcl 1 cds like cds_args automatic;

dcl 1 dummy_symbol_table aligned,			/* To define correct entry in object segment */
    2 db_fnp_symbols_ fixed bin;

dcl  line char (linel) based (linep);
dcl  rest char (restl) based (restp);
dcl  word char (wordl) based (wordp);

dcl 1 explain_seg aligned based (explain_seg_ptr),	/* Explanations are accumulated in this seg */
    2 unused bit (36),				/* Dummy word so offset will never be 0 */
    2 data (1) bit (36) aligned;

/* Constants */

dcl  white_space char (2) int static options (constant) init (" 	"); /* Space and tab */
dcl  nl char (1) int static options (constant) init ("
");
dcl  name char (16) int static options (constant) init ("db_fnp_symbols_");
dcl  macro_name char (13) int static options (constant) init ("macros.map355");
dcl  statement_name (9) char (16) int static options (constant) init (
     "symrel", "symlen", "symtype", "symdef", "symflag", "symdel", "synval", "symget", "symgetr");

/* External stuff */

dcl  ioa_ entry options (variable);
dcl  ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1) aligned, bit (1) aligned);
dcl  com_err_ entry options (variable);
dcl  cu_$arg_list_ptr entry (ptr);
dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  get_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35));
dcl  release_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35));
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  get_wdir_ entry returns (char (168));
dcl  create_data_segment_ entry (ptr, fixed bin (35));

dcl  error_table_$noentry ext fixed bin (35);

dcl  cleanup condition;

dcl (addr, addrel, bin, bit, divide, hbound, index, length, null, rel, search, size, string, substr, unspec, verify) builtin;

/* Initialization */

	ptr_array = null;
	segp = null;
	on cleanup call clean_up;

	call get_temp_segments_ (name, ptr_array, code);
	if code ^= 0 then do;
	     call com_err_ (code, name, "Unable to get temp segment.");
	     go to done;
	end;
	symbol_tablep = ptr_array (1);
	explain_seg_ptr = ptr_array (2);
	exptextp = addr (explain_seg.data);		/* Start data here */

	call init_macro_seg;			/* This locates the macro segment */

	call build_symbol_table;			/* And this does all the work */

	call relocate_explanations;			/* Copy symbols explanations in */


/* Now create the data segment */

	cds.p (1) = symbol_tablep;
	cds.len (1) = size (symbol_table) + n_exp_words;
	dummy_symbol_table.db_fnp_symbols_ = 0;		/* Reference dummy table so compiler doesnt delete it */
	cds.struct_name (1) = "dummy_symbol_table";
	cds.p (2) = null;
	cds.len (2) = 0;
	cds.struct_name (2) = "";
	cds.seg_name = name;
	cds.num_exclude_names = 0;
	cds.exclude_array_ptr = null;
	string (cds.switches) = "0"b;
	cds.have_text = "1"b;
	call create_data_segment_ (addr (cds), code);
	if code ^= 0 then call com_err_ (code, name, "From create_data_segment_");

done:	call clean_up;
	return;

/* Procedure  to scan the macro file and build the symbol table */

build_symbol_table: proc;

dcl  i fixed bin;
dcl  opname char (16);
dcl  r_sw bit (1);					/* Set for symgetr */
dcl  start_cnt fixed bin;
dcl  start_sym char (6);
dcl  end_sym char (6);
dcl  start_lineno fixed bin;
dcl  save_restp ptr;
dcl  save_restl fixed bin;

read_line:
	     call get_line;
	     if linep = null then do;			/* End of segment */
		if symbol_table.cnt = 0 then do;
		     call com_err_ (0, name, "No symbols defined.");
		     go to done;
		end;
		else return;
	     end;
	     if length (line) <= 6 then go to read_line;	/* Very short lines not interesting */
	     if substr (line, 1, 6) ^= "*++sym" then go to read_line; /* Not a line of importance */
	     call adv_line (3);			/* Skip over *++ */
	     i = search (line, white_space);		/* Find end of keyword */
	     if i = 0 then i = length (line);
	     else i = i-1;
	     opname = substr (line, 1, i);
	     call adv_line (i);			/* Skip over keyword */
	     call skip_white_space;			/* And white space after it */
	     do i = 1 to hbound (statement_name, 1);
		if statement_name (i) = opname then go to statement_type (i);
	     end;
	     call com_err_ (0, name, "Invalid *++^a statement on line ^d.", opname, lineno);
	     go to done;

statement_type (1):					/* *++ symrel */
	     if end_of_line then go to no_operand;	/* Need operands */
	     do while (^end_of_line);
		call get_symword;
		call get_word;
		call check_reloc;			/* Be sure this is valid relocation keyword */
		sym.reloc = reloc_type;
	     end;
	     go to read_line;

statement_type (2):					/* *++ symlen */
	     if end_of_line then go to no_operand;
	     do while (^end_of_line);
		call get_symword;			/* Look up symbol */
		call get_word;			/* Get length */
		if word = "" then do;
		     call com_err_ (0, name, "Invalid length for ^a on line ^d.", sym.name, lineno);
		     go to done;
		end;
		sym.len = eval (word);
	     end;
	     go to read_line;

statement_type (3):					/* *++ symtype */
	     if end_of_line then go to no_operand;
	     do while (^end_of_line);
		call get_symword;
		call get_word;
		do i = lbound (long_type_names, 1) to hbound (long_type_names, 1); /* Check for valid type */
		     if word = long_type_names (i) | word = short_type_names (i) then go to got_type;
		end;
		call com_err_ (0, name, "Invalid type for ^a on line ^d.", sym.name, lineno);
		go to done;
got_type:		sym.type = i;
	     end;
	     go to read_line;

statement_type (4):					/* *++symdef - define a new symbol */
	     if end_of_line then go to no_operand;
	     do while (^end_of_line);
		call get_word;
		if word = "" then go to no_operand;
		do i = 1 to symbol_table.cnt;		/* Be sure not duplicate */
		     symp = addr (symbol_table.entry (i));
		     if sym.name = word then do;
			call com_err_ (0, name, "Attempt to multiply define ^a on line ^d.", word, lineno);
			go to done;
		     end;
		end;
		symbol_table.cnt, symbol_table.maxcnt = symbol_table.cnt + 1;
		symp = addr (symbol_table.entry (symbol_table.cnt)); /* Addr of new entry */
		sym.name = word;
		sym.value = 0;
		sym.len = 1;
		sym.reloc = reloc_abs;
		sym.type = type_oct;
		sym.flag_mem = "";
		if ^end_of_line then do;		/* There is value */
		     call get_word;
		     sym.value = eval (word);
		end;
	     end;
	     go to read_line;

statement_type (5):					/* *++symflag */
	     if end_of_line then go to no_operand;
	     do while (^end_of_line);
		call get_symword;
		if end_of_line then sym.flag_mem = "";
		else do;
		     call get_word;
		     sym.flag_mem = word;
		end;
	     end;
	     go to read_line;

statement_type (6):					/* *++symdel - delete a previously defined symbol */
	     if end_of_line then go to no_operand;
	     do while (^end_of_line);
		call get_symword;
		do i = sym_offset + 1 to symbol_table.cnt; /* Shift everything after it down */
		     symbol_table.entry (i-1) = symbol_table.entry (i);
		end;
		unspec (symbol_table.entry (symbol_table.cnt)) = "0"b;
		symbol_table.cnt, symbol_table.maxcnt = symbol_table.cnt - 1;
	     end;
	     go to read_line;

statement_type (7):					/* *++symval - sets the valuue of a symbol */
	     if end_of_line then go to no_operand;
	     do while (^end_of_line);
		call get_symword;
		if end_of_line then sym.value = 0;
		else do;
		     call get_word;
		     sym.value = eval (word);
		end;
	     end;
	     go to read_line;

statement_type (8):					/* *++symget - gets a range of symbols into table */
	     r_sw = "0"b;
	     go to statement_type_8_9;

statement_type (9):					/* *++symgetr - like symget, but adds them in reverse order */
	     r_sw = "1"b;

statement_type_8_9:
	     save_restp = restp;			/* Save these values incase read-ahead needed */
	     save_restl = restl;
	     start_lineno = lineno;
	     start_cnt = symbol_table.cnt;		/* Remember origonal count */
	     if end_of_line then go to no_operand;
	     call get_word;				/* Get starting symbol name */
	     if word = "" | end_of_line then go to no_operand;
	     start_sym = word;
	     call get_word;				/* Ending symbol */
	     if word = "" then go to no_operand;
	     end_sym = word;
	     reloc_type = reloc_abs;			/* Default relocation */
	     flag_type = "";			/* Default flag field */
	     if ^end_of_line then do;			/* There may be relocation field */
		call get_word;
		if word = "" then reloc_type = reloc_abs;
		else call check_reloc;
	     end;
	     if ^end_of_line then do;			/* May be flag field */
		call get_word;
		flag_type = word;
	     end;

scan_start_sym:
	     call get_line;				/* Search for starting symbol */
	     if linep = null then do;
		call com_err_ (0, name, "Cant't find starting symbol ""^a"" requested on line ^d.",
		     start_sym, start_lineno);
		go to done;
	     end;
	     if substr (line, 1, 1) = "*" then go to scan_start_sym;
	     call get_label;
	     if label ^= start_sym then go to scan_start_sym;
	     call make_sym_entry;			/* Make entry for starting symbol */
	     if label = end_sym then go to done_sym_scan;
scan_end_sym:
	     call get_line;
	     if linep = null then do;
		call com_err_ (0, name, "Can't find ending symbol ""^a"" requested on line ^d.",
		     end_sym, start_lineno);
		go to done;
	     end;
	     if substr (line, 1, 1) = "*" then go to scan_end_sym;
	     call get_label;
	     if label = "" then go to scan_end_sym;
	     call make_sym_entry;
	     if label ^= end_sym then go to scan_end_sym;
done_sym_scan:
	     lineno = start_lineno;			/* Back up to *++symget statement */
	     restp = save_restp;
	     restl = save_restl;
	     i = symbol_table.cnt - start_cnt;		/* Number of symbols added */
	     if r_sw then begin;			/* Reverse them if symgetr */

dcl  j fixed bin;
dcl 1 temp_table,
    2 entry (i) unal,
      3 one_symbol like sym unal;

		do j = 1 to i;			/* Copy to temp table */
		     temp_table.entry (j) = symbol_table.entry (start_cnt + j);
		end;
		do j = i to 1 by -1;		/* Copy back */
		     symbol_table.entry (symbol_table.cnt - j + 1) = temp_table.entry (j);
		end;
	     end;
	     go to read_line;

no_operand:    call com_err_ (0, name, "Missing operand for *++^a on line ^d.", opname, lineno);
	     go to done;

	end build_symbol_table;

/* Procedure called after the symbol table is build3t to copy in explanation data and compute offsets to it */

relocate_explanations: proc;

dcl  words (n_exp_words) bit (36) aligned based;
dcl (p, q) ptr;
dcl  i fixed bin;

	     if n_exp_words = 0 then return;
	     p = addrel (symbol_tablep, size (symbol_table)); /* First word available for explanations */
	     q = addr (explain_seg.data);
	     p -> words = q -> words;			/* Copy it */
	     do i = 1 to symbol_table.cnt;		/* Loop to adjust all offsets */
		symp = addr (symbol_table.entry (i));
		if sym.explain ^= "0"b then		/* It has explanation */
		     sym.explain = bit (bin (bin (sym.explain, 17) + size (symbol_table) -1, 18), 18);
	     end;
	     return;

	end relocate_explanations;

/* Procedure to initiate the macro source segment. It looks first in the working directory,
   then in >ldd>mcs>info */

init_macro_seg: proc;

	     dir = get_wdir_ ();
	     call hcs_$initiate_count (dir, macro_name, "", bit_count, 0, segp, code);
	     if segp = null then do;
		if code ^= error_table_$noentry then do;
macro_seg_err:	     call com_err_ (code, name, "^a^[>^]^a", dir, dir ^= ">", macro_name);
		     go to done;
		end;
		dir = ">ldd>mcs>info";		/* Try library */
		call hcs_$initiate_count (dir, macro_name, "", bit_count, 0, segp, code);
		if segp = null then go to macro_seg_err;
	     end;

	     call ioa_ ("^a: Using ^a^[>^]^a", name, dir, (dir ^= ">"), macro_name);

	     segl = divide (bit_count, 9, 17, 0);
	     restp = segp;
	     restl = segl;
	     return;

	end init_macro_seg;

/* Procedure to isolate the next line in the source */

get_line:	proc;

dcl  i fixed bin;

get_next_line: end_of_line = "0"b;
	     if restl = 0 then do;			/* End of file */
		linep = null;
		return;
	     end;
	     lineno = lineno+1;

	     i = index (rest, nl);
	     if i = 0 then i, linel = restl;		/* No more newlines */
	     else linel = i-1;
	     linep = restp;
	     restp = substraddr (rest, i+1);
	     restl = restl - i;
	     if linel = 0 then go to get_next_line;	/* Ignor empty lines */
	     return;

	end get_line;

/* Procedure called while parsing line to move pointer down the line. */

adv_line:	proc (n);

dcl  n fixed bin;					/* How far too move */

	     linep = substraddr (line, n+1);
	     linel = linel - n;
	     if linel = 0 then end_of_line = "1"b;
	     return;

	end adv_line;

/* Procedure to skip over any white space */

skip_white_space: proc;

dcl  i fixed bin;

	     i = verify (line, white_space);		/* Count white space characters */
	     if i = 0 then i = linel;			/* All white line */
	     else i = i - 1;
	     call adv_line (i);
	     return;

	end skip_white_space;

/* Procedure to get the next word from the operand field. */

get_word:	proc;

dcl  i fixed bin;

	     if end_of_line | (linel = 0) then do;
		end_of_line = "1"b;
		wordp = null;
		wordl = 0;
		return;
	     end;

	     i = search (line, " 	,");		/* Space, tab, and comma */
	     if i = 0 then i = length (line);
	     else i = i - 1;
	     wordp = linep;
	     wordl = i;
	     call adv_line (i);			/* More forward over the word */
	     if linel > 0 then			/* Check for end of line */
		if substr (line, 1, 1) ^= "," then end_of_line = "1"b;
		else call adv_line (1);		/* Skip  ver  comma  */
	     return;

	end get_word;

/* Procedure to get the next word as a symbol */

get_symword: proc;

	     call get_word;
	     do sym_offset = 1 to symbol_table.cnt;
		symp = addr (symbol_table.entry (sym_offset));
		if sym.name = word then return;
	     end;
	     call com_err_ (0, name, "Undefined symbol ^a on line ^d", word, lineno);
	     go to done;

	end get_symword;

/* Check current word for valid relocation type */

check_reloc: proc;

	     if word = "abs" then reloc_type = reloc_abs;
	     else if word = "tib" then reloc_type = reloc_tib;
	     else if word = "sfcm" then reloc_type = reloc_sfcm;
	     else if word = "hwcm" then reloc_type = reloc_hwcm;
	     else if word = "meters" then reloc_type = reloc_meters;
	     else do;
		call com_err_ (0, name, "Invalid relocation type of ^a on line ^d", word, lineno);
		go to done;
	     end;
	     return;

	end check_reloc;

/* Extrace label from assembler statement */

get_label: proc;

dcl  i fixed bin;

	     i = search (line, white_space);
	     if i = 1 then label = "";		/* No label */
	     else do;
		if i = 0 then i = length (line);	/* Label is hole line */
		else i = i-1;
		label = substr (line, 1, i);
		call adv_line (i);
	     end;
	     call skip_white_space;
	     return;

	end get_label;

/* Procedure to make a new symbol table entry by compiling the curent line */

make_sym_entry: proc;

dcl  i fixed bin;
dcl  dec_sw bit (1);

	     i = search (line, white_space);		/* Find end of opcode */
	     if i = 0 then i = length (line);
	     else i = i-1;
	     if substr (line, 1, i) = "set" | substr (line, 1, i) = "equ" then dec_sw = "1"b; /* Valid decimal op */
	     else if substr (line, 1, i) = "bool" then dec_sw = "0"b;
	     else do;
		call com_err_ (0, name, "Unrecognized opcode ""^a"" defining ""^a"" on line ^d.",
		     substr (line, 1, i), label, lineno);
		go to done;
	     end;
	     call adv_line (i);			/* Over opcode */
	     call skip_white_space;
	     symbol_table.cnt, symbol_table.maxcnt = symbol_table.cnt + 1;
	     symp = addr (symbol_table.entry (symbol_table.cnt));
	     sym.name = label;
	     sym.value = 0;
	     sym.len = 1;
	     sym.reloc = reloc_type;
	     if flag_type = "" then sym.type = type_oct;
	     else sym.type = type_bit;
	     sym.flag_mem = flag_type;
	     sym.explain = "0"b;
	     sym.pad = "0"b;
	     i = search (line, white_space);		/* Find end of expression */
	     if i = 0 then i = length (line);
	     else i = i-1;
	     if dec_sw then sym.value = eval (substr (line, 1, i));
	     else sym.value = eval_oct (substr (line, 1, i));

	     call adv_line (i);			/* Over expression */
	     if end_of_line then return;
	     call skip_white_space;			/* Move up to comment */
	     if end_of_line then return;
	     exptext.len = length (line);		/* Rest of line is explanation */
	     exptext.data = line;
	     sym.explain = rel (exptextp);
	     i = size (exptext);
	     n_exp_words = n_exp_words + i;
	     exptextp = addrel (exptextp, i);		/* Loc for next eplanation */

	     return;

	end make_sym_entry;

/* Cleanup handler */

clean_up:	proc;

	     if segp ^= null then call hcs_$terminate_noname (segp, code);
	     if ptr_array (1) ^= null then call release_temp_segments_ (name, ptr_array, code);
	     return;

	end clean_up;

/* Simulate substraddr builtin temporarily */

substraddr: proc (c, n) returns (ptr);

dcl  c char (*);
dcl  n fixed bin;
dcl  ca (n) char (1) unal based (addr (c));

	     return (addr (ca (n)));

	end substraddr;

/* Procedure to evaluate expressions in source lines. This code was
   copied origionally from db_fnp_eval_ */

eval:	proc (arg_expr) returns (fixed bin);

/* Parameters */

dcl  arg_expr char (*);				/* The expression to evaluate */

/* Automatic */

dcl  result fixed bin;
dcl  code fixed bin (35);
dcl  ntoken fixed bin;				/* Number of tokens */
dcl  exprp ptr;					/* Pointer to unparsed part of expression */
dcl  exprl fixed bin;				/* Length of unparsed part */
dcl  expr char (exprl) based (exprp);			/* The unparsed part of expression */
dcl  tstart fixed bin;				/* Starting token in sub-expression */
dcl  tend fixed bin;				/* Last token in sub-expression */
dcl  tcur fixed bin;				/* Current token */
dcl  n_mult fixed bin;				/* Count of multiplies and divides */
dcl  n_add fixed bin;				/* Count of adds and subtracts */
dcl  dec_sw bit (1);

dcl 1 token_list aligned,
    2 entry (255) unal,
      3 token like token;


/* Definition of a token */

dcl  tokenp ptr;

dcl 1 token unaligned based (tokenp),
    2 prev fixed bin (8),				/* Backwards pointer */
    2 next fixed bin (8),				/* Forwards pointer */
    2 type fixed bin (8),				/* Kind of token */
    2 sub fixed bin (8),				/* Sub-type, for some tokens */
    2 val fixed bin (35);

/* Values for token.type */

dcl (start_token init (0),				/* Start of expression */
     leftp_token init (1),				/* Left parenthesis */
     rightp_token init (2),				/* Right parenthesis */
     mult_token init (3),				/* Multiply (sub=1), or divide (sub=2) */
     add_token init (4),				/* Add (sub=1), or subtract (sub=2) */
     sym_token init (6),				/* Symbol or constant */
     end_token init (7))				/* End of expression */
     fixed bin int static options (constant);


/* Initialization */

	     dec_sw = "1"b;				/* Called at decimal entryry */
	     go to eval_start;

eval_oct:	     entry (arg_expr) returns (fixed bin);

	     dec_sw = "0"b;

eval_start:

	     exprp = addr (arg_expr);
	     exprl = length (arg_expr);


/* Now evaluate the expression */

	     call parse_expr;

	     call eval_expr;
	     return (result);

/* Procedure to parse the expression */

parse_expr:    proc;

dcl  nparen fixed bin;				/* For paren level counting */
dcl  i fixed bin;

		ntoken = 0;
		call new_token (start_token);		/* First, start of expr token */

		nparen = 0;



		do while (exprl > 0);		/* Loop until end */

		     i = index ("()*/+|-", substr (expr, 1, 1)); /* Check for special character */
		     if i = 0 then do;		/* Must be symbol */
			if sym_or_rightp () then go to bad_char;
			call parse_sym;
			go to next_token;
		     end;
		     else go to parse_op (i);		/* Branch, depending on character */

parse_op (1):					/* Left paren */
		     if sym_or_rightp () then go to bad_char;
		     call new_token (leftp_token);
		     nparen = nparen + 1;
		     call adv (1);
		     go to next_token;

parse_op (2):					/* Right paren */
		     if token.type = start_token | mult_or_add () then go to bad_char;
		     if nparen ^> 0 then do;
			if exprl = length (arg_expr) then go to bad_char;
			else call err ("Too many "")"".");
		     end;
		     call new_token (rightp_token);
		     nparen = nparen - 1;
		     call adv (1);
		     go to next_token;

parse_op (3):					/* "*" - multiply */
		     if ^sym_or_rightp () then go to bad_char;
		     call new_token (mult_token);
		     token.sub = 1;
		     call adv (1);
		     go to next_token;

parse_op (4):					/* Divide */
		     if start_or_leftp () | mult_or_add () then go to bad_char;
		     call new_token (mult_token);
		     token.sub = 2;
		     call adv (1);
		     go to next_token;

parse_op (5):					/* Add */
parse_op (6):					/* Add, alternate form ("|") */
parse_op (7):					/* Subtract */
		     if start_or_leftp () then call new_token (sym_token); /* Unary, treat as 0+ or 0- */
		     else if mult_or_add () then go to bad_char;
		     call new_token (add_token);
		     if substr (expr, 1, 1) = "-" then token.sub = 2;
		     else token.sub = 1;
		     call adv (1);
		     go to next_token;

next_token:
		end;

		if nparen ^= 0 then call err ("Parens do not balance."); /* Must balance in end */

		if mult_or_add () then call err ("Expression ends badly.");

		call new_token (end_token);
		return;

	     end parse_expr;

/* Procedure to parse a constant or a symbol name */

parse_sym:     proc;

dcl  val fixed bin (35);
dcl  bval bit (36) aligned based (addr (val));
dcl (i, j) fixed bin;
dcl  p ptr;

		i = verify (expr, "0123456789");	/* Try constant first */
		if i ^= 1 then do;			/* It is a constant */
		     if i = 0 then i = length (expr);	/* Rest of expr is a constant */
		     else i = i - 1;
		     if dec_sw then do;
			val = cv_dec_check_ (substr (expr, 1, i), code);
			if code ^= 0 then call err ("Invalid decimal integer: ""^a"".", substr (expr, 1, i));
			if val < -262144 | val > 262143 then
			     call err ("Decimal integer not in range -262144 to 262143: ^a", substr (expr, 1, i));
			call adv (i);
		     end;
		     else do;			/* Octal number */
			val = cv_oct_check_ (substr (expr, 1, i), code);
			if code ^= 0 then call err ("Invalid octal integer: ""^a"".", substr (expr, 1, i));
			if substr (bval, 1, 18) ^= "0"b & substr (bval, 1, 18) ^= "777777"b3 then
			     call err ("Octal integer not in range -400000 to 377777: ^a", substr (expr, 1, i));
			call adv (i);
		     end;
		     if val > 0 then if substr (bval, 19, 1) then /* Really negative */
			     substr (bval, 1, 18) = "777777"b3;
		     call new_token (sym_token);	/* Set up token for symbol */
		     token.val = val;
		     return;
		end;

/* Symbol must be a name */

		i = search (expr, "()*/+|-");		/* Look for end */
		if i = 1 then go to bad_char;
		if i = 0 then i = length (expr);
		else i = i - 1;

		do j = 1 to symbol_table.cnt;
		     p = addr (symbol_table.entry (j));
		     if p -> sym.name = substr (expr, 1, i) then go to sym_found;
		end;
		call err ("Invalid symbol: ^a", substr (expr, 1, i));

sym_found:
		call new_token (sym_token);
		token.val = p -> sym.value;
		call adv (i);
		return;

	     end parse_sym;

/* Procedures which to some comon tests on the previous token */

mult_or_add:   proc returns (bit (1));

		return (token.type = mult_token | token.type = add_token);

	     end mult_or_add;

start_or_leftp: proc returns (bit (1));

		return (token.type = start_token | token.type = leftp_token);

	     end start_or_leftp;

sym_or_rightp: proc returns (bit (1));

		return (token.type = sym_token | token.type = rightp_token);

	     end sym_or_rightp;

/* Procedure to create a new token and trhread it in */

new_token:     proc (type);

dcl  type fixed bin;				/* Type of new token */

		if ntoken = hbound (token_list.entry, 1) then call err ("Expression too long.");
		if ntoken > 0 then token.next = ntoken + 1; /* Set pointer in prev token */
		ntoken = ntoken + 1;
		tokenp = addr (token_list.entry (ntoken));
		token.prev = ntoken - 1;
		token.next = 0;
		token.type = type;
		token.sub = 0;
		token.val = 0;
		return;

	     end new_token;

/* Procedure to advance pointer in expression */

adv:	     proc (n);

dcl  n fixed bin;					/* Amount to move */

		exprp = substraddr (expr, n+1);	/* Adjust pointer */
		exprl = exprl - n;			/* Adjust length */
		return;

	     end adv;

/* Procedure to evaluate the expression by scanning the list of tokens */
/* The procedure is to find the inner most expression, evaluate it, and
   continue. At the end, there should only be 3 tokens left: the start, the end,
   and one symbol token containing the final value */

eval_expr:     proc;

		do while (ntoken > 3);
		     call find_sub_expr;		/* Find some inner expression to work on */
		     call eval_sub_expr;		/* And reduce it to a value */
		end;

		tokenp = addr (token_list.entry (1));	/* Pointer to start token */
		tokenp = addr (token_list.entry (token.next)); /* Second token, containing the value */
		result = token.val;			/* Get the answer */
		return;

	     end eval_expr;


/* Procedure to locate an inner expression to evaluate. This will be either
   a part of the expression delimited by parens, or, if no parens left, the
   entire expression. */
/* The following variables are set for future use:
   tstart - the first token in the expression found
   tend - the last
   n_mult - likewise for mult tokens
   n_add - likewise for add tokens */

find_sub_expr: proc;

		n_mult, n_add = 0;
		tstart, tcur = 1;
		tokenp = addr (token_list.entry (tstart));

		do while ((token.type ^= rightp_token) & (token.type ^= end_token));
		     if token.type = leftp_token then do;
			tstart = tcur;		/* Maybe expression will start here */
			n_mult, n_add = 0;		/* Must reset counters for inner level */
		     end;
		     else if token.type = mult_token then n_mult = n_mult + 1;
		     else if token.type = add_token then n_add = n_add + 1;
		     tcur = token.next;		/* On to next one */
		     tokenp = addr (token_list.entry (tcur));
		end;
		tend = tcur;

	     end find_sub_expr;

/* Procedure to evaluate sub-expression once it has been isolated. */
/* The sub-expression is repeatedly scanned for mult tokens, add tokens */

eval_sub_expr: proc;

		do while ((n_mult + n_add) > 0);
		     if n_mult > 0 then call eval_op (mult_token, n_mult);
		     if n_add > 0 then call eval_op (add_token, n_add);
		end;

		call del_token (tstart);		/* Delete parens one expression is evaluated */
		call del_token (tend);
		return;

	     end eval_sub_expr;

/* This procedure scans looking for either mult tokens or add tokens to be evaluated. */

eval_op:	     proc (token_type, token_cnt);

dcl  token_type fixed bin;				/* The kind of token being evaluated, mult or add */
dcl  token_cnt fixed bin;				/* Number still unevaluated in sub-expression */

		tcur = tstart;
		tokenp = addr (token_list.entry (tcur));
		do while (token_cnt > 0);
		     if token.type = token_type then do; /* Got one */
			call compute_op;		/* Go do the arithmetic */
			token_cnt = token_cnt - 1;
		     end;
		     tcur = token.next;
		     tokenp = addr (token_list.entry (tcur));
		end;
		return;				/* Every thing possible is done */

	     end eval_op;

/* Procedure called to evalue a mult or add token. Once the arithmetic is done,
   the value is stored in the first sym token. the operator token and the second
   symbol token are deleted. This procedure is called with tcur as the operator
   token being evaluated */

compute_op:    proc;

dcl (del1, del2) fixed bin;				/* The two tokens to be deleted */
dcl (val1, val2) fixed bin (35);			/* Values of the two symbols */
dcl  p ptr;

		del1 = tcur;			/* The operator token will be deleted */
		del2 = token.next;			/* As well as the second operand */
		p = addr (token_list.entry (token.next)); /* Pointter to second symbol token */
		val2 = p -> token.val;
		p = addr (token_list.entry (token.prev)); /* Pointer to the first symbol */
		val1 = p -> token.val;
		if token.type = add_token then do;	/* Add or subtract */
		     if token.sub = 1 then val1 = val1 + val2;
		     else val1 = val1 - val2;
		end;
		else do;				/* Multiply or divide */
		     if token.sub = 1 then val1 = val1 * val2;
		     else do;
			if val2 = 0 then call err ("Division by zero.");
			else val1 = divide (val1, val2, 35, 0);
		     end;
		end;

		tcur = token.prev;			/* Make first operand the current token */
		tokenp = addr (token_list.entry (tcur));
		token.val = val1;			/* Save answer */
		call del_token (del1);		/* Delete operator */
		call del_token (del2);		/* And the sedond operand */
		return;

	     end compute_op;

/* Procedure to delete a token by untreading it from the list */

del_token:     proc (n);

dcl  n fixed bin;					/* The token to go */
dcl (next, prev) fixed bin;
dcl  p ptr;

		p = addr (token_list.entry (n));
		prev = p -> token.prev;
		next = p -> token.next;
		if (prev = 0) | (next = 0) then return; /* Ndver delete start or end */

		p = addr (token_list.entry (prev));
		p -> token.next = next;
		p = addr (token_list.entry (next));
		p -> token.prev = prev;
		ntoken = ntoken - 1;
		return;

	     end del_token;

/* Error routines */

bad_char:
	     if exprl < length (arg_expr) then call err ("""^a"" after ""^a"" is invalid.",
		substr (expr, 1, 1), substr (arg_expr, 1, length (arg_expr) - exprl));
	     else call err ("""^a"" at beginning is invalid.", substr (expr, 1, 1));


/* General error subroutine */

err:	     proc options (variable);

dcl  s char (256);
dcl  p ptr;

		call cu_$arg_list_ptr (p);
		call ioa_$general_rs (p, 1, 2, s, (0), "1"b, "0"b);
		call com_err_ (0, name, "Invalid expression in line ^d: ""^a"". ^a", lineno, arg_expr, s);
		go to done;

	     end err;

	end eval;

%include debug_fnp_data;

%include cds_args;

     end db_fnp_symbols_;




		    db_fnp_trace_.pl1               11/15/82  1816.2rew 11/15/82  1502.2      134217



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


/* DB_FNP_TRACE_ - Implements db_fnp commands that deal with the trace table */
/* Written 1977 by Larry Johnson */
/* Modified August 1979 by Larry Johnson to make use of .crtsz and to improve command interface */

db_fnp_trace_: proc;

/* Parameters */

dcl  arg_corep ptr;
dcl  arg_fnp fixed bin;
dcl  arg_cmd_infop ptr;
dcl  arg_expr_infop ptr;

/* Automatic */

dcl  corep ptr;
dcl  fnp fixed bin;
dcl (i, j) fixed bin;
dcl  code fixed bin (35);
dcl  trace_mask bit (18) unal;			/* Current mask word */
dcl  temp_name char (16);
dcl  set bit (1);
dcl  trace_sw (1) bit (18) unal;
dcl  tcur fixed bin;
dcl  mem_word (1) bit (18) unal;
dcl (print_start, print_count) fixed bin;		/* Args on print trace */
dcl  trace_message char (128) var;
dcl  trace_req_msgp ptr init (null ());
dcl  trace_req_msg_cnt fixed bin;
dcl (start_given, count_given) bit (1);
dcl  something_printed bit (1);

dcl 1 modch aligned,				/* Module table required by format_fnp_trace_msg_ */
    2 nmodules fixed bin init (30),
    2 entries (30),
      3 name char (4),
      3 address fixed bin;

/* Constants */

dcl  mask_name (10) char (4) int static options (constant) init (
     "sked", "dia", "intp", "util", "lsla", "hsla", "cons", "trac", "init", "ptrc");
dcl  name char (13) int static options (constant) init ("db_fnp_trace_");

/* Static */

dcl  symbols_looked_up bit (1) int static init ("0"b);
dcl  crtra fixed bin int static;			/* Address of trace mask */
dcl  crtsw fixed bin int static;			/* Global trace switch */
dcl  crtrb fixed bin int static;			/* Base of trace table */
dcl  crtrc fixed bin int static;			/* Current entry */
dcl  crmem fixed bin int static;			/* Last word of memory */
dcl  crtsz fixed bin int static;			/* Size of trace table */
dcl  h1mb fixed bin int static;			/* Hsla 1 mailbox - used as lower bound on address checking */
dcl  free_areap ptr int static;			/* Address of temp area */
dcl  free_area area based (free_areap);

/* Stuff associated with trace table */

dcl  trace_tab_size fixed bin;			/* Its length */
dcl  trace_tab_start fixed bin;			/* Starting memory addrress */
dcl  trace_tab_current fixed bin;			/* Current entry */
dcl  trace_tab_cnt fixed bin;				/* Number of entries */
dcl  trace_tabp ptr init (null);			/* Address of table */
dcl  trace_tab (trace_tab_size) bit (18) unal based (trace_tabp);

/* Format of a trace message entry */

dcl  tmsgp ptr;
dcl 1 tmsg unal based (tmsgp),
    2 module bit (6) unal,				/* Module logging message */
    2 type bit (6) unal,				/* Message number */
    2 length bit (6) unal,				/* Number of data words */
    2 time bit (18) unal,
    2 data (1) bit (18) unal;				/* Array of tmsg.length words */
dcl  flag_word bit (18) unal based (tmsgp);		/* For checking sentinels */
dcl  logical_end bit (18) int static options (constant) init ("525252"b3);
dcl  physical_end bit (18) int static options (constant) init ("525250"b3);

/* Based */

dcl  trace_req_msg (10) char (32) var based (trace_req_msgp);

/* External */

dcl  db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35));
dcl  db_fnp_memory_$store entry (ptr, fixed bin, fixed bin, fixed bin, ptr, char (*), fixed bin, fixed bin (35));
dcl  db_fnp_sym_util_$get_value entry (char (*)) returns (fixed bin);
dcl  db_fnp_reader_$get_operand entry (ptr);
dcl  db_fnp_eval_ entry (ptr, fixed bin, char (*), ptr, char (*), fixed bin, fixed bin (35));
dcl  db_fnp_util_$get_special_modch entry (ptr, fixed bin, ptr, fixed bin (35));
dcl  format_fnp_trace_msg_ entry (ptr, ptr, char (*) var);
dcl (ioa_, ioa_$nnl) entry options (variable);
dcl  com_err_ entry options (variable);
dcl  get_system_free_area_ entry returns (ptr);

dcl  cleanup condition;

dcl (addr, bin, hbound, length, max, min, null, substr, unspec) builtin;

/* Entry to print the trace table */

print_trace: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call init;

	on cleanup call clean_up;

	if corep = null then do;			/* Be sure tracing is disabled for running fnp */
	     call fetch (crtsw, 1, addr (trace_sw (1)));
	     if trace_sw (1) = "0"b then do;
		call ioa_ ("Tracing not disabled. Use stop_trace first.");
		go to error_return;
	     end;
	end;

	print_start = 1;
	print_count = -1;
	start_given, count_given = "0"b;

	call get_operand;
	do while (^cmd_info.endline);
	     if substr (operand, 1, 1) = "/" then do;	/* scan string */
		if trace_req_msgp = null () then do;
		     allocate trace_req_msg in (free_area);
		     trace_req_msg_cnt = 0;
		end;
		if trace_req_msg_cnt = hbound (trace_req_msg, 1) then do;
		     call ioa_ ("Too many strings requested.");
		     go to error_return;
		end;
		trace_req_msg_cnt = trace_req_msg_cnt + 1;
		i = length (operand) - 1;
		if substr (operand, length (operand), 1) = "/" then i = i - 1;
		trace_req_msg (trace_req_msg_cnt) = substr (operand, 2, i);
	     end;
	     else if ^start_given then do;
		call db_fnp_eval_ (corep, fnp, operand, expr_infop, "", print_start, code);
		if code ^= 0 then go to error_return;
		start_given = "1"b;
	     end;
	     else if ^count_given then do;
		call db_fnp_eval_ (corep, fnp, operand, expr_infop, "", print_count, code);
		if code ^= 0 then go to error_return;
		count_given = "1"b;
	     end;
	     else do;
		call ioa_ ("Unrecognized operand: ^a", operand);
		go to error_return;
	     end;
	     call get_operand;
	end;

	call db_fnp_util_$get_special_modch (corep, fnp, addr (modch), code);
	if code ^= 0 then modch.nmodules = 0;

	call capture_trace;				/* Find trace table */
	if print_start < 0 then print_start = trace_tab_cnt + print_start + 1; /* Measuring from end */
	print_start = max (1, print_start);
	if print_start > trace_tab_cnt then do;
	     call ioa_ ("Trace table contains only ^d entries.", trace_tab_cnt);
	     go to error_return;
	end;

	i = 1;
	tcur = trace_tab_current;
	tmsgp = addr (trace_tab (tcur - trace_tab_start + 1));
	do while (i < print_start);			/* Loop past unneeded entries at start */
	     if flag_word = physical_end then tcur = trace_tab_start;
	     else do;
		i = i + 1;
		tcur = tcur + bin (tmsg.length) + 2;
	     end;
	     tmsgp = addr (trace_tab (tcur - trace_tab_start + 1));
	end;

	i = 0;
	something_printed = "0"b;
	do while (i ^= print_count);			/* Loop till enough printed */
	     if flag_word = logical_end then go to print_trace_end;
	     else if flag_word = physical_end then tcur = trace_tab_start;
	     else do;
		call format_fnp_trace_msg_ (tmsgp, addr (modch), trace_message);
		if trace_req_msgp ^= null () then do;	/* strings requested */
		     do j = 1 to trace_req_msg_cnt;
			if index (trace_message, trace_req_msg (j)) > 0 then
			     go to print_it;
		     end;
		     go to skip_it;
		end;
print_it:		call ioa_ ("^a", trace_message);
		something_printed = "1"b;
skip_it:		i = i + 1;
		tcur = tcur + bin (tmsg.length) + 2;
	     end;
	     tmsgp = addr (trace_tab (tcur - trace_tab_start + 1));
	end;

print_trace_end:
	if trace_req_msgp ^= null & ^something_printed then do;
	     call ioa_ ("No trace messages match request.");
	     go to error_return;
	end;

	call clean_up;
	return;

/* Entry to set and/or print the trace mask */

mask:	entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call init;
	call fetch (crtra, 1, addr (trace_mask));	/* Read current mask */
	call get_operand;				/* Get first openard */
	if cmd_info.endline then do;			/* No operands, print mask */
	     call ioa_$nnl ("Trace mask is ^.3b:", trace_mask);
	     do i = 1 to hbound (mask_name, 1);
		if substr (trace_mask, i, 1) then call ioa_$nnl (" ^a", mask_name (i));
	     end;
	     call ioa_ ("");
	     return;
	end;

	do while (^cmd_info.endline);			/* Parse operands for new mask */
	     if substr (operand, 1, 1) = "+" then do;	/* Must set bit */
		set = "1"b;
		temp_name = substr (operand, 2);
	     end;
	     else if substr (operand, 1, 1) = "^" | substr (operand, 1, 1) = "-" then do; /* Reset */
		set = "0"b;
		temp_name = substr (operand, 2);
	     end;
	     else do;				/* Default is to set */
		set = "1"b;
		temp_name = operand;
	     end;
	     if temp_name = "all" then do;
		if set then trace_mask = "777777"b3;
		else trace_mask = "0"b;
		go to next_trace_name;
	     end;
	     else if temp_name = "none" then do;
		if set then trace_mask = "0"b;
		else trace_mask = "777777"b3;
		go to next_trace_name;
	     end;
	     else do i = 1 to hbound (mask_name, 1);	/* Look op name */
		if mask_name (i) = temp_name then do;	/* Got it */
		     substr (trace_mask, i, 1) = set;
		     go to next_trace_name;
		end;
	     end;
	     call ioa_ ("Invalid trace mask name: ^a", temp_name);
	     go to error_return;
next_trace_name:
	     call get_operand;
	end;
	call store (crtra, 1, addr (trace_mask));	/* Store result */
	return;

/* Entries to turn tracing on and off */

start_trace: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	trace_sw (1) = "0"b;
start_or_stop_trace:
	call init;
	call store (crtsw, 1, addr (trace_sw (1)));
	return;

stop_trace: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	trace_sw (1) = "000001"b3;
	go to start_or_stop_trace;

/* Initializatioon */

init:	proc;

	     corep = arg_corep;
	     fnp = arg_fnp;
	     cmd_infop = arg_cmd_infop;
	     expr_infop = arg_expr_infop;
	     if symbols_looked_up then return;
	     crtra = db_fnp_sym_util_$get_value (".crtra");
	     crtsw = db_fnp_sym_util_$get_value (".crtsw");
	     crtrb = db_fnp_sym_util_$get_value (".crtrb");
	     crtrc = db_fnp_sym_util_$get_value (".crtrc");
	     crmem = db_fnp_sym_util_$get_value (".crmem");
	     crtsz = db_fnp_sym_util_$get_value (".crtsz");
	     h1mb = db_fnp_sym_util_$get_value ("h1mb");
	     free_areap = get_system_free_area_ ();
	     symbols_looked_up = "1"b;
	     return;

	end init;

/* Read and write memory words */

fetch:	proc (a, n, p);

dcl  a fixed bin;
dcl  n fixed bin;
dcl  p ptr;

	     call db_fnp_memory_$fetch (corep, fnp, a, n, p, code);
	     if code = 0 then return;
	     if n = 1 then call com_err_ (code, name, "Unable to read location ^o.", a);
	     else call com_err_ (code, name, "Unable to read locations ^o thru ^o", a, a+n-1);
	     go to error_return;

store:	     entry (a, n, p);

	     call db_fnp_memory_$store (corep, fnp, a, n, p, name, 0, code);
	     if code = 0 then return;
	     if n = 1 then call com_err_ (code, name, "Unable to write location ^o.", a);
	     else call com_err_ (code, name, "Unable to write locations ^o thru ^o", a, a+n-1);
	     go to error_return;

	end fetch;

/* Get next operand from command line */

get_operand: proc;

	     call db_fnp_reader_$get_operand (cmd_infop);
	     if cmd_info.error then go to error_return;
	     return;

	end get_operand;

error_return:
	cmd_info.flush = "1"b;
	call clean_up;
	return;

clean_up:	proc;

	     if trace_tabp ^= null () then free trace_tab;
	     if trace_req_msgp ^= null () then free trace_req_msg;
	     return;

	end clean_up;

/* Procedure to "capture" the trace table */

capture_trace: proc;

dcl  offset fixed bin;				/* Offset to current section */
dcl  p ptr;
dcl  mem_size fixed bin;

	     call fetch (crtrb, 1, addr (mem_word));	/* Read start address */
	     trace_tab_start = bin (mem_word (1));
	     if trace_tab_start = 0 then do;
		call ioa_ ("No trace table.");
		go to error_return;
	     end;
	     call fetch (crtrc, 1, addr (mem_word));	/* Read current pointer */
	     trace_tab_current = bin (mem_word (1));
	     tcur = trace_tab_current;
	     call fetch (crmem, 1, addr (mem_word));
	     mem_size = bin (mem_word (1));

	     if (trace_tab_start < h1mb) |		/* Gullability checks on pointers */
	     (trace_tab_start > mem_size) |
	     (trace_tab_current < h1mb) |
	     (trace_tab_current > mem_size) |
	     (trace_tab_current < trace_tab_start) then do;
bad_pointers:	call ioa_ ("Unable to capture trace buffers: pointers inconsistent.");
		go to error_return;
	     end;

	     call fetch (crtsz, 1, addr (mem_word));	/* Read trace size */
	     if mem_word (1) = "0"b then do;

/* The following code is for pre-MR8 systems where trace size is not known */

		offset = 0;
		trace_tab_size = 1024;		/* Read first 1024 words */
		allocate trace_tab in (free_area);
fetch_more:	call fetch (trace_tab_start+offset, 1024, addr (trace_tab (offset+1))); /* Read next 1024 words */
		if (trace_tab_current - trace_tab_start) >= trace_tab_size then do;
						/* Dont have section with current entry yet */
capture_more:					/* So must grow table */
		     trace_tab_size = trace_tab_size+1024;
		     allocate trace_tab in (free_area) set (p); /* Allocate bigger one */
		     trace_tab_size = trace_tab_size - 1024 ; /* Revert to smaller size temporarily */
		     unspec (p -> trace_tab) = unspec (trace_tab); /* Copy to new area */
		     free trace_tab;
		     trace_tab_size = trace_tab_size + 1024;
		     trace_tabp = p;		/* New space ready */
		     offset = offset+1024;
		     go to fetch_more;		/* Go read next section */
		end;
check_next_entry:
		tmsgp = addr (trace_tab (tcur - trace_tab_start + 1));
		if flag_word = physical_end | flag_word = logical_end then go to count_trace_entries; /* Whole table found */
		tcur = tcur + bin (tmsg.length) + 2;	/* Address of next one */
		if tcur >= trace_tab_start + trace_tab_size then go to capture_more; /* Havent read necessary part yet */
		else go to check_next_entry;
	     end;

/* The following code is MR8 and later systems where trace table size is known */

	     else do;
		trace_tab_size = bin (mem_word (1));
		if trace_tab_current > trace_tab_start + trace_tab_size then
		     go to bad_pointers;
		allocate trace_tab in (free_area);
		do offset = 0 to trace_tab_size - 1 by 1024;
		     call fetch (trace_tab_start + offset, min (1024, trace_tab_size - offset), addr (trace_tab (offset + 1)));
		end;
	     end;

/* Now analyze captured trace */

count_trace_entries:
	     trace_tab_cnt = 0;
	     tcur = trace_tab_current;
	     tmsgp = addr (trace_tab (tcur - trace_tab_start + 1));
	     do while (flag_word ^= logical_end);	/* Loop to count entries */
		if flag_word = physical_end then tcur = trace_tab_start;
		else do;
		     tcur = tcur + bin (tmsg.length) + 2;
		     trace_tab_cnt = trace_tab_cnt + 1;
		end;
		tmsgp = addr (trace_tab (tcur - trace_tab_start + 1));
	     end;

	     return;

	end capture_trace;

%include debug_fnp_data;

     end db_fnp_trace_;




		    db_fnp_util_.pl1                11/15/82  1816.2rew 11/15/82  1449.5      208944



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


/* DB_FNP_UTIL_ - A series of entries that deal with internal tables in the FNP */

/* Written January 1977 by Larry Johnson */

/* format: style4,delnl,insnl,^ifthendo */
db_fnp_util_:
     proc;

/* Parameters */

dcl  arg_corep ptr;					/* Pointer to segment containing fnp memory */
dcl  arg_fnp fixed bin;				/* The fnp number, for real fnps */
dcl  arg_edited_addr char (*) var;			/* String built by edit_module_addr entry */
dcl  arg_fnp_addr fixed bin;				/* Address in fnp memory */
dcl  arg_code fixed bin (35);
dcl  arg_mod_name char (*);				/* Name of module to be looked up */
dcl  arg_tty_name char (*);				/* Name of tty channel */
dcl  arg_chan_name char (*);
dcl  arg_tty_line_no fixed bin;
dcl  arg_expr_infop ptr;
dcl  arg_modchp ptr;
dcl  arg_cmd_infop ptr;

/* Automatic */

dcl  fnp fixed bin;
dcl  code fixed bin (35);
dcl  (i, j, k) fixed bin;
dcl  mod_name char (8);
dcl  fnp_addr fixed bin;
dcl  corep ptr;					/* Pointer to fnp core image */
dcl  min_offset fixed bin;
dcl  addr_temp1 char (8) var;
dcl  addr_temp2 char (16) var;
dcl  word_buf bit (18) unal;
dcl  tty_fnp_no fixed bin;				/* Fnp to which a tty is connected */
dcl  tty_hsla_sw bit (1);				/* Set if tty is on hsla */
dcl  tty_la_no fixed bin;				/* The relative hsla or lsla number */
dcl  tty_chan_no fixed bin;				/* Relative channel on channel */
dcl  tty_slot_no fixed bin;				/* Time slot position on lsla */
dcl  tty_line_no fixed bin;
dcl  mem_word bit (18) unal;
dcl  force_sw bit (1);
dcl  paren_sw bit (1);

dcl  1 tty_name unal,				/* Format of  a tty channel name */
       2 fnp_name char (1),
       2 dot char (1),
       2 la_type char (1),
       2 la_no picture "9",
       2 chan_no picture "99";

dcl  modchp ptr;
dcl  1 modch aligned based (modchp),			/* Special module table used by trace */
       2 nmodules fixed bin,
       2 entries (modch.nmodules),
         3 name char (4),
         3 address fixed bin;

/* based */

dcl  1 fnptab aligned based (fnptabp),
       2 per_fnp (0:8),
         3 init_switches,
	 4 modtab_init bit (1) unal,			/* Set when module table setup */
	 4 iomtab_init bit (1) unal,			/* Set when iom table setup */
	 4 lslatab_init (0:5) bit (1) unal,
	 4 hslatab_init (0:2) bit (1) unal,
         3 bind_time fixed bin (71),
         3 boot_time fixed bin (71),
         3 nmodules fixed bin,
         3 per_module (50),
	 4 name char (6),
	 4 start fixed bin,
	 4 date char (6),
         3 iom_table,
	 4 lsla_tab_addr (0:5) fixed bin,		/* Addr of lsla tables in fnp */
	 4 hsla_tab_addr (0:2) fixed bin,		/* Likewise for hslas */
         3 per_lsla (0:5),
	 4 lsla_hwcm_addr fixed bin,
	 4 lsla_sfcm_addr fixed bin,
	 4 lsla_tib_addr (0:51) fixed bin (17) unal,
	 4 lsla_slot_no (0:51) fixed bin (17) unal,
         3 per_hsla (0:2),
	 4 hsla_mbx_addr fixed bin,
	 4 hsla_tib_addr (0:31) fixed bin (17) unal;

/* External stuff */

dcl  db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35));
dcl  db_fnp_sym_util_$get_value entry (char (*)) returns (fixed bin);
dcl  db_fnp_sym_util_$get_length entry (char (*)) returns (fixed bin);
dcl  ioa_ entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  com_err_ entry options (variable);
dcl  parse_tty_name_ entry (char (*), fixed bin, bit (1), fixed bin, fixed bin);
dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  get_temp_segment_ entry (char (*), pointer, fixed bin (35));
dcl  get_fnp_name_ entry (fixed bin) returns (char (32));

dcl  error_table_$bad_arg ext fixed bin (35);
dcl  error_table_$noentry ext fixed bin (35);

dcl  (addr, bin, divide, hbound, lbound, min, mod, null, rtrim, size, string, substr, translate) builtin;

/* constants */

dcl  name char (12) int static options (constant) init ("db_fnp_util_");
dcl  xlate (0:63) char (1) int static options (constant) init (
						/* Bcd to ascii xlation table */
	"0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "[", "#", "@", ":", ">", "?", " ", "A", "B", "C", "D", "E",
	"F", "G", "H", "I", "&", ".", "]", "(", "<", "^", "|", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "-", "$",
	"*", ")", ";", "'", "+", "/", "S", "T", "U", "V", "W", "X", "Y", "Z", "_", ",", "%", "=", """", "!");

/* INTERNAL STATIC DATA */

dcl  fnptabp ptr int static init (null ());
dcl  constants_computed bit (1) int static init ("0"b);
dcl  crldt fixed bin int static;			/* Address of bind time in 355 */
dcl  crmod fixed bin int static;			/* Address of module chain in 355 */
dcl  criom fixed bin int static;
dcl  crtdt fixed bin int static;			/* Address of T&D executive TIB */
dcl  h_sfcm fixed bin int static;			/* Offset to sfcm pointer in hwcm */
dcl  h1ch fixed bin int static;			/* First hsla channel number */
dcl  l1ch fixed bin int static;			/* First lsla channel number */
dcl  hwcm_len fixed bin int static;

/* PRINT_MODULE_TABLE - Entry that will print the module table for the fnp. This entry is a debug_fnp command. */

print_module_table:
     entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop);

	call setup;
	cmd_infop = arg_cmd_infop;

	call setup_module_table;
	if code ^= 0
	then do;
	     call com_err_ (code, "", "Unable to get module table.");
	     cmd_info.flush = "1"b;
	     return;
	end;

	do i = 1 to fnptab.nmodules (fnp);
	     call ioa_ ("^6a^8o  ^a/^a/^a", fnptab.name (fnp, i), fnptab.start (fnp, i),
		substr (fnptab.date (fnp, i), 1, 2), substr (fnptab.date (fnp, i), 3, 2),
		substr (fnptab.date (fnp, i), 5, 2));
	end;
	return;


/* LOOKUP_MODULE - Entry to lookup one name in the module table */

lookup_module:
     entry (arg_corep, arg_fnp, arg_mod_name, arg_fnp_addr, arg_code);

	call setup;
	call setup_module_table;
	if code ^= 0
	then do;
	     arg_code = code;
	     arg_fnp_addr = 0;
	     return;
	end;

	mod_name = translate (arg_mod_name, "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
	do i = 1 to fnptab.nmodules (fnp);
	     if fnptab.name (fnp, i) = mod_name
	     then do;
		arg_fnp_addr = fnptab.start (fnp, i);
		arg_code = 0;
		return;
	     end;
	end;
	arg_code = error_table_$noentry;
	arg_fnp_addr = 0;
	return;

/* GET_SPECIAL_MODCH - returns module table in special form used by format_fnp_trace_msg_ */

get_special_modch:
     entry (arg_corep, arg_fnp, arg_modchp, arg_code);

	call setup;
	call setup_module_table;
	if code ^= 0
	then do;
	     arg_code = code;
	     return;
	end;

	modchp = arg_modchp;
	i = min (fnptab.nmodules (fnp), modch.nmodules);	/* Return what fits */
	do j = 1 to i;
	     modch.name (j) = fnptab.name (fnp, j);
	     modch.address (j) = fnptab.start (fnp, j);
	end;
	modch.nmodules = i;				/* Return actual count */
	arg_code = 0;
	return;

/* EDIT_MODULE_ADDR - Entry to edit a fnp address in the form module|offset */

edit_module_addr:
     entry (arg_corep, arg_fnp, arg_fnp_addr, arg_edited_addr, arg_code);

	force_sw, paren_sw = "0"b;
edit_module_addr_join:
	call setup;
	fnp_addr = arg_fnp_addr;
	call setup_module_table;
	if code ^= 0
	then do;
	     arg_code = code;
	     arg_edited_addr = "";
	     return;
	end;

	j = -1;					/* No module found */
	if fnp_addr < 0 | fnp_addr > 32767
	then go to edit_module_offset;
	min_offset = 32768;
	do i = 1 to fnptab.nmodules (fnp);		/* Check addr against each module */
	     k = fnp_addr - fnptab.start (fnp, i);	/* Get an offset */
	     if (k >= 0) & (k < min_offset)
	     then do;				/* Found a possible */
		j = i;				/* Save its index */
		min_offset = k;			/* Remember lowest value found */
	     end;
	end;
edit_module_offset:
	if j = -1
	then addr_temp1 = "";			/* No module */
	else do;
	     addr_temp1 = rtrim (fnptab.name (fnp, j));
	     addr_temp1 = addr_temp1 || "|";
	     fnp_addr = min_offset;
	end;
	call ioa_$rsnnl ("^o", addr_temp2, (0), fnp_addr);/* Edit offset */
	if addr_temp1 = ""
	then do;					/* Out of range */
	     if force_sw | paren_sw
	     then arg_edited_addr = addr_temp2;
	     else arg_edited_addr = "";
	end;
	else do;
	     if ^paren_sw
	     then arg_edited_addr = addr_temp1 || addr_temp2;
	     else call ioa_$rsnnl ("^o (^a^a)", arg_edited_addr, (0), arg_fnp_addr, addr_temp1, addr_temp2);
	end;
	arg_code = 0;
	return;

/* EDIT_MODULE_ADDR_FORCE - Like above, but returns octal for out of module range address */

edit_module_addr_force:
     entry (arg_corep, arg_fnp, arg_fnp_addr, arg_edited_addr, arg_code);

	force_sw = "1"b;
	paren_sw = "0"b;
	go to edit_module_addr_join;

/* EDIT_MODULE_ADDR_PAREN - Like above, but returns "addr (mod|offset)" */

edit_module_addr_paren:
     entry (arg_corep, arg_fnp, arg_fnp_addr, arg_edited_addr, arg_code);

	force_sw = "0"b;
	paren_sw = "1"b;
	go to edit_module_addr_join;

/* GET_CHAN_ADDRS - Entry which takes a tty channel name and finds its TIB address */

get_chan_addrs:
     entry (arg_corep, arg_fnp, arg_chan_name, arg_expr_infop, arg_code);

	call setup;
	expr_infop = arg_expr_infop;
	expr_info.tib_known, expr_info.hwcm_known, expr_info.sfcm_known = "0"b;

	tty_line_no = cv_oct_check_ (arg_chan_name, code);/* Check for all octal */
	if code = 0
	then do;
	     call parse_tty_line_no;
	     if tty_fnp_no < 0
	     then go to char_to_tib_bad_arg;
	end;
	else do;					/* Character form name */
	     call parse_tty_name_ (arg_chan_name, tty_fnp_no, tty_hsla_sw, tty_la_no, tty_chan_no);
	     if tty_fnp_no < 0
	     then go to char_to_tib_bad_arg;
	     if arg_fnp > 0
	     then if arg_fnp ^= tty_fnp_no
		then				/* Line not on current FNP */
		     go to char_to_tib_bad_arg;
	end;

	if tty_la_no = 7				/* handle T&D channel specially */
	then do;
	     call validate_fnp_data;
	     call db_fnp_memory_$fetch (corep, fnp, crtdt, 1, addr (mem_word), code);
	     if code ^= 0
	     then go to char_to_tib_err;
	     if mem_word = "0"b
	     then go to char_to_tib_bad_arg;
	     expr_info.tib_addr = bin (mem_word);
	     expr_info.tib_known = "1"b;		/* but other data bases remain unknown */
	end;

	else do;
	     call setup_la_table;			/* Find appropriate table */
	     if code ^= 0
	     then go to char_to_tib_err;

	     if tty_hsla_sw
	     then do;
		expr_info.hwcm_addr = fnptab.hsla_mbx_addr (fnp, tty_la_no) + hwcm_len * tty_chan_no;
		expr_info.hwcm_known = "1"b;
		if fnptab.hsla_tib_addr (fnp, tty_la_no, tty_chan_no) = 0
		then go to char_to_tib_bad_arg;
		expr_info.tib_addr = fnptab.hsla_tib_addr (fnp, tty_la_no, tty_chan_no);
		expr_info.tib_known = "1"b;
		call db_fnp_memory_$fetch (corep, fnp, expr_info.hwcm_addr + h_sfcm, 1, addr (mem_word), code);
		if code ^= 0
		then go to char_to_tib_err;
		expr_info.sfcm_addr = bin (mem_word);
		expr_info.sfcm_known = "1"b;
	     end;
	     else do;
		if tty_chan_no < 0
		then call cv_lsla_slot_no;
		if tty_chan_no < 0 | tty_chan_no > 51
		then go to char_to_tib_bad_arg;
		if fnptab.lsla_tib_addr (fnp, tty_la_no, tty_chan_no) = 0
		then go to char_to_tib_bad_arg;
		expr_info.tib_addr = fnptab.lsla_tib_addr (fnp, tty_la_no, tty_chan_no);
		expr_info.tib_known = "1"b;
		expr_info.hwcm_addr = fnptab.lsla_hwcm_addr (fnp, tty_la_no);
		expr_info.hwcm_known = "1"b;
		expr_info.sfcm_addr = fnptab.lsla_sfcm_addr (fnp, tty_la_no);
		expr_info.sfcm_known = "1"b;
	     end;
	end;

	arg_code = 0;
	return;

char_to_tib_bad_arg:
	code = error_table_$bad_arg;
char_to_tib_err:
	arg_code = code;
	return;

/* Procedure that given a tty line number, computes a name */

cv_line_no:
     entry (arg_corep, arg_fnp, arg_tty_line_no, arg_tty_name, arg_code);

	call setup;
	tty_line_no = arg_tty_line_no;

	call parse_tty_line_no;			/* Break number into components */
	if tty_fnp_no < 0
	then do;					/* Error */
cv_line_bad:
	     arg_code = error_table_$bad_arg;
	     return;
	end;

	if ^tty_hsla_sw
	then do;
	     call setup_la_table;
	     if code ^= 0
	     then do;
		arg_code = code;
		return;
	     end;
	     call cv_lsla_slot_no;
	     if tty_chan_no < 0
	     then go to cv_line_bad;
	end;

	tty_name.fnp_name = get_fnp_name_ (max (arg_fnp, 1));
	tty_name.dot = ".";
	if tty_la_no = 7
	then do;
	     tty_name.la_type = "c";
	     tty_name.la_no, tty_name.chan_no = 0;
	end;

	else do;
	     if tty_hsla_sw
	     then tty_name.la_type = "h";
	     else tty_name.la_type = "l";
	     tty_name.la_no = tty_la_no;
	     tty_name.chan_no = tty_chan_no;
	end;

	arg_tty_name = string (tty_name);
	arg_code = 0;
	return;

/* Entry that given a name of a tty channel in either octal or ttyxxx form, returns the ttyname and the tty line number */

cv_chan_name:
     entry (arg_corep, arg_fnp, arg_chan_name, arg_tty_name, arg_tty_line_no, arg_code);

	call setup;
	arg_tty_line_no = 0;
	arg_tty_name = "";
	tty_line_no = cv_oct_check_ (arg_chan_name, code);/* Try octal */
	if code = 0
	then					/* Easy case, another entry already does this */
	     call cv_line_no (corep, arg_fnp, tty_line_no, arg_tty_name, code);
	else do;					/* Given ttyxxx form */
	     call parse_tty_name_ (arg_chan_name, tty_fnp_no, tty_hsla_sw, tty_la_no, tty_chan_no);
	     if tty_fnp_no < 0
	     then do;
cv_chan_bad:
		arg_code = error_table_$bad_arg;
		return;
	     end;
	     if arg_fnp > 0
	     then if tty_fnp_no ^= arg_fnp
		then				/* On wrong FNP */
		     go to cv_chan_bad;
	     if tty_hsla_sw
	     then					/* Compute line number for hsla */
		tty_line_no = 512 + 64 * tty_la_no + tty_chan_no;
	     else do;				/* Lslas are harder */
		call setup_la_table;		/* Need more data */
		tty_slot_no = fnptab.lsla_slot_no (fnp, tty_la_no, tty_chan_no);
		if tty_slot_no = 0
		then go to cv_chan_bad;
		tty_line_no = 64 * tty_la_no + tty_slot_no;
	     end;
	     arg_tty_name = arg_chan_name;		/* Just return name given */
	     code = 0;
	end;
	arg_tty_line_no = tty_line_no;
	arg_code = code;
	return;

/* Procedure to setup internal static fnp table */

setup_module_table:
     proc;

dcl  (i, j) fixed bin;
dcl  chainloc fixed bin;
dcl  1 chain aligned,				/* Entry in module chain */
       2 next bit (18) unal,
       2 name (6) bit (6) unal,
       2 start bit (18) unal,
       2 date (6) bit (6) unal;

	call validate_fnp_data;
	if code ^= 0
	then return;

	if fnptab.modtab_init (fnp)
	then return;				/* Table all setup */

	i = 0;
	call db_fnp_memory_$fetch (corep, fnp, crmod, 1, addr (chain.next), code);
						/* Get module chain start */
	if code ^= 0
	then return;
	chainloc = bin (chain.next);			/* First chain is here */

	do while ((chainloc ^= 0) & (i < hbound (fnptab.per_module, 2)));
	     call db_fnp_memory_$fetch (corep, fnp, chainloc, 6, addr (chain), code);
	     if code ^= 0
	     then return;
	     i = i + 1;
	     fnptab.start (fnp, i) = bin (chain.start);
	     mod_name = "";
	     do j = 1 to 6;				/* Convert name */
		substr (mod_name, j, 1) = xlate (bin (chain.name (j)));
	     end;
	     fnptab.name (fnp, i) = translate (mod_name, "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
	     do j = 1 to 6;				/* Convert date */
		substr (fnptab.date (fnp, i), j, 1) = xlate (bin (chain.date (j)));
	     end;
	     chainloc = bin (chain.next);		/* Next pointer */
	end;

	fnptab.nmodules (fnp) = i;
	fnptab.modtab_init (fnp) = "1"b;
	return;


     end setup_module_table;

/* Procedure to get the table for the current line adapter setup */

setup_la_table:
     proc;

	call validate_fnp_data;
	if code ^= 0
	then return;
	call setup_iom_table;			/* Need this first */
	if code ^= 0
	then return;
	if tty_hsla_sw
	then call setup_hsla_table;			/* Let some one else do the work */
	else call setup_lsla_table;
	return;

     end setup_la_table;

/* Procedure to find the iom table */

setup_iom_table:
     proc;

dcl  auto_iom_table (size (iom_table)) bit (36) aligned;	/* To read iom table into */
dcl  i fixed bin;

	if fnptab.iomtab_init (fnp)
	then return;				/* Only do this once */

	call db_fnp_memory_$fetch (corep, fnp, criom, 1, addr (word_buf), code);
	if code ^= 0
	then return;
	itblp = addr (auto_iom_table);
	call db_fnp_memory_$fetch (corep, fnp, bin (word_buf), 2 * size (iom_table), itblp, code);
	if code ^= 0
	then return;
	fnptab.lsla_tab_addr (fnp, *) = 0;
	fnptab.hsla_tab_addr (fnp, *) = 0;
	do i = lbound (iom_table, 1) to hbound (iom_table, 1);
						/* Pick out line adapters */
	     if iom_table.dev_type (i) = HSLA
	     then fnptab.hsla_tab_addr (fnp, i - h1ch) = bin (iom_table.table (i));
	     else if iom_table.dev_type (i) = LSLA
	     then fnptab.lsla_tab_addr (fnp, i - l1ch) = bin (iom_table.table (i));
	end;
	fnptab.iomtab_init (fnp) = "1"b;
	code = 0;
	return;

     end setup_iom_table;

/* Procedure to find all tib addresses for 1 hsla */

setup_hsla_table:
     proc;

dcl  auto_hsla_table (size (hsla_table)) bit (36) aligned;	/* To read hsla table into */
dcl  i fixed bin;

	if tty_chan_no < 0 | tty_chan_no > 31
	then go to bad_hsla;
	if ^fnptab.hslatab_init (fnp, tty_la_no)
	then do;					/* Only do this if new hsla */
	     i = fnptab.hsla_tab_addr (fnp, tty_la_no);	/* Address of hsla table */
	     if i = 0
	     then do;				/* Nothing on this hsla */
bad_hsla:
		code = error_table_$bad_arg;
		return;
	     end;
	     tblp = addr (auto_hsla_table);
	     call db_fnp_memory_$fetch (corep, fnp, i, 2 * size (hsla_table), tblp, code);
	     if code ^= 0
	     then return;
	     do i = lbound (hsla_table, 1) to hbound (hsla_table, 1);
						/* Copy addresses */
		fnptab.hsla_tib_addr (fnp, tty_la_no, i) = hsla_table.tib_addr (i);
	     end;
	     fnptab.hsla_mbx_addr (fnp, tty_la_no) = get_mbx_addr ("h");
	     fnptab.hslatab_init (fnp, tty_la_no) = "1"b;
	end;

	code = 0;
	return;

     end setup_hsla_table;

/* Procedure to find all the tib addresses for 1 lsla */

setup_lsla_table:
     proc;

dcl  auto_lsla_table (size (lsla_table)) bit (36) aligned;	/* To read lsla table into */
dcl  (i, j, k) fixed bin;
dcl  mem_word bit (18) unal;

	if ^fnptab.lslatab_init (fnp, tty_la_no)
	then do;					/* If not done yet */
	     i = fnptab.lsla_tab_addr (fnp, tty_la_no);	/* Addr of lsla table */
	     if i = 0
	     then do;
		code = error_table_$bad_arg;
		return;
	     end;
	     tblp = addr (auto_lsla_table);
	     call db_fnp_memory_$fetch (corep, fnp, i, 2 * size (lsla_table), tblp, code);
	     if code ^= 0
	     then return;
	     j, k = 0;
	     fnptab.lsla_tib_addr (fnp, tty_la_no, *) = 0;
	     fnptab.lsla_slot_no (fnp, tty_la_no, *) = 0;
	     do i = 1 to hbound (lsla_table, 1);	/* Copy all tib address */
		if lsla_table.slot_id (i) = "111"b
		then go to setup_lsla_done;
		if lsla_table.tib_addr (i) ^= k
		then do;				/* New tib */
		     fnptab.lsla_tib_addr (fnp, tty_la_no, j), k = lsla_table.tib_addr (i);
		     fnptab.lsla_slot_no (fnp, tty_la_no, j) = i;
		     j = j + 1;
		end;
	     end;
setup_lsla_done:
	     fnptab.lsla_hwcm_addr (fnp, tty_la_no) = get_mbx_addr ("l");
	     call db_fnp_memory_$fetch (corep, fnp, fnptab.lsla_hwcm_addr (fnp, tty_la_no) + h_sfcm, 1, addr (mem_word),
		code);
	     if code ^= 0
	     then return;
	     fnptab.lsla_sfcm_addr (fnp, tty_la_no) = bin (mem_word);
	     fnptab.lslatab_init (fnp, tty_la_no) = "1"b;
	end;

	code = 0;
	return;

     end setup_lsla_table;

/* Procedure line parse_tty_name that "parses" a line number */

parse_tty_line_no:
     proc;

	tty_fnp_no = -1;				/* Error flag */
	tty_hsla_sw = (tty_line_no >= 512);
	tty_chan_no = mod (tty_line_no, 64);
	tty_la_no = mod (divide (tty_line_no, 64, 17, 0), 8);
	if tty_line_no ^= (512 * bin (tty_hsla_sw, 1) + 64 * tty_la_no + tty_chan_no)
	then return;				/* Doesn't compute */
	if tty_hsla_sw
	then do;
	     if tty_la_no > 2 & tty_la_no ^= 7
	     then return;
	     if tty_la_no = 7			/* this should be T&D channel */
		& tty_chan_no ^= 63			/* but it isn't */
	     then return;
	end;
	else do;
	     if tty_la_no > 5
	     then return;
	     tty_slot_no = tty_chan_no;		/* This is really a time slot */
	     tty_chan_no = -1;			/* The subchannel isn't known */
	end;
	tty_fnp_no = 1;				/* No error */
	return;

     end parse_tty_line_no;

/* Procedure to convert from a lsla slot number to channel number */

cv_lsla_slot_no:
     proc;

dcl  i fixed bin;

	do i = lbound (fnptab.lsla_slot_no, 3) to hbound (fnptab.lsla_slot_no, 3);
	     if fnptab.lsla_slot_no (fnp, tty_la_no, i) = tty_slot_no
	     then do;
		tty_chan_no = i;
		return;
	     end;
	     if fnptab.lsla_slot_no (fnp, tty_la_no, i) > tty_slot_no
	     then do;
		tty_chan_no = i - 1;		/* Other than the first time slot of a channel */
		return;
	     end;
	end;
	return;					/* Couldn't do it */

     end cv_lsla_slot_no;

/* Procedure which checks to be sure that the static FNP data is still valid. */
/* The check is to see if times in the core image have changed */

validate_fnp_data:
     proc;

dcl  1 times aligned,
       2 bind_time fixed bin (71),
       2 boot_time fixed bin (71);

	call compute_constants;
	call db_fnp_memory_$fetch (corep, fnp, crldt, 8, addr (times), code);
						/* Get bind and boot time */
	if code ^= 0
	then return;
	if fnptab.bind_time (fnp) ^= times.bind_time | fnptab.boot_time (fnp) ^= times.boot_time
	then string (fnptab.init_switches (fnp)) = "0"b;
	fnptab.bind_time (fnp) = times.bind_time;
	fnptab.boot_time (fnp) = times.boot_time;
	return;

     end validate_fnp_data;


/* Procedure to computing the addresses of some constants in the 355 */

compute_constants:
     proc;

dcl  i fixed bin;

	if fnptabp = null ()
	then call get_temp_segment_ (name, fnptabp, code);

	if constants_computed
	then return;				/* Do this once per process */

	crldt = db_fnp_sym_util_$get_value (".crldt");
	crmod = db_fnp_sym_util_$get_value (".crmod");
	criom = db_fnp_sym_util_$get_value (".criom");
	crtdt = db_fnp_sym_util_$get_value (".crtdt");
	h_sfcm = db_fnp_sym_util_$get_value ("h.sfcm");
	l1ch = db_fnp_sym_util_$get_value ("l1ch");
	h1ch = db_fnp_sym_util_$get_value ("h1ch");
	hwcm_len = db_fnp_sym_util_$get_length ("hwcm");

	do i = lbound (fnptab.init_switches, 1) to hbound (fnptab.init_switches, 1);
	     string (fnptab.init_switches (i)) = "0"b;
	end;
	fnptab.bind_time = 0;			/* And all these numbers */
	fnptab.boot_time = 0;
	constants_computed = "1"b;
	return;

     end compute_constants;

/* Get address of a mailbox */

get_mbx_addr:
     proc (t) returns (fixed bin);

dcl  t char (1);
dcl  1 mb_name unal,
       2 type char (1) unal,
       2 num picture "9" unal,
       2 mb char (2) unal;

	mb_name.type = t;
	mb_name.num = tty_la_no + 1;
	mb_name.mb = "mb";
	return (db_fnp_sym_util_$get_value (string (mb_name)));

     end get_mbx_addr;



/* Initialization procedure to copy seg pointer and fnp args */

setup:
     proc;

	corep = arg_corep;
	if corep = null
	then fnp = arg_fnp;				/* Real fnp */
	else fnp = 0;
	return;

     end setup;

%include mcs_memory_map;


%include debug_fnp_data;

     end db_fnp_util_;




		    debug_fnp.pl1                   11/15/82  1816.2rew 11/15/82  1502.3      113373



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


/* DEBUG_FNP - A tool for analyzing FNP dumps and debugging FNP software. */

/* Written February 1977 by Larry Johnson */
/* Modified 7/24/78 by J. Stern to add buffer_status command */
/* Modified September 1978 by Larry Johnson for call_trace command */

debug_fnp: db_fnp: proc;

/* Automatic and related things */

dcl  code fixed bin (35);
dcl  i fixed bin;
dcl  fnp fixed bin;					/* Current fnp, if working on live fnp */
dcl  corep ptr;					/* Pointer to fnp core image in a segment */
dcl  arg_ptr ptr;
dcl  arg_len fixed bin;
dcl  arg char (arg_len) based (arg_ptr);

dcl 1 auto_expr_info like expr_info aligned automatic;
dcl 1 auto_cmd_info like cmd_info aligned automatic;
dcl 1 auto_env like env aligned automatic;

dcl 1 user_symbol_table aligned,
    2 cnt fixed bin,
    2 maxcnt fixed bin,
    2 entry (50) unal,
      3 one_symbol like sym unal;

/* Constants */

dcl  name char (9) int static options (constant) init ("debug_fnp");

/* Commands are numbered internally as follows:
   01 - fnp
   02 - dump
   03 - image
   04 - map
   05 - e
   06 - quit
   07 - convert_address
   08 - display
   09 - line
   10 - .
   11 - patch
   12 - =
   13 - what
   14 - why
   15 - regs
   16 - buffer
   17 - buffer_chain
   18 - set
   19 - set_break
   20 - start
   21 - reset_break
   22 - list_break
   23 - dump_dir
   24 - dumps
   25 - last_dump
   26 - prev_dump
   27 - trace_mask
   28 - start_trace
   29 - stop_trace
   30 - print_trace
   31 - select_fnp
   32 - next_dump
   33 - block
   34 - block_chain
   35 - flags
   36 - explain
   37 - buffer_status
   38 - call_trace
   39 - set_flag
   40 - clear_flag
   41 - idle_time
   42 - ic_sample
   43 - sample_time
   44 - mdisp_data
   45 - apropos
   46 - when */

/* List of commands and their abbreviations. An index in this array is translated by cmd_no into a command number */

dcl  cmd_list (61) char (16) int static options (constant) init (
     "fnp",					/* 1 */
     "dump",					/* 2 */
     "image",					/* 3 */
     "map",					/* 4 */
     "e",						/* 5 */
     "quit",					/* 6 */
     "q",						/* 7 */
     "convert_address",				/* 8 */
     "cva",					/* 9 */
     "display",					/* 10 */
     "d",						/* 11 */
     "line",					/* 12 */
     ".",						/* 13 */
     "patch",					/* 14 */
     "=",						/* 15 */
     "what",					/* 16 */
     "why",					/* 17 */
     "regs",					/* 18 */
     "buffer",					/* 19 */
     "buf",					/* 20 */
     "buffer_chain",				/* 21 */
     "bufc",					/* 22 */
     "set",					/* 23 */
     "set_break",					/* 24 */
     "sb",					/* 25 */
     "start",					/* 26 */
     "sr",					/* 27 */
     "reset_break",					/* 28 */
     "rb",					/* 29 */
     "list_break",					/* 30 */
     "lb",					/* 31 */
     "dump_dir",					/* 32 */
     "dumps",					/* 33 */
     "last_dump",					/* 34 */
     "prev_dump",					/* 35 */
     "trace_mask",					/* 36 */
     "start_trace",					/* 37 */
     "stop_trace",					/* 38 */
     "print_trace",					/* 39 */
     "select_fnp",					/* 40 */
     "next_dump",					/* 41 */
     "block",					/* 42 */
     "blk",					/* 43 */
     "block_chain",					/* 44 */
     "blkc",					/* 45 */
     "flags",					/* 46 */
     "explain",					/* 47 */
     "buffer_status",				/* 48 */
     "bstat",					/* 49 */
     "call_trace",					/* 50 */
     "trace_call",					/* 51 */
     "trace_calls",					/* 52 */
     "set_flag",					/* 53 */
     "clear_flag",					/* 54 */
     ".q",					/* 55 */
     "idle_time",					/* 56 */
     "ic_sample",					/* 57 */
     "sample_time",					/* 58 */
     "mdisp_data",					/* 59 */
     "apropos",					/* 60 */
     "when");					/* 61 */

/* This array maps the index of "cmd_list" into a command number */

dcl  cmd_no (61) fixed bin (11) unal int static options (constant) init (
     01, 02, 03, 04, 05, 06, 06, 07, 07, 08,		/* 01-10 */
     08, 09, 10, 11, 12, 13, 14, 15, 16, 16,		/* 11-20 */
     17, 17, 18, 19, 19, 20, 20, 21, 21, 22,		/* 21-30 */
     22, 23, 24, 25, 26, 27, 28, 29, 30, 31,		/* 31-40 */
     32, 33, 33, 34, 34, 35, 36, 37, 37, 38,		/* 41-50 */
     38, 38, 39, 40, 06, 41, 42, 43, 44, 45,		/* 51-60 */
     46);						/* 61 */

/* This array, indexed by command number says whether some fnp, dump, or
   core image must be selected before the command can be used. */

dcl  select_required (46) bit (1) unal int static options (constant) init (
     "0"b, "0"b, "0"b, "1"b, "0"b, "0"b, "0"b, "1"b, "1"b, "0"b, /* 01-10 */
     "1"b, "1"b, "0"b, "1"b, "1"b, "1"b, "1"b, "0"b, "1"b, "1"b, /* 11-20 */
     "1"b, "1"b, "0"b, "0"b, "0"b, "0"b, "1"b, "1"b, "1"b, "1"b, /* 21-30 */
     "1"b, "0"b, "1"b, "1"b, "0"b, "0"b, "1"b, "1"b, "1"b, "1"b, /* 31-40 */
     "1"b, "1"b, "1"b, "1"b, "0"b, "1"b);		/* 41-46 */

/* All commands are passed through the following entry array. */

dcl  cmd_entry (46) entry (ptr, fixed bin, ptr, ptr) variable init (
     db_fnp_env_$fnp_cmd,				/* 1 */
     db_fnp_env_$dump_cmd,				/* 2 */
     db_fnp_env_$image_cmd,				/* 3 */
     db_fnp_util_$print_module_table,			/* 4 */
     execute_command,				/* 5 */
     quit_command,					/* 6 */
     db_fnp_convert_address_,				/* 7 */
     db_fnp_disp_cmd_$display,			/* 8 */
     db_fnp_env_$line,				/* 9 */
     dot_command,					/* 10 */
     db_fnp_disp_cmd_$patch,				/* 11 */
     db_fnp_disp_cmd_$equal,				/* 12 */
     db_fnp_env_$what,				/* 13 */
     db_fnp_dumps_$why,				/* 14 */
     db_fnp_dumps_$regs,				/* 15 */
     db_fnp_disp_cmd_$buffer,				/* 16 */
     db_fnp_disp_cmd_$buffer_chain,			/* 17 */
     db_fnp_sym_util_$set_command,			/* 18 */
     db_fnp_break_$set,				/* 19 */
     db_fnp_break_$start,				/* 20 */
     db_fnp_break_$reset,				/* 21 */
     db_fnp_break_$list,				/* 22 */
     db_fnp_env_$dump_dir,				/* 23 */
     db_fnp_env_$dumps,				/* 24 */
     db_fnp_env_$last_dump,				/* 25 */
     db_fnp_env_$prev_dump,				/* 26 */
     db_fnp_trace_$mask,				/* 27 */
     db_fnp_trace_$start_trace,			/* 28 */
     db_fnp_trace_$stop_trace,			/* 29 */
     db_fnp_trace_$print_trace,			/* 30 */
     db_fnp_env_$select_fdump_fnp,			/* 31 */
     db_fnp_env_$next_dump,				/* 32 */
     db_fnp_disp_cmd_$block,				/* 33 */
     db_fnp_disp_cmd_$block_chain,			/* 34 */
     db_fnp_disp_cmd_$flags,				/* 35 */
     db_fnp_sym_util_$explain,			/* 36 */
     db_fnp_buffer_status_,				/* 37 */
     db_fnp_call_trace_,				/* 38 */
     db_fnp_disp_cmd_$set_flag,			/* 39 */
     db_fnp_disp_cmd_$clear_flag,			/* 40 */
     db_fnp_scheduler_$idle_time,			/* 41 */
     db_fnp_scheduler_$ic_sample,			/* 42 */
     db_fnp_scheduler_$sample_time,			/* 43 */
     db_fnp_scheduler_$mdisp_data,			/* 44 */
     db_fnp_sym_util_$apropos,			/* 45 */
     db_fnp_env_$when);				/* 46 */

/* External stuff */

dcl  com_err_ entry options (variable);
dcl  cu_$cp entry (ptr, fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$arg_count entry (fixed bin);
dcl  db_fnp_break_$list entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_break_$reset entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_break_$set entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_break_$start entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_buffer_status_ entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_call_trace_ entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_convert_address_ entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_disp_cmd_$flags entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_disp_cmd_$display entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_disp_cmd_$patch entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_disp_cmd_$equal entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_disp_cmd_$buffer entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_disp_cmd_$buffer_chain entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_disp_cmd_$block entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_disp_cmd_$block_chain entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_disp_cmd_$set_flag entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_disp_cmd_$clear_flag entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_dumps_$regs entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_dumps_$why entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_env_$fnp_cmd entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_env_$dump_cmd entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_env_$image_cmd entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_env_$dumps entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_env_$last_dump entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_env_$prev_dump entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_env_$next_dump entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_env_$select_fdump_fnp entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_env_$dump_dir entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_env_$what entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_env_$when entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_env_$line entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_env_$init entry (ptr);
dcl  db_fnp_env_$term entry (ptr);
dcl  db_fnp_reader_$get_command entry (ptr);
dcl  db_fnp_scheduler_$ic_sample entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_scheduler_$idle_time entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_scheduler_$mdisp_data entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_scheduler_$sample_time entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_sym_util_$apropos entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_sym_util_$set_command entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_sym_util_$explain entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_trace_$mask entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_trace_$print_trace entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_trace_$start_trace entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_trace_$stop_trace entry (ptr, fixed bin, ptr, ptr);
dcl  db_fnp_util_$print_module_table entry (ptr, fixed bin, ptr, ptr);
dcl  ioa_ entry options (variable);

dcl (cleanup, program_interrupt) condition;

dcl (addr, hbound, length, string) builtin;

/* Initialization */

	expr_infop = addr (auto_expr_info);
	cmd_infop = addr (auto_cmd_info);
	envp = addr (auto_env);
	cmd_info.flush = "1"b;
	cmd_info.envp = envp;
	expr_info.user_tablep = addr (user_symbol_table);
	user_symbol_table.cnt = 0;
	user_symbol_table.maxcnt = hbound (user_symbol_table.entry, 1);
	string (expr_info.flags) = "0"b;

	call db_fnp_env_$init (envp);			/* Initalize environment */
	fnp = env.fnp;
	corep = env.corep;
	on program_interrupt begin;
	     cmd_info.flush = "1"b;
	     go to next_cmd;
	end;
	on cleanup call db_fnp_env_$term (envp);

	call cu_$arg_count (i);
	if i > 0 then do;				/* There is an arg */
	     call cu_$arg_ptr (1, arg_ptr, arg_len, code);
	     cmd_info.inbuf = ";" || arg;
	     cmd_info.commandp = addr (cmd_info.inbuf);
	     cmd_info.commandl = arg_len + 1;
	     cmd_info.flush, cmd_info.error, cmd_info.endline = "0"b;
	end;


/* Command dispatcher */

next_cmd:						/* Everyone returns here for next command */
	call db_fnp_reader_$get_command (cmd_infop);
	do i = 1 to hbound (cmd_list, 1);		/* Check against all known commands */
	     if operand = cmd_list (i) then do;
		if select_required (cmd_no (i)) then
		     if ^(env.fnp_sw | env.dump_sw | env.image_sw) then do;
			call ioa_ ("No FNP, dump, or image selected.");
			cmd_info.flush = "1"b;
			go to next_cmd;
		     end;
		call cmd_entry (cmd_no (i)) (corep, fnp, cmd_infop, expr_infop);
		fnp = env.fnp;			/* In case changed */
		corep = env.corep;
		go to next_cmd;
	     end;
	end;
	call ioa_ ("Undefined command: ^a", operand);
	go to next_cmd;

/* Come here to stop command completely */

done:	call db_fnp_env_$term (envp);
	return;


/* DOT COMMAND - Doesn't do much */

dot_command: proc;

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

	end dot_command;

/* QUIT COMMAND - Ends the program */

quit_command: proc;

	     go to done;

	end quit_command;

/* EXECUTE COMMAND - pass rest of command line to the current command processor */

execute_command: proc;

	     call cu_$cp (addr (command), length (command), code);
	     cmd_info.flush = "1"b;			/* We dont look at rest of line */
	     return;

	end execute_command;

%include debug_fnp_data;

     end debug_fnp;






		    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
