



		    copy_dump_seg_.pl1              11/15/82  1847.9rew 11/15/82  1516.3       33831



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


copy_dump_seg_: proc (segno, cur_proc_ind, p_array, l_array, outptr, retlen);

/* Converted to 6180 and v2pl1 by R. Mullen Feb 1973 */
/* modified 11/14/80 by J. A. Bush for the DPS8/70M CPU */

dcl (segno, cur_proc_ind) fixed bin,			/* Parameters */
     retlen fixed bin (19),
    (p_array ptr,
     l_array fixed bin (19)) (0:31),
     outptr ptr;

dcl (orig, next_orig) fixed bin (35);

dcl (i, l, n, len, nsegs, idx, off,			/* Misc variables */
     next_off, seg_no, cpi, segn) fixed bin,
    (outp, p) ptr;

dcl  hcs_$get_max_length_seg entry (ptr, fixed bin (19), fixed bin (35));
dcl  hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35));
dcl (addrel, divide, fixed, mod) builtin;

dcl  array (n) fixed bin (35) based;
dcl  wps fixed bin (19);
% include bos_dump;
/* 
   Copy args first, then lookup segment # in image index */
	dumpptr = p_array (0);
	outp = outptr;
	seg_no = segno;
	cpi = cur_proc_ind;
	call hcs_$get_max_length_seg (dumpptr, wps, orig);
	if orig ^= 0 then go to err;

	nsegs = dumpptr -> dump.num_segs;
	orig = size (dump);				/* account for two page header */
	i = 1;

find_proc: if i = cpi then go to find_seg;
	orig = orig + fixed (dumpptr -> dump.segs (i).length, 18) * 64;
	i = i + 1;
	go to find_proc;

find_seg:	do i = cpi to nsegs;
	     segn = fixed (dumpptr -> dump.segs (i).segno, 18);
	     if segn = 0				/* Segment 0 is flag for new process */
	     then if i ^= cpi
		then go to err;			/* Insure that we stay within the current process */
	     if segn = seg_no			/* See if we've found desired seg */
	     then go to copy;
	     orig = orig + fixed (dumpptr -> dump.segs (i).length, 18) * 64; /* increment orig to next seg */
	end;					/* and look at next seg */

err:	retlen = 0;				/* error, can't find segment */
	return;

copy:
	if i ^= nsegs				/* If last seg of dump, use dump length */
	then next_orig = fixed (dumpptr -> dump.segs (i).length, 18) * 64 + orig;
	else next_orig = fixed (dumpptr -> dump.words_dumped, 35);
	len = next_orig - orig;
	if len <= 0
	then go to err;				/* Something messed up, return 0 */
						/* Length dumped is difference between current and next seg origins */
	idx = divide (orig, wps, 17, 0);		/* Get image-index for first word */
	off = mod (orig, wps);			/* And offset within the image segment */
	p = p_array (idx);
	l = l_array (idx) * 1024;
	next_off = len + off;			/* For checking bounds on seg */
	call hcs_$truncate_seg (outp, 0, orig);		/* Truncate output segment */
	if next_off <= wps				/* Does seg cross boundaries of image seg? */
	then do;					/* No, copy directly */

/* Since image is zero-suppressed from the end, can't run into trailing zeroes problem here */
	     n = len;				/* Set arg for move operation */
	     outp -> array = addrel (p, off) -> array;	/* Copy array */
	end;

	else do;
	     n = l - off;				/* If zeroes near the boundary, may get bounds fault */
	     if n > 0				/* May be leading zeroes */
	     then outp -> array = addrel (p, off) -> array; /* Very similar */
	     outp = addrel (outp, (wps - off));		/* Advance "outp" regardless of "l" */
	     n = next_off - wps;			/* Calculate second part */
	     outp -> array = p_array (idx + 1) -> array;
	end;
	retlen = len;				/* Finished */
     end copy_dump_seg_;




		    format_355_dump_line_.alm       11/15/82  1847.9rew 11/15/82  1533.9       37638



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

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	FORMAT_355_DUMP_LINE_
"
"	This is an alm program which is called by online_355_dump_ to
"	produce an ascii representation of 1 or more 355 words in octal.
"	It is called with three arguments: argument 1 is a pointer to the
"	input data. This pointer may have a bit offset in it but it must
"	be either 0 or 18 (i.e., the 355 words must be 18 bit aligned).
"	Argument 2 is the number of 355 18 bit words to be converted to
"	their ascii octal representation. Argument 3 is a pointer to the
"	place where the output is to be written. This pointer may have
"	a bit offset but it must be on a 9 bit (character) boundary.
"
"	This program has another entry point, 'line'. The first 3 args
"	are as above but the last four consist of two pointer, fixed
"	bin pairs that are to be converted to octal. That is, the 2 fixed
"	bin args are to be converted to octal and the result placed in
"	the locations specified by the pointers. The two fixed bin values
"	are location counters for placement in the dump line.
"
"
"	Originally written by R.B.Snyder 09/14/73
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	name	format_355_dump_line_
	entry	format_355_dump_line_
format_355_dump_line_:
	eppbp	ap|2,*		get ptr to ptr to input data
	ldaq	bp|0		get ptr to data in AQ
	qrl	9		shift bit count to ql
	anq	=o77,dl		isolate
	eax1	0,ql		copy to X1
	eppbp	bp|0,*		put pointer in bp
	ldq	ap|4,*		get 355 word count in q
	mpy	6,dl		compute number of octits
	eax3	0,ql		put in X3
	eppbb	ap|6,*		get pointer to pointer to output
	ldaq	bb|0		get ptr to output in AQ
	qrl	9		shift bit count to ql
	anq	=o77,dl		isolate
	div	9,dl		comput character number (0-3)
	qls	1		multiply char by 2
	eax2	0,ql		put char number*2 in X2
	eppbb	bb|0,*		put pointer to output in bb
	ldq	bp|0		get input
	qls	0,1		shift to get correct 18 bit word
	cmpx1	18,du		see if 18 or 36 bit aligned
	tnz	*+3
	eax1	6		18
	tra	*+2
	eax1	12		36
loop:
	lda	0,dl		clear A
	lls	3		get an octit into A-reg
	ora	=o60,dl		convert to ascii
	xed	store,2		store in output
	adx3	-1,du		decrement  character count
	tze	return		all done
	eax2	2,2		bump output character position
	cmpx2	8,du		see if done with current word
	tnz	*+3
	eax2	0		yes
	eppbb	bb|1		advance output pointer
	eax1	-1,1		decrement count of remaining octits
	cmpx1	6,du		time to insert blank?
	tze	insert_blank	yes
	cmpx1	0,du
	tnz	loop		no
insert_blank:
	lda	=o40,dl		get a blank
	xed	store,2		put in output string
	eax2	2,2		advance output index
	cmpx2	8,du
	tnz	*+3
	eax2	0
	eppbb	bb|1
	cmpx1	0,du		done with current word?
	tnz	loop		still more in Q-reg
	eax1	12		get new count of octits
	eppbp	bp|1		advance input pointer
	ldq	bp|0		get new word
	tra	loop
return:
	lda	ap|0		see if called with 3 args
	arl	18
	cmpa	6,dl
	tnz	line_entry	no - we were called at line entry point
real_return:
	short_return

	entry	line
line:
	eax4	0
	tra	format_355_dump_line_ do first 3 args
line_entry:
	cmpx4	8,du		have we gone thru both pairs
	tze	real_return	yes
	ldaq	ap|8,4		get ptr
	staq	ap|6		and substitute for third arg
	ldq	18,dl		put a bit offset in arg ptr so
	qls	9		common code will work
	orsq	ap|11,4		..
	eppbp	ap|10,4		get ptr to fixed bin number
	spribp	ap|2		store as first arg
	eppbp	=1		arg 2 is number of words to do
	spribp	ap|4
	eax4	4,4		bump call index
	tra	format_355_dump_line_



	even
store:
	als	9*3
	stba	bb|0,40
	als	9*2
	stba	bb|0,20
	als	9*1
	stba	bb|0,10
	nop	0,du
	stba	bb|0,04


	end




		    format_dump_line_.alm           11/15/82  1847.9rew 11/15/82  1534.0       39618



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


	name	format_dump_line_

	entry	format_dump_line_
	segdef	line_size		for od_print_

" dcl format_dump_line_ entry(ptr)

" call format_dump_line_(bufp)

" Gets input data from caller of its caller

	bool	two_zeroes,060060	Will be OR'ed in
	bool	two_pad,177177	Will be shifted

	set	get,0
	set	put,5

format_dump_line_:
	eppbp	ap|2,*
	eppbp	bp|0,*		Load pointer to buffer

	lda	two_sp_pad	Get two blanks
	sta	bp|put+3
	sta	bp|put+7
	sta	bp|put+11
	sta	bp|put+15
	sta	bp|put+19
	sta	bp|put+23
	sta	bp|put+27

	lda	nl
	sta	bp|put+31

	ldq	blanks		Get four blanks
	stq	bp|4		Separation between loc fields and 8-words

	eppap	sp|26,*		Get arg ptr of caller
	lda	ap|2,*		Convert "abs_loc"
	tmi	set_blanks	Not relevant, store blanks in field
	even;	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	two_zeroes,du
	stq	bp|1
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|0

	tra	pick_loc		Now format offset within seg

set_blanks:
" No absolute location, stuff in eight blanks
	stq	bp|0
	stq	bp|1

pick_loc:				" Convert offset value
	lda	ap|4,*		Second arg
	eaq	two_pad		Initialize
	even;	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	two_zeroes,du
	stq	bp|3

	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|2

	eppap	ap|6,*		Get pointer to data
	lda	ap|get
	even;	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|put+2
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|put+1
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|put+0

	set	get,get+1
	set	put,put+4

	lda	ap|get
	even;	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|put+2
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|put+1
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|put+0

	set	get,get+1
	set	put,put+4

	lda	ap|get
	even;	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|put+2
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|put+1
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|put+0

	set	get,get+1
	set	put,put+4

	lda	ap|get
	even;	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|put+2
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|put+1
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|put+0

	set	get,get+1
	set	put,put+4

	lda	ap|get
	even;	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|put+2
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|put+1
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|put+0

	set	get,get+1
	set	put,put+4

	lda	ap|get
	even;	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|put+2
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|put+1
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|put+0

	set	get,get+1
	set	put,put+4

	lda	ap|get
	even;	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|put+2
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|put+1
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|put+0

	set	get,get+1
	set	put,put+4

	lda	ap|get
	even;	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|put+2
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|put+1
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	lrl	3
	qrl	6
	orq	zeroes
	stq	bp|put+0

	set	put,put+4		One last update

	short_return

zeroes:	aci	"0000"
blanks:	aci	"    "		Four blanks

two_sp_pad:
	vfd	o36/177177040040	Two blanks between formatted words

nl:	vfd	o36/177177177012	NL char plus padding

line_size:
	vfd	36/put		Last updated value is size of buffer

	end	format_dump_line_	




		    format_fnp_trace_msg_.pl1       11/15/82  1847.9rew 11/15/82  1516.3       71172



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


/* FORMAT_FNP_TRACE_MSG_ - A procedure to interpret an FNP trace table entry */

/* Written May 1977 by Larry Johnson */
/* Modified August 1979 by Larry Johnson for better decoding of dia codes */

/* This module performs an ioa-like edit of a control string found in od355_msgs.
   There is one control for each kind of trace message. The string may contain
   only ^d, ^o, ^w, ^b, ^e, and ^f codes with their normal ioa_ meaning. In addition,
   the special request ^n* may be used, with the following meanings:

   ^1*	module|offset
   ^2*	opblock name
   ^3*	3rd word of jump table
   ^4*	dia mailbox opcode
   ^5*	alter parameters sub-code
*/

format_fnp_trace_msg_: proc (arg_tmsgp, arg_modchp, arg_string);

/* Parameters */

dcl  arg_tmsgp ptr;					/* Pointer to the trace table entry to interpret */
dcl  arg_modchp ptr;				/* Address of module chain */
dcl  arg_string char (*) var;				/* Where to put the result */

/* Automatic */

dcl (i, j) fixed bin;
dcl  p ptr;
dcl  argno fixed bin;				/* For counting args */
dcl  edit_temp char (50) var;

dcl  ctlp ptr;					/* Pointer to unprocess part of control string */
dcl  ctll fixed bin;				/* Its length */
dcl  ctl char (ctll) based (ctlp);

dcl  ctl_accp ptr;					/* Pointer to origional ACC control string */
dcl 1 ctl_acc aligned based (ctl_accp),
    2 length fixed bin (8) unal,
    2 msg char (ctl_acc.length) unal;

/* Format of a trace table entry */

dcl  tmsgp ptr;
dcl 1 tmsg unal based (tmsgp),
    2 module bit (6) unal,				/* Module that logged entry */
    2 type bit (6) unal,				/* Index into possible msgs for that module */
    2 length bit (6) unal,				/* Number of data words */
    2 time bit (18) unal,				/* Relative time message was logged */
    2 data (1) bit (18) unal;				/* Array of optional data words */

/* Format of module chain table */

dcl  modchp ptr;
dcl 1 modch aligned based (modchp),
    2 nmodules fixed bin,
    2 entries (modch.nmodules),
      3 name char (4),
      3 address fixed bin;

/* Format of the third word of a jump table */

dcl  jumptblp ptr;
dcl 1 jumptbl unal based (jumptblp),
    2 channel bit (4),
    2 device bit (2),
    2 subchan bit (5),
    2 module bit (7);

/* Things in od355_msgs */

dcl  od355_msgs$ ext;
dcl  od355_msgs$trace_modtab (1) bit (18) aligned ext;	/* Array of offsets for each module */
dcl  message_offsetsp ptr;
dcl  message_offsets (1) bit (18) aligned based (message_offsetsp); /* Offsets to the individual acc strings */

/* External */

dcl  ioa_$rsnpnnl entry options (variable);
dcl  db_fnp_opblock_util_$get_name entry (bit (18), char (*));
dcl  db_fnp_sym_util_$lookup_member entry (fixed bin, char (*), char (*));

dcl (addr, bin, hbound, index, lbound, length, ptr, substr, verify) builtin;

/* Find the origional control string in od355_msgs */

	tmsgp = arg_tmsgp;				/* Address of tracetable entry */
	modchp = arg_modchp;
	i = bin (tmsg.module);			/* Module number */
	j = bin (tmsg.type);			/* Message number for that module */
	p = addr (od355_msgs$);			/* For doing pointercalculations */
	message_offsetsp = ptr (p, bin (od355_msgs$trace_modtab (i))); /* Address of table of messages for the module */
	ctl_accp = ptr (p, bin (message_offsets (j)));	/* Address of ACC string */
	ctlp = addr (ctl_acc.msg);			/* For looking at text part */
	ctll = length (ctl_acc.msg);

/* Now parse the input "ioa_" string, editing each operand */

	call ioa_$rsnpnnl ("^.3b", arg_string, (0), tmsg.time); /* Start line with the time */
	arg_string = arg_string || " ";
	argno = 0;
	do while (ctll > 0);			/* Loop till string exhausted */
	     i = index (ctl, "^");			/* Look for next control */
	     if i = 1 then do;			/* Found one */
		i = verify (substr (ctl, 2), "0123456789."); /* Count digits */
		if substr (ctl, i+1, 1) ^= "*" then do; /* Normal ioa_ control */
		     argno = argno + 1;		/* Get next argument */
		     if substr (ctl, i+1, 1) = "b" then /* ^b requries a bit arg */
			call ioa_$rsnpnnl (substr (ctl, 1, i+1), edit_temp, (0), tmsg.data (argno));
		     else call ioa_$rsnpnnl (substr (ctl, 1, i+1), edit_temp, (0), bin (tmsg.data (argno), 18));
						/* Let ioa_ edit number */
		     arg_string = arg_string || edit_temp;
		end;
		else do;				/* Special dump edit request */
		     j = bin (substr (ctl, 2, i-1));	/* Decode request nubber */
		     argno = argno + 1;
		     call special_edit (j);
		end;
		ctlp = substraddr (ctl, i+2);		/* Next character to deal with */
		ctll = ctll - i - 1;
	     end;
	     else do;				/* The next char is not a "^" */
		if i = 0 then i = ctll;
		else i = i - 1;			/* Number of characters berore next "^" */
		arg_string = arg_string || substr (ctl, 1, i); /* Copy to string under construction */
		ctlp = substraddr (ctl, i+1);		/* Skip over them */
		ctll = ctll - i;
	     end;
	end;

/* All items have been turned into character rsults */

	return;


/* Procedure to perform special editing requests */

special_edit: proc (n);

dcl  n fixed bin;					/* The special type */
dcl  i fixed bin;
dcl  idx fixed bin;
dcl (diff, min_diff) fixed bin;
dcl  addr_val fixed bin;
dcl  opname char (6);
dcl  opval bit (18);

	     go to special_ed (n);

special_ed (1):					/* ^1* means edit as module|offset */

	     min_diff = 32768;
	     idx = 0;
	     addr_val = bin (tmsg.data (argno));
	     do i = 1 to modch.nmodules;
		diff = addr_val - modch.address (i);
		if diff >= 0 then
		     if diff < min_diff then do;
			idx = i;
			min_diff = diff;
		     end;
	     end;
	     if idx = 0 then call ioa_$rsnpnnl ("^6w", edit_temp, (0), addr_val); /* No conversion */
	     else call ioa_$rsnpnnl ("^o (^a|^o)", edit_temp, (0), addr_val, modch.name (idx), min_diff);
	     arg_string = arg_string || edit_temp;
	     return;

special_ed (2):					/* ^2* means explain opblock number */

	     i = bin (tmsg.data (argno));
	     substr (opval, 1, 9) = "777"b3;		/* rebuild opblock */
	     substr (opval, 10, 9) = bit (bin (i, 9), 9);
	     call db_fnp_opblock_util_$get_name (opval, opname);
	     if opname = "" then opname = "?";

	     call ioa_$rsnpnnl ("^3w (^a)", edit_temp, (0), i, opname);
	     arg_string = arg_string || edit_temp;
	     return;

special_ed (3):					/* ^3* means third word of jump table */

	     jumptblp = addr (tmsg.data (argno));
	     call ioa_$rsnpnnl ("^.3b (ch=^o dv=^o subch=^o mod=^o)", edit_temp, (0),
		tmsg.data (argno),
		bin (jumptbl.channel, 4),
		bin (jumptbl.device, 2),
		bin (jumptbl.subchan, 5),
		bin (jumptbl.module, 7));
	     arg_string = arg_string || edit_temp;
	     return;

special_ed (4):					/* ^4* means dia opcode */
	     call db_fnp_sym_util_$lookup_member (bin (tmsg.data (argno)), "diaop", opname);
	     call ioa_$rsnpnnl ("^o (^a)", edit_temp, (0), bin (tmsg.data (argno)), opname);
	     arg_string = arg_string || edit_temp;
	     return;

special_ed (5):					/* ^5* means alter paramaters code */
	     call db_fnp_sym_util_$lookup_member (bin (substr (tmsg.data (argno), 1, 9)), "alterp", opname);
	     call ioa_$rsnpnnl ("^o (^a)", edit_temp, (0), bin (tmsg.data (argno)), opname);
	     arg_string = arg_string || edit_temp;
	     return;

	end special_edit;

/* 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;

     end format_fnp_trace_msg_;




		    get_ast_name_.pl1               01/26/85  1314.2r w 01/22/85  1311.1       19188



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


get_ast_name_: proc (a_astep, a_sstp, a_sstnp, retstr);

dcl (a_astep, a_sstp, a_sstnp) ptr;

dcl  retstr char (*);
%include sst;
%include sstnt;
%include aste;


	astep = a_astep;
	sstp = a_sstp;
	sstnp = a_sstnp;

	if fixed (rel (astep), 18) < fixed (rel (sstp -> sst.astap), 18) then do;
fail:	     retstr = "CANNOT GET PATHNAME";
	     return;
	end;

	if rel (astep) = rel (sstp -> sst.root_astep) then do;
	     retstr = ">";
	     return;
	end;

	retstr = recurse (astep, length (retstr));
	return;

recurse:	proc (astep, namel) returns (char (*));

dcl (ptsi, ra) fixed bin;
dcl  namel fixed bin;

dcl  astep ptr, name char (32) varying;

	     ra = fixed (rel (astep), 18);		/* for ease */
	     if ra < fixed (rel (sstp -> sst.astap), 18) then go to fail;
	     do ptsi = 3 to 0 by -1 while (ra < sstnp -> sstnt.ast_offsets (ptsi));
	     end;
	     if ptsi < 0 then go to fail;

	     if ptsi ^= fixed (astep -> aste.ptsi, 2) then go to fail;

	     name = sstnp -> sstnt.names (
		divide (ra - sstnp -> sstnt.ast_offsets (ptsi),
		sstnp -> sstnt.ast_sizes (ptsi), 18, 0) +
		sstnp -> sstnt.ast_name_offsets (ptsi));

	     if length (name) = 0 then name = "CANNOT-GET";

	     if astep -> aste.par_astep = rel (sstp -> sst.root_astep) then do;
		if length (name) >= namel then return ("");
		else return (">" || name);
	     end;


	     if namel = 1 then return (">");
	     if length (name) >= namel then return (
		recurse (ptr (astep, astep -> aste.par_astep),
		namel -1) || ">");

	     return (recurse (ptr (astep, astep -> aste.par_astep),
		namel - length (name) - 1)
		|| ">" || name);
	end;
     end;




		    get_dump_ptrs_.pl1              11/15/82  1847.9rew 11/15/82  1516.4       33786



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


get_dump_ptrs_: proc (erfno, pa, la, nsegs, name);

dcl  erfno char (*),
    (pa ptr,
     la fixed bin) (0:31),
     nsegs fixed bin,
     name char (32) aligned,
     d_dir char (*);

/* This program gets pointers to all of the segments of
   a multics on-line dump given the error report form number of the
   dump. It returns the pointers in the array 'pa' and the number of
   pointers returned in 'nsegs'. It also returns the name of the
   first dump segment in 'name'.

   Coded 4/71 SHW */
/* Modified 02/01/79 by F. W. Martinson to allow up to 32 dump segments */
/* Modified 06/29/79 by J. A. Bush to add the dump_dir entry point */

dcl  code fixed bin (35);
dcl (i, count) fixed bin,
    (dumpdir char (168) int static,
    (dump_name,
     star_name,
     char32 based) char (32),
     c0 char (0)) aligned,
    (eptr, nptr, areap) ptr,
     star_area area ((128)),

     hcs_$star_ entry (char (*) aligned, char (*) aligned, fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)),
     hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     hcs_$status_long entry (char (*) aligned, char (*) aligned, fixed bin (1), ptr, ptr, fixed bin (35));
dcl (addr, fixed, null, substr) builtin;

declare 1 br aligned,
       (2 (type bit (2), nnames bit (16), nrp bit (18)),
        2 dtm bit (36),
        2 dtu bit (36),
        2 (mode bit (5), pad1 bit (13), records bit (18)),
        2 dtd bit (36),
        2 dtem bit (36),
        2 acct bit (36),
        2 (curlen bit (12), bitcnt bit (24)),
        2 (did bit (4), imdid bit (4),
         copysw bit (1), pad3 bit (9),
         rbs (0:2) bit (6)),
        2 uid bit (36)) unaligned;

/* 
   */

	dumpdir = ">dumps";				/* set default dump directory */
join:
	areap = addr (star_area);			/* get a pointer to the star area */
	star_name = "*.*.0." || erfno;		/* generate star name */

	call hcs_$star_ (dumpdir, star_name, 2, areap, count, eptr, nptr, code);
						/* get first dump seg name */
	if code = 0
	then do;					/* No problems, continue */

	     dump_name = nptr -> char32;		/* copy name of first dump seg */
	     name = dump_name;			/* return name to caller */

	     areap = addr (br);			/* Get pointer to branch structure */

	     do i = 0 to 31;			/* Initiate the dump segments */

		call hcs_$initiate (dumpdir, dump_name, c0, 0, 1, eptr, code); /* initiate the dump seg */
		if eptr = null
		then do;				/* no more segs, return */

		     nsegs = i;			/* return number of segs found */
		     return;

		end;

/* We will allow up to 32 dump segments 0-31 */

		pa (i) = eptr;			/* Copy pointer */
		call hcs_$status_long (dumpdir, dump_name, 1, areap, null, code);
		if code ^= 0
		then la (i) = 0;
		else la (i) = fixed (br.curlen, 17);
		substr (dump_name, 13) = ltrim (char (i+1))||"."||ltrim (erfno);
						/* generate the next dump seg name */

	     end;

	end;

	nsegs = 0;				/* Fell out of loop, or error in star_ call */
	return;

/* dump_dir - entry to get dump ptrs, given a dump directory name */

dump_dir:	entry (d_dir, erfno, pa, la, nsegs, name);

	dumpdir = d_dir;				/* copy dump directory */
	go to join;				/* and go to common code */


     end get_dump_ptrs_;




		    od355_msgs.alm                  11/15/82  1847.9rew 11/15/82  1452.6       88587



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

"
"	This module is used by online_355_dump_ to translate trace table
"	entries into intelligible messages
"
	name	od355_msgs
	segdef	trace_modtab
	segdef	die_list
"
"
"
"		the module table is indexed by module number, and the
"		message tables pointed to by the module table entries
"		are indexed by trace type
"
trace_modtab:
	zero	skdtrc
	zero	diatrc
	zero	inttrc
	zero	utltrc
	zero	lsltrc
	zero	hsltrc


"	trace messages are in the form for pseudo-ioa control strings
"	They may contain ^o, ^w, ^d, ^b, ^e, and ^f operations with their
"	normal meaning. Also, they may contain special editing requests
"	in the form ^n*. The following special requests are defined:

"		^1* - edit address in form module|offset
"		^2* - edit name of opblock, given its number
"		^3* - edit third word of jump table
"		^4* - edit dia mailbox opcode
"		^5* - edit 'alter parameters' code



skdtrc:
	zero	msg1.1
	zero	msg1.2
	zero	msg1.3
	zero	msg1.4
	zero	msg1.5
	zero	msg1.6
	zero	msg1.7
	zero	msg1.8

msg1.1:	acc	'interrupt at ^5w, 3wjt ^3*'
msg1.2:	acc	'idle, indicators ^6w, ier ^6w'
msg1.3:	acc	'run interrupt routine ^6w'
msg1.4:	acc	'restart interrupted routine at ^6w'
msg1.5:	acc	'run queued routine ^6w'
msg1.6:	acc	'set timer ^6w for tib ^6w'
msg1.7:	acc	'interval timer runout, current time ^6w ^6w'
msg1.8:	acc	'queue routine, pri ^6w, rtn ^6w, x1 ^6w'

diatrc:
	zero	msg2.1
	zero	msg2.2
	zero	msg2.3
	zero	msg2.4
	zero	msg2.5
	zero	msg2.6
	zero	msg2.7
	zero	msg2.8
	zero	msg2.9
	zero	ms2.10
	zero	ms2.11
	zero	ms2.12

msg2.1:	acc	'dia terminate, tcword = ^2w'
msg2.2:	acc	'dia interrupt for mailbox ^2w'
msg2.3:	acc	'dia reading mailbox ^2w'
msg2.4:	acc	'new entry in dia i/o queue at ^6w: opcode ^4*, line ^4w'
msg2.5:	acc	'wcd in mailbox ^2w: opcode ^4*, line ^4w'
msg2.6:	acc	'using dia i/o queue entry at ^6w: opcode ^4*, line ^4w'
msg2.7:	acc	'dia sending input count of ^6w for line ^4w'
msg2.8:	acc	'dia writing mailbox ^2w'
msg2.9:	acc	'dia freeing mailbox ^2w'
ms2.10:	acc	'wtx in mailbox ^2w for line ^4w, ^3w buffers'
ms2.11:	acc	'rtx in mailbox ^2w for line ^4w'
ms2.12:	acc	'alter parameters: ^5*'

inttrc:

	zero	msg3.1
	zero	msg3.2
	zero	msg3.3
	zero	msg3.4
	zero	msg3.5

msg3.1:	acc	'itest: tib at ^6w, t.cur = ^1*'
msg3.2:	acc	'iwrite: tib at ^6w, t.cur = ^1*'
msg3.3:	acc	'istat: tib at ^6w, t.cur = ^1*, status ^6w'
msg3.4:	acc	'itime: tib at ^6w, t.cur = ^1*'
msg3.5:	acc	'op block at ^1*, type = ^2*'


utltrc:
	zero	msg4.1
	zero	msg4.2
	zero	msg4.3
	zero	msg4.4

msg4.1:	acc	'buffer allocated at ^o (^o words) by ^1*, x1=^o'
msg4.2:	acc	'buffer freed at ^o (^o words) by ^1*, x1=^o'
msg4.3:	acc	'request for ^o buffers (^o words) by ^1*, x1=^o'
msg4.4:	acc	'buffer list at ^o freed by ^1*, x1=^o'

lsltrc:

	zero	msg5.1
	zero	msg5.2
	zero	msg5.3
	zero	msg5.4
	zero	msg5.5
	zero	msg5.6
	zero	msg5.7

msg5.1:	acc	'lsla interrupt, 3wjt = ^3*'
msg5.2:	acc	'lsla output frame at ^6w, sfcm at ^6w'
msg5.3:	acc	'lsla output buffer at ^6w'
msg5.4:	acc	'lsla input frame at ^6w, sfcm at ^6w'
msg5.5:	acc	'lsla input buffer at ^6w'
msg5.6:	acc	'sending ^3w to lsla slot ^2w for line ^4w'
msg5.7:	acc	'escape in lsla slot ^2w for line ^4w'


hsltrc:
	zero	msg6.1
	zero	msg6.2
	zero	msg6.3
	zero	msg6.4
	zero	msg6.5

msg6.1:	acc	'hsla dcw processor, tib ^6w, list ^1*, len ^2w'
msg6.2:	acc	'hsla pcw, tib ^6w, pcw ^6w ^6w'
msg6.3:	acc	'hsla interrupt, 3wjt = ^3*'
msg6.4:	acc	'hsla status, tib ^6w, status ^6w ^6w'
msg6.5:	acc	'hsla, tib ^6w, attempting icw indicator recovery'

"
die_list:
	aci	'scheduler   '
	zero	0,sked_messages

	aci	'dia_man     '
	zero	0,dia_messages

	aci	'interpreter '
	zero	0,intp_messages

	aci	'utilities   '
	zero	0,util_messages

	aci	'lsla_man    '
	zero	0,lsla_messages

	aci	'hsla_man    '
	zero	0,hsla_messages

	aci	'console_man '
	zero	0,cons_messages

	aci	'trace       '
	zero	0,trac_messages

	aci	'init        '
	zero	0,init_messages


sked_messages:
	zero	sked_1
	zero	sked_2

dia_messages:
	zero	dia_1
	zero	dia_2
	zero	dia_3
	zero	dia_4
	zero	dia_5
	zero	dia_6
	zero	dia_7
	zero	dia_8
	zero	dia_9
	zero	dia_10
	zero	dia_11
	zero	dia_12
	zero	dia_13
	zero	dia_14
	zero	dia_15
	zero	dia_16
	zero	dia_17
	zero	dia_18
	zero	dia_19
	zero	dia_20
	zero	dia_21
	zero	dia_22


intp_messages:
	zero	intp_1
	zero	intp_2
	zero	intp_3
	zero	intp_4
	zero	intp_5
	zero	intp_6
	zero	intp_7
	zero	intp_8
	zero	intp_9
	zero	intp_10
	zero	intp_11
	zero	intp_12
	zero	intp_13
	zero	intp_14
	zero	intp_15
	zero	intp_16
	zero	intp_17
	zero	dia_10


util_messages:
	zero	util_1
	zero	util_2
	zero	util_3
	zero	util_4
	zero	util_5
	zero	util_6
	zero	intp_7
	zero	util_8
	zero	util_9
	zero	util_10
	zero	util_11
	zero	util_12
	zero	util_13
	zero	util_14


lsla_messages:
	zero	lsla_1
	zero	util_8
	zero	util_9
	zero	lsla_4
	zero	lsla_5
	zero	intp_6
	zero	intp_7
	zero	lsla_8
	zero	lsla_9
	zero	dia_10
	zero	lsla_11


hsla_messages:
	zero	hsla_1
	zero	hsla_2
	zero	hsla_3
	zero	hsla_4
	zero	hsla_5
	zero	hsla_6
	zero	hsla_7
	zero	hsla_8
	zero	dia_10
	zero	hsla_10
	zero	no_message
	zero	hsla_12
	zero	hsla_13


cons_messages:
	zero	no_message


trac_messages:
	zero	no_message


init_messages:
	zero	dia_10
	zero	init_2
	zero	init_3
	zero	init_4
	zero	init_5
	zero	init_6
	zero	bad_init
	zero	init_8
	zero	init_9
	zero	init_10
	zero	init_11
	zero	init_12
	zero	init_13
	zero	init_14
	zero	init_15


sked_1:	acc	'no buffers for delay queue'
sked_2:	acc	'attempt to run missing routine'


dia_1:	acc	'mailbox wraparound queue full'
dia_2:	acc	'unrecoverable i/o error'	h
dia_3:	acc	'more than 5 consecutive i/o errors'	h
dia_4:	acc	'invalid value for tcw'
dia_5:	acc	'mailbox queue count < 0'
dia_6:	acc	'invalid mailbox number in wraparound queue'
dia_7:	acc	'3 consecutive mailbox checksum errors'	h
dia_8:	acc	'op-code not valid for i/o command'
dia_9:	acc	'rcd processed with no queue entries'
dia_10:	acc	'buffer allocation failed'
dia_11:	acc	'last buffer in input chain lacks "last" flag'
dia_12:	acc	'tally for rtx too small'
dia_13:	acc	'tally for rtx too large'
dia_14:	acc	'attempt to lock already locked dia'
dia_15:	acc	'attempt to unlock already unlocked dia'
dia_16:	acc	'rtx in mailbox, next queue element not accept input'
dia_17:	acc	'unrecognized i/o command'
dia_18:	acc	'no dia configured'
dia_19:	acc	'accept input when no input chain'
dia_20:	acc	'attempt to chain to invalid output chain'
dia_21:	acc	'input buffer had zero tally'
dia_22:	acc	'no entry for line in tib list'


intp_1:	acc	'x1 = 0 at entry'
intp_2:	acc	't.cur = 0 at entry'
intp_3:	acc	'called when not at wait block'
intp_4:	acc	'type not of form 777xxx'
intp_5:	acc	'tried to execute status block'
intp_6:	acc	'unrecognized sub-op in dcw list'
intp_7:	acc	'outmsg not followed by output_end'
intp_8:	acc	'unrecognized op block'
intp_9:	acc	'started block check while check in progress'
intp_10:	acc	'compare block check without start block check'
intp_11:	acc	'unrecognized scan type'
intp_12:	acc	't.type <= 0'
intp_13:	acc	'error in use of calsub, retsub op blocks'
intp_14:	acc	'error in use of getext, retext op blocks'
intp_15:	acc	'error in scan control string'
intp_16:	acc	'invalid sub-op list to config op'
intp_17:	acc	'replay attempted with active output chain'


util_1:	acc	'buffer of size <= 0 requested'
util_2:	acc	'buffer of more than max size requested'
util_3:	acc	'tried to free buffer with address < .crbuf'
util_4:	acc	'tried to free space already free'
util_5:	acc	'address in block pointer too large'
util_6:	acc	'invalid interrupt vector'
util_8:	acc	'kybd/prtr addressing with control set'
util_9:	acc	'unrecognized type in output sub-op'
util_10:	acc	'could not allocate buffer for output'
util_11:	acc	't.olst -> buffer has forward pointer'
util_12:	acc	'free block size too large'
util_13:	acc	'attempt to append output to single-message chain'
util_14:	acc	'attempt to move data with an invalid address'


hsla_1:	acc	'attempt to modify loc < 1000(8)'
hsla_2:	acc	'config op is invalid for channel'
hsla_3:	acc	'read tally started with active input chain'
hsla_4:	acc	'receive transfer timing error'	h
hsla_5:	acc	'input tally runout'
hsla_6:	acc	'unable to find cct for modes requested'
hsla_7:	acc	'xmit transfer timing error'	h
hsla_8:	acc	'hdcw called with no dcw list'
hsla_10:	acc	'no sfcm addr for line'
hsla_12:	acc	'houtav called with bad chain'
hsla_13:	acc	'invalid hsla status'


lsla_1:	acc	'not in xmit mode after output sub-op'
lsla_4:	acc	'more than 10 successive re-sync attempts'
lsla_5:	acc	'send transfer timing error'	h
lsla_8:	acc	'unrecognized receive status'
lsla_9:	acc	'input icw status does not agree with flag'
lsla_11:	acc	'output icw status does not agree with flag'


no_message:
	acc	'unrecognized error code'

init_2:	acc	'timer channel not enabled'
init_3:	acc	'more than one dia configured'
init_4:	acc	'dia does not exist'
init_5:	acc	'dia did not respond'
init_6:	acc	'invalid baud rate specified'
init_8:	acc	'core image specified more memory than physically present'
init_9:	acc	'lsla ^o illegal sync speed'
init_10:	acc	'lsla ^o failed ten times to init'
init_11:	acc	'lsla ^o speed not equal desired speed'
init_12:	acc	'timer switch incorrectly set'
init_13:	acc	'lsla ^o, actual config does not match CDT'
init_14:	acc	'pager is disabled or inoperative'
init_15:	acc	'unable to allocate trace buffer'
bad_init:	acc	'unrecognized config status ^s^w'

	end




		    od_print_.pl1                   11/15/82  1847.9rew 11/15/82  1516.5       36153



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


/* "ioa_" for on-line dumper, generates page headers etc. */
/* converted to 6180, v2pl1 by R Mullen Feb 1973 */

od_print_: proc (num_nl) recursive;			/* Calls itself to print page headings */

dcl  num_nl fixed bin;

dcl (bufp ptr,
    (linect, cur_word_no, erf_no, proc_no, seg_no, page_no,
     zero init (0),
     two init (2),
     three init (3),
     wpl) fixed bin,
    (ioname char (32) init ("od_output_"),
     time_string char (24),				/* date and time */
     fmtheader char (51)
     init ("^|^-ERF ^d^3-^a^3-Page ^3d^2-Process ^d, Seg ^3o^2/"),
     buffer char (4104)) aligned) int static,		/* 4096 + 8 characters of slop */
     status bit (72) aligned,				/* for ios_ calls */
     p ptr,
    (i,						/* Misc */
     fmt_sw,					/* 0 - fast 8 words, 1 - regular format */
     n,						/* length of formatted string */
     nnl) fixed bin;				/* # of NL chars in formatted string */

declare 1 fun based aligned,				/* For adding NL plus PAD */
        2 fill char (n) unaligned,
        2 ny bit (36) unaligned;

dcl  formline_ entry (fixed bin, fixed bin, ptr, fixed bin, fixed bin),
     format_dump_line_ entry (ptr),			/* Plus three args passed to "od_print_" */
     ios_$write entry (char (*) aligned, ptr, fixed bin, fixed bin, fixed bin, bit (72) aligned),
     date_time_ entry (fixed bin (52), char (*) aligned),
     od_print_ entry options (variable);

dcl  format_dump_line_$line_size ext fixed bin;

dcl (addr, addrel, divide) builtin;

/* 
   Format the output line. */

	fmt_sw = 1;				/* not special, do formatting */
	nnl = num_nl;

test_page:					/* First see if page overflow */
	if nnl >= 0
	then do;

	     if (linect + nnl) > 54			/* Check for page overflow. */
	     then do;

		linect = -3;			/* Reset line counter. */
		page_no = page_no + 1;		/* Increment the page number. */
		call od_print_ (three, fmtheader,
		erf_no, time_string, page_no, proc_no, seg_no);
						/* Print out page heading. */
	     end;

	     linect = linect + nnl;			/* Now update the counter */

	end;

	p = addrel (bufp, cur_word_no);		/* Pointer to space to generate new text */

	if fmt_sw ^= 0
	then do;

	     n = 256;				/* Allow for multi-line formats */
	     call formline_ (two, three, p, n, zero);

	     p -> fun.ny = "000001010001111111001111111001111111"b;
						/* Add NL char plus PADs */

	     cur_word_no = cur_word_no + divide (n + 4, 4, 17, 0);

	end;

	else do;

	     call format_dump_line_ (p);
	     cur_word_no = cur_word_no + wpl;

	end;

	if cur_word_no > 960			/* 1024 - 64 */
	then do;

	     n = cur_word_no * 4;			/* Convert words to characters */
	     cur_word_no = 0;			/* and reset counter */

	     call ios_$write (ioname, bufp, 0, n, i, status);

	end;

	return;

op_fmt_line: entry (num_nl);				/* Nominally */

	nnl = 1;
	fmt_sw = 0;

	go to test_page;

/* 
   Miscellaneous entry points */

op_finish: entry;

	if cur_word_no = 0
	then return;

	n = cur_word_no * 4;			/* Same as before */
	cur_word_no = 0;				/* .. */

	call ios_$write (ioname, bufp, 0, n, i, status);

	return;

op_new_seg: entry (segno);

dcl  segno fixed bin;

	seg_no = segno;
	if seg_no = 0
	then proc_no = proc_no + 1;

op_new_page: entry;

	linect = 54;

	return;

op_init:	entry (erfno, time_val);

dcl  erfno fixed bin,
     time_val fixed bin (52);

	erf_no = erfno;
	call date_time_ (time_val, time_string);

	wpl = format_dump_line_$line_size;
	bufp = addr (buffer);
	cur_word_no = 0;
	page_no = 0;
	proc_no = 0;
	seg_no = 0;
	linect = 54;

     end od_print_;




		    od_stack_.pl1                   11/05/86  1504.5r w 11/04/86  1034.3       98451



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


od_stack_: proc (stackptr, stacklen, sltp, namp, sstp, sstnp);

/* Coded by RE Mullen June 73 */

/* Called with pointer to a stack, the stack's length,
   and pointers to an SLT and name_seg */

dcl (stackptr, sp_next, sp_curr, lineptr) ptr;
dcl (stacklen, i, frame_no, depth, slen, fword, sword, segno, spoff, case, fsize) fixed bin;
dcl  stackwords (0: 1) fixed bin (35) aligned based (sb);
dcl (addr, baseno, baseptr, addrel, max, min, mod, ptr, null, fixed, rel) builtin;
dcl  od_print_$op_fmt_line entry (fixed bin, fixed bin, fixed bin (35));
dcl  od_print_ entry options (variable);
dcl (curptr, lastptr) ptr;

dcl  plural char (1) aligned;
dcl  nskip fixed bin;
dcl  fmtskip char (21) aligned int static init ("^-^7o line^a repeated");
dcl 1 dbl based aligned,
    2 (zero, two, four, six) fixed bin (71);
dcl (entinfo, retinfo) char (128) aligned init ("");

/*
dcl  od_frame_owner_ entry (ptr, ptr, ptr, ptr, ptr, char (*) aligned, char (*) aligned);
*/
dcl (sltp, ptr_to_entry, namp, ptr_to_return, sstp, sstnp) ptr;
dcl (subsysfrms, save_slen) fixed bin init (0);
dcl (save_sp_next, save_sp, last_sp) ptr;
dcl  subsysflag fixed bin init (0);
% include its;
% include stack_frame;
% include stack_header;

/*  */
	sp, sb = stackptr;				/* initialize and copy args */
	slen = stacklen;				/* the length of the stack we will dump */

	sp_next = stack_header.stack_begin_ptr;		/* we will do a forward trace */
	segno = fixed (baseno (sp_next));		/* this is the segno the dead stack had */
	call check_sp_next;
	if case <= 4 then do;			/* its a pointer and spoff is set to rel (sp_next) */
	     if segno = 49 then if spoff = 272 then sp_next = addrel (sp_next, 48); /* PRDS has bug in it . . . */
	end;


/* Prelim. trace to see if any next_sp = stack_end_ptr, if so
   the frame will be number zero implying its owner was running */

	do frame_no = 0 by 1;
	     call check_sp_next;			/* internal proc to keep from being too gullible */
	     if case ^= 0 then go to bad;		/* sp_next loses */
	     if addr (stack_header.stack_end_ptr) -> its.its_mod ^= "100011"b then go to bad;/* not its? */
	     if addr (stack_header.stack_end_ptr) -> its.mod ^= "000000"b then go to bad; /* not its? */
	     if spoff > fixed (rel (stack_header.stack_end_ptr), 18) then do; /* spoff has been set to offset of sp_next */
		case = 10;			/* FOR DEBUGGING */
		go to bad;
	     end;
	     if sp_next = stack_header.stack_end_ptr then go to good; /* this frame will be number zero . . */
	     sp = ptr (sb, spoff);			/* advance to next frame, but fudge segno  */
	     sp_next = stack_frame.next_sp;		/* pick up new sp_next */


	end;

bad:	frame_no = 0;				/* if stack was bad or not active, number frames from 0 up */
good:	



/* Now loop through th frames. At the beginning of each
   iteration sp will point to a frame to be printed (eg. sp = 334|2740),
   and sword will be the relative offset from the base of thestack
   of the first word of the frame.  If that frames next_sp is good
   then sp will be advanced and the current frame will be printed.
   If next_sp is bad then the remainder of the stack will
   be dumped.  Also any frames jumped over by syserr will
   be broken out with number "XX" */
	curptr, sp, sb = stackptr;			/* reinitialize */
	slen = stacklen;				/* in case we tampered with anything */
	sp_next = stack_header.stack_begin_ptr;		/* again trace forward */
	call check_sp_next;
	if case <= 4 then do;			/* sp_next is ptr and spoff is set to rel (sp_next) */
	     if segno = 49 then if spoff = 272  then sp_next = addrel (sp_next, 48); /* PRDS has bug in it . . . */
	     sp_curr = ptr (sp_next, 0);		/* back pointers will be checked against this */
	end;
	sword = 0;				/* offset from base of the first word of a line to be printed */
	ptr_to_entry, ptr_to_return = null;		/* for stack header */
	subsysfrms = 0;				/* will = 1 if looking at frame jumped over by syserr */

	do i = 0 by 1;				/* only way out of loop is if sword >= slen */
below_syserr: 					/* come here when i must no increase */
	     call check_sp_next;			/* which will advance spoff and set case */
	     if case ^= 0 then go to dump_rest;		/* print this frame heading and rest of stack */

	     last_sp = sp;				/* save this in case we find frames preserved by syserr */
	     sp = ptr (sb, spoff);			/* advance sp to next frame */

	     if (i > 0 & i - frame_no >= 0) | subsysfrms = 1 then do; /* skip these tests low on the stack */
		if addr (stack_frame.prev_sp) -> its.its_mod ^= "100011"b then go to dump_rest; /* not its? */
		if addr (stack_frame.prev_sp) -> its.mod ^= "000000"b then go to dump_rest;/* furth. mod? */
		if addr (sp_curr) -> its.its_mod ^= "100011"b then go to dump_rest;/* not its? */
		if addr (sp_curr) -> its.mod ^= "000000"b then go to dump_rest;/* furth. mod? */

		if baseno (sp_curr) ^= baseno (stack_frame.prev_sp) then go to dump_rest; /* another segno? */
		if rel (sp_curr) ^= rel (stack_frame.prev_sp) then go to dump_rest; /* back pointer bad? */
	     end;

	     if spoff = 12288 then if subsysfrms = 0 then do; /* probable syserr frame */
		subsysfrms = 1;			/* detour to see what is between here and syserr */
		save_slen = slen;			/* remember the length of the stack */
		save_sp = sp;			/* and the address of the syserr frame */
		save_sp_next = sp_next;		/* and the stacks internal representation of same */
		slen = 12288;			/* only want to print up to the syserr frame for now */
		sp = last_sp;			/* reset sp to previous frame */
		sp_next = ptr_to_entry;		/* and pick up sp_next from where syserr saves it */
		go to below_syserr;			/* retry the above with fudged sp_next */
	     end;

	     fsize = fixed (rel (sp_next), 18) - fixed (rel (sp_curr), 18); /* size of frame to be printed */
	     go to print_frame;			/* and print it knowing there will be another frame */

dump_rest:     fsize = slen - sword;			/* no next frame */

print_frame:   

	     retinfo, entinfo = "";			/* don't know anything yet */

/*
	     call od_frame_owner_ (ptr_to_return, ptr_to_entry, sltp, namp, sstp, sstnp, retinfo, entinfo);
*/
	     if subsysflag = 0 then			/* a mainline frame with a number */
	     call od_print_ (2, "^/^3-STACK FRAME ^d	^a", i - frame_no, retinfo); /* print the info */
	     else					/* this frame has been jumped over by syserr, no number */
	     call od_print_ (2, "^/^3-STACK FRAME XX	^a", retinfo);

	     if entinfo ^= "" then			/* entinfo may be in retinfo, or may be absent */
	     call od_print_ (2, "^5-entry_ptr: ^a^/", entinfo);
	     else
	     call od_print_ (2, "^/");
	     if subsysfrms = 1 then subsysflag = 1;	/* frame no = XX for now */

	     nskip = 0;				/* have skiped no lines so far this frame */
	     do fword = 0 by 8 while (fword < fsize);	/* loop to print contents of frame */
		if fword ^= 0 then			/* dont check for repeat on first line */
		if lastptr -> dbl.zero = curptr -> dbl.zero then /* see if current line same al last printed line */
		if lastptr -> dbl.two = curptr -> dbl.two then
		if lastptr -> dbl.four = curptr -> dbl.four then
		if lastptr -> dbl.six = curptr -> dbl.six then do;
		     nskip = nskip + 1;		/* note that another line has been skipped */
		     go to SKIP;			/* and skip printing the line */
		end;
		if nskip > 0 then do;		/* before printing a line check backlog of skipped lines */
		     if nskip > 1 then plural = "s"; else plural = " "; /* more than one? */
		     call od_print_ (1, fmtskip, nskip, plural); /* tell how many */
		     nskip = 0;			/* these are accounted for */
		end;
		call od_print_$op_fmt_line (sword, fword, stackwords (sword)); /* now print the line */
		lastptr = curptr;			/* future lines will be compared to this one */
SKIP:						/* come here if line was to be skipped */
		sword = sword + 8;			/* want to move to next line in any case */
		curptr = addrel (curptr, 8);		/* and advance pointer to it also */
	     end;					/* leave loop when frame is printed */
	     if nskip > 0 then do;			/* could have skipped a lot of lines lately */
		if nskip > 1 then plural = "s"; else plural = " "; /*  */
		call od_print_ (1, fmtskip, nskip, plural); /* tell how many */
	     end;
	     if sword >= slen then do;		/* whole stack may be done . . . */
		if subsysfrms = 1 then do;
		     subsysfrms = 0;		/* in which case we want to continue */
		     subsysflag = 0;		/* print frame num not XX from now on */
		     slen = save_slen;		/* reset to real lenght of stack */
		     sp = save_sp;			/* reset sp to point to syserr frame */
		     sp_next = save_sp_next;		/* reset */
		end;
		else go to ALLDONE;			/* actually at end of stack */
	     end;

	     sp_curr = sp_next;			/* advance internal representation */
	     ptr_to_entry = stack_frame.entry_ptr;	/* sp -> next frame to be printed, which is known to be good */
	     if fixed (stack_frame.translator_id, 18) = 2	/* Version I pl1 */
	     then ptr_to_return = stack_frame.pointer_registers (0);
	     else ptr_to_return = stack_frame.return_ptr;	/* ret ptr in exptected place */
	     sp_next = stack_frame.next_sp;		/* pick up foward pointer */
	     if subsysfrms = 1 then go to below_syserr;	/* so frame nums won't increase */
	end;
ALLDONE:						/* exit from above loop by coming here */
	return;




/* -------------------------------------------------------------------------- */


check_sp_next: proc;				/* verifies that sp_next might point to next stack frame */


	     if addr (sp_next) -> its.mod = "000000"b then /* if sp_next is not too fancy */
	     if addr (sp_next) -> its.its_mod = "100011"b then do; /* and if it is an its pointer */
		spoff = fixed (rel (sp_next), 18);	/* then pick up word offset portion */
		if fixed (baseno (sp_next), 18) = segno then /* if segno is good */
		if spoff <= slen -stack_frame_min_length then /* if spoff is not too big */
		if mod (spoff, 16) = 0 then		/* and mod16 */
		if spoff >= fixed (rel (sp), 18) + stack_frame_min_length then /* and further up the stack */
		case = 0;				/* then its possible sp_next points to a sack frame */
		else case = 1;			/* sp_next not forword enough */
		else case = 2;			/* sp_next not mod16 */
		else case = 3;			/* sp_next points off end of what stack we have */
		else case = 4;			/* sp_next points into some other segment */
	     end;
	     else case = 5;				/* sp_next is not a pointer */
	     else case = 6;				/* sp_next has further modification */

	     return;
	end check_sp_next;

     end od_stack_;




		    online_355_dump_.pl1            07/21/86  1518.9rew 07/21/86  1507.9      170334



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

/* format: off */

online_355_dump_: proc (a_dumpp, number);

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
   *
   *	online_355_dump_
   *
   *	This is a subroutine to produce a dump suitable for printing from a fnp
   *	fdump. This subroutine is called with a pointer to the dump to be printed
   *	and with the stream name "od_output_" already attached to the output device.
   *
   *	Originally written by Dick Snyder 05/31/73
   *	Modified for new 355 software by Robert Coren 04/01/75
   *	Modified for multiple 355s by Robert Coren 10/08/75
   *	Modified for new communications region and to add crash message by Robert Coren 06/24/76
   *	Modified 79 May 16 by Art Beattie to support 64K fnp dumps.
   *
   * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */


/****^  HISTORY COMMENTS:
  1) change(85-05-31,Farley), approve(86-07-10,MCR7247),
     audit(86-07-18,Fawcett), install(86-07-21,MR12.0-1099):
     Allow for upto 256k FNP memory sizes (phx19295).
                                                   END HISTORY COMMENTS */


/*	EXTERNAL ENTRIES		*/


dcl  ios_$write ext entry (char (*), ptr, fixed bin, fixed bin, fixed bin, bit (72) aligned);
dcl  com_err_ ext entry options (variable);
dcl  ioa_$rsnnl ext entry options (variable);
dcl  ioa_$rs ext entry options (variable);
dcl  format_355_dump_line_$line ext entry (ptr, fixed bin, ptr, ptr, fixed bin, ptr, fixed bin);
dcl  format_355_dump_line_ ext entry (ptr, fixed bin, ptr);
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  format_fnp_trace_msg_ entry (ptr, ptr, char (*) var);
dcl  get_fnp_name_ entry (fixed bin) returns (char (32));


/*	AUTOMATIC STORAGE 		*/


dcl  faultp pointer;				/* points to fault data */
dcl  a_dumpp pointer;
dcl  number fixed bin;				/* fnp identifier */
dcl  st bit (72) aligned;				/* ios status word */
dcl  st_code fixed bin based (statp);			/* overlay for left half of st */
dcl  statp pointer;					/* points to st */
dcl  dumpp pointer;					/* argument copied to local variable for better code */
dcl (i, k, nelemt);					/* scratch temps */
dcl  retstring char (132);				/* string returned by ioa_$rsnnl */
dcl  retp pointer;					/* points to retstring */
dcl  retl fixed bin;				/* number of valid chars in retstring */
dcl  date_time_bound char (24);
dcl  date_time_booted char (24);
dcl  type char (5);					/* fault type */
dcl  octal char (200);				/* string written by format_355_dump_line_ */
dcl  octalp pointer;				/* points to octal */
dcl  next_module_start fixed bin;			/* address of base of a module */
dcl  dup_copy bit (144) based;			/* for copying 8 fnp words */
dcl  mem_size fixed bin (18) unsigned;			/* size of fnp memory */
dcl  mod_chain fixed bin;				/* start of module chain */
dcl  locs_to_dump fixed bin (18) unsigned;		/* number of words left to dump */
dcl  rel_addr fixed bin init (0);			/* rell address in current module being dumped */
dcl  curlp pointer;					/* points to current line being dumped in fnp image */
dcl  dupp pointer;					/* points to last non-duplicate line */
dcl  cur_loc fixed bin init (0);			/* current loc being dumped in fnp image */
dcl  cur_chain fixed bin (18) unsigned;			/* offset in dump of current module chain block */
dcl  modx fixed bin;				/* current index into module chain */
dcl  module_name char (12);
dcl  module_num fixed bin;
dcl  die_ptr ptr;
dcl  reasonp ptr;
dcl  ch_val fixed bin;
dcl  trace_edit char (128) var;
dcl  print_trace bit (1) init ("1"b);			/* ON - try printing trace data */

/*	BASED			*/

dcl  bit36 bit (36) unal based;			/* used to overlay module name in fnp module chain */
dcl  first_200_words bit (7200) aligned based (dumpp);	/* used to check if fnp core is all zero */

dcl  message_offsets (1) bit (18) aligned based;		/* list of message offsets (per module) */

dcl 1 die_reason based (reasonp) aligned,
    2 length fixed bin (8) unaligned,
    2 msg char (0 refer (die_reason.length)) unaligned;

dcl 1 die_word based (die_ptr),			/* format of illegal op word used to crash fnp */
    2 mod_num bit (4) unaligned,
    2 op_code bit (5) unaligned,
    2 reason fixed bin (8) unaligned;

dcl  dump_chars (16) bit (9) unaligned based (curlp);

/*	STRUCTURES		*/

dcl 1 core_fnpb aligned based (dumpp),			/* overlay for fnp dump in 18 bit pieces */
    2 words (0: MEM_256K - 1) bit (18) unaligned;

dcl 1 core_fnp aligned based (dumpp),			/* overlay for fnp dump in packed fixed bin */
    2 words (0: MEM_256K - 1) fixed bin (17) unaligned;


dcl 1 dump_line aligned,				/* dump line */
    2 abs_addr char (6) unaligned,			/* absolute fnp address */
    2 star char (1) unaligned,			/* duplicate line indicator */
    2 space1 char (1) unaligned,			/* blank */
    2 module char (4) unaligned,			/* module name */
    2 space2 char (1) unaligned,			/* blank */
    2 rel_addr char (6) unaligned,			/* rel address in module */
    2 space3 char (3) unaligned,			/* blanks */
    2 eight_words char (55) unaligned,			/* dump line itself */
    2 space4 char (2) unaligned,			/* blanks */
    2 ascii (16) char (1) unaligned,			/* ascii of dump_line */
    2 nl char (1) unaligned;				/* new line */

dcl 1 fault_data aligned based (faultp),		/* to overlay fault data in fnp */
    2 regs (9) fixed bin (17) unaligned,
    2 fault_number fixed bin (17) unaligned,
    2 fault_name bit (18) unaligned;

dcl 1 octal_overlay (50) unaligned based (addr (octal)),	/* to get at 6 chars at a time in octal */
    2 word char (6) unaligned,			/* octal representation of 1 fnp word */
    2 space char (1) unaligned;			/* a space */

dcl 1 modch aligned,				/* information provided by module chain */
    2 nmodules fixed bin,
    2 entries (30),
      3 name char (4),
      3 address fixed bin (24);

/*	INTERNAL STATIC */

dcl  MEM_24K fixed bin (19) uns int static options (constant) init (24576);
dcl  MEM_32K fixed bin (19) uns int static options (constant) init (32768);
dcl  MEM_64K fixed bin (19) uns int static options (constant) init (65536);
dcl  MEM_128K fixed bin (19) uns int static options (constant) init (131072);
dcl  MEM_256K fixed bin (19) uns int static options (constant) init (262144);

dcl  die_op bit (5) int static options (constant) init ("01001"b);

dcl  faults (0: 10) char (16) int static options (constant) init (
     "POWER OFF ", "POWER ON  ", "MEMORY PARITY", "ILLEGAL OPCODE", "OVERFLOW  ",
     "STORE FAULT", "DIVIDE CHECK", "ILLEGAL INT", "EXTRA INT ", "IOM FAULT", "CONSOLE ABORT");

dcl  xlate (0: 63) char (1) int static 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", "_", ",", "%", "=", """", "!");

dcl  end_of_table bit (18) int static init ("101010101010101000"b); /* physical end of trace table pattern */
dcl  logical_end bit (18) int static init ("101010101010101010"b); /* logical end of trace table pattern */
dcl  nl char (1) int static options (constant) init ("
");



/*	EXTERNAL STATIC */

dcl  od355_msgs$ fixed bin ext static;

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

/* BUILTINS */

dcl (addr, addrel, bin, bit, fixed, length, ptr, string, substr, unspec) builtin;

/* INCLUDE FILES */

%include mcs_memory_map;

	memp,
	     dumpp = a_dumpp;			/* copy argument for better access code */
	statp = addr (st);				/* init random pointers */
	octalp = addr (octal);
	retp = addr (retstring);

	if first_200_words = "0"b then return;		/* assume in this case there's no core */

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
   *
   *	PRINT OUT DUMP HEADER
   *
   * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

	call date_time_ (comm_reg.crldt, date_time_bound);
	call date_time_ (comm_reg.crbdt, date_time_booted);

	call ioa_$rsnnl ("^2/^3-DATANET FNP MEMORY DUMP^2/FNP ^a, MCS Version ^a^/Bound ^a^/Booted ^a^3/",
	     retstring, retl, get_fnp_name_ (number), comm_reg.crver,
	     date_time_bound, date_time_booted);	/* format dump header */
	call ios_$write ("od_output_", retp, 0, retl, nelemt, st); /* output the string */
	if st_code ^= 0 then do;			/* error? */
err:
	     call com_err_ (st_code, "online_355_dump_", "Attempted to write to output file."); /* bitch */
	     return;
	end;


/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
   *
   *	PRINT OUT FAULT DATA
   *
   *	Print cause of fault, and regs in the following order:
   *
   *	IC, Indicators, A, Q, X1, X2, X3, Enable Register, Elapsed Timer
   *
   * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

	faultp = addr (core_fnp.words (comm_reg.crreg));	/* make pointer to fault data */
	if fault_data.fault_number > 7 then type = "ABORT"; /* not a processor fault */
	else type = "FAULT";
						/* format fault/abort message */
	if fault_data.fault_number = 3		/* illegal opcode */
	then do;
	     die_ptr = addr (core_fnp.words (fault_data.regs (1) - 1)); /* get word it died on */
	     if die_word.op_code = die_op		/* software-induced crash */
	     then do;
		module_num = bin (die_word.mod_num, 4);
		module_name = od355_msgs$die_list (module_num).name;

		reasonp = ptr (addr (od355_msgs$), od355_msgs$die_list (module_num).offset);
		reasonp = ptr (reasonp, reasonp -> message_offsets (die_word.reason));

		call ioa_$rsnnl ("CRASH REASON:^2/^a: ^a^3/", retstring, retl, module_name, reasonp -> die_reason.msg);
		call ios_$write ("od_output_", retp, 0, retl, nelemt, st);
		if st_code ^= 0 then go to err;
	     end;
	end;

	if fault_data.regs (1) = 0 then		/* no fault if IC = 0 */
	     call ioa_$rsnnl ("^a: ^a^2/", retstring, retl, type, "NONE      ");
	else call ioa_$rsnnl ("^a: ^a^2/", retstring, retl, type, faults (fault_data.fault_number));
	call ios_$write ("od_output_", retp, 0, retl, nelemt, st); /* output it */
	if st_code ^= 0 then go to err;		/* error */

	call format_355_dump_line_ (addr (fault_data.regs (1)), 9, octalp); /* get regs in octal */
						/* format regs output line */
	call ioa_$rsnnl ("IC ^a, IR ^a, A ^a, Q ^a, X1 ^a, X2 ^a, X3 ^a, ER ^a, ET ^a^/",
	     retstring, retl, octal_overlay (1).word, octal_overlay (2).word, octal_overlay (3).word,
	     octal_overlay (4).word, octal_overlay (5).word, octal_overlay (6).word, octal_overlay (7).word,
	     octal_overlay (8).word, octal_overlay (9).word);

	call ios_$write ("od_output_", retp, 0, retl, nelemt, st); /* output it */
	if st_code ^= 0 then go to err;		/* error */

	mem_size = comm_reg.crmem;			/* copy out fnp mem size for better code */
	if mem_size ^= MEM_24K - 1 then		/* check for clobbered mem size */
	     if mem_size ^= MEM_32K - 1 then
		if mem_size ^= MEM_64K - 1 then
		     if mem_size ^= MEM_128K - 1 then
			if mem_size ^= MEM_256K - 1
			then do;			/* memory really messed up */
			     mem_size = MEM_64K - 1;	/* use 64K if clobbered */
			     print_trace = "0"b;	/* better not try to do trace */
			end;
			else;
		     else;
		else;
	     else;
	else;

/* * * * * * * * * * * * * * * * * * * * * * *  * * * * *
   *
   *	PRINT OUT MODULE CHAIN
   *
   *	Search through fnp module chain and print out module names
   *	and starting addresses, also saving them for later use.
   *
   * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */


	modch.nmodules = 0;
	cur_chain = comm_reg.crmod;			/* get beginning of module chain */
	if cur_chain ^= 0
	then if cur_chain < mem_size then do;		/* if there's anything in it, print header */
		call ioa_$rs ("^3/MODULE CHAIN", retstring, retl);
		call ios_$write ("od_output_", retp, 0, retl, nelemt, st);
	     end;

	do i = 1 by 1 while (cur_chain > 0 & cur_chain < mem_size);
	     modch.address (i) = core_fnp.words (cur_chain+3); /* get address from chain entry */
						/* convert bcd module name */
	     do k = 1 to 4;				/* in module chain block */
						/* get ascii translation */
		substr (modch.name (i), k, 1) = xlate (fixed (substr (addr (core_fnpb.words (cur_chain+1)) -> bit36,
		     (k-1)*6+1, 6), 6));
	     end;
	     modch.nmodules = modch.nmodules + 1;

	     call ioa_$rs ("^6x^4a  ^5o", retstring, retl, modch.name (i), modch.address (i));
	     call ios_$write ("od_output_", retp, 0, retl, nelemt, st);

	     cur_chain = core_fnp.words (cur_chain);	/* chase chain */
	end;

	modch.address (i) = MEM_32K;			/* no module is loaded above 32K */
	modch.name (i) = "";
	modch.address (i+1) = MEM_256K + 1;		/* mark last entry so address won't pass it */


/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
   *
   *	PRINT OUT CONTENTS OF TRACE TABLE
   *
   *	Find the oldest entry in the trace table and then print all
   *	the entries in order of age. The first word of an entry is a coded 18-bit
   *	word which consists of three fields. The first 6 bits contain the number
   *	of the module that made the entry; the next 6 bits contain
   *	the trace type within the module; and the last 6 bits contain
   *	the number of data words in the entry. This word is followed by
   *	an 18-bit clock time and a variable number of data items.
   *	The logical end of the trace table is marked by a word containing
   *	the pattern 525252(8).
   *
   * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */



	if print_trace then do;
	     mod_chain = comm_reg.crmod;		/* do validity checking on trace pointers */
	     if comm_reg.crtrb <= mod_chain | comm_reg.crtrb > mem_size |
	     comm_reg.crtrc <= mod_chain | comm_reg.crtrc > mem_size
	     then go to skip_trace_print;

	     if core_fnp.words (comm_reg.crtrc) = 0 then go to skip_trace_print;

	     call ioa_$rsnnl ("^3/^3-TRACE TABLE^3/", retstring, retl); /* format trace table header */
	     call ios_$write ("od_output_", retp, 0, retl, nelemt, st); /* output it */
	     if st_code ^= 0 then go to err;		/* error */

	     i = comm_reg.crtrc;			/* put current trace index in i */
trace_start:
	     if core_fnpb.words (i) = end_of_table then do; /* at end of trace table? */

		i = comm_reg.crtrb;			/* reset trace index to start of table */
		go to trace_start;			/* look some more */
	     end;

	     if core_fnpb.words (i) = logical_end then go to trace_done; /* found end of table */

	     call format_fnp_trace_msg_ (addr (core_fnpb.words (i)), addr (modch), trace_edit);
	     retstring = trace_edit || nl;
	     call ios_$write ("od_output_", retp, 0, length (trace_edit) + 1, nelemt, st);
	     if st_code ^= 0 then go to err;

	     i = i + bin (substr (core_fnpb.words (i), 13, 6)) + 2; /* bump to next entry */
						/* (include header and time words) */
	     go to trace_start;
	end;
	else do;

skip_trace_print:
	     call ioa_$rsnnl ("^3/Dump of trace data not attempted.  The comm_reg appears to be inconsistent.", retstring, retl);
	     call ios_$write ("od_output_", retp, 0, retl, nelemt, st);
	     if st_code ^= 0 then go to err;
	end;

trace_done:


/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
   *
   *	DUMP CONTENTS OF MEMORY
   *
   *	Each print line will consist of four fields. The first is the
   *	absolute address being printed followed possibly by a "*" if
   *	some lines were skipped due to duplication. The second is the
   *	name of the module in the area being dumped (or blanks if no
   *	module. The third is the relative address within that module,
   *	and the fourth is the octal representation of 8 18 bit words.
   *
   * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */



	dump_line.space1, dump_line.space2, dump_line.space3, dump_line.space4,
	     dump_line.module, dump_line.star = "";	/* init blanks */
	dump_line.nl = nl;
	call ioa_$rsnnl ("^|^3-MEMORY DUMP^3/", retstring, retl); /* output header */
	call ios_$write ("od_output_", retp, 0, retl, nelemt, st);
	if st_code ^= 0 then go to err;		/* error */

	locs_to_dump = mem_size;			/* get size of fnp core */
	modx = 1;					/* initialize module chain index */
	next_module_start = modch.address (1);		/* and next module's starting address */

	curlp = dumpp;				/* init current line pointer for dup line checking */
	go to skip_dup_test;
mem_dump_loop:
	if curlp -> dup_copy = dupp -> dup_copy then do;	/* check for duplicate lines */
	     dump_line.star = "*";			/* print out a star on next line to show dup */
	     go to dup_line;
	end;

skip_dup_test:
	dupp = curlp;				/* save prt to current line for dup checking */
	call format_355_dump_line_$line (curlp, 8, addr (dump_line.eight_words),
	     addr (dump_line.abs_addr), cur_loc, addr (dump_line.rel_addr), rel_addr); /* format a dump line */

	do i = 1 to 16;				/* format ascii data */
	     ch_val = fixed (dump_chars (i), 17);
	     if ch_val < 32 | ch_val > 126 then ch_val = 32;
	     unspec (dump_line.ascii (i)) = bit (fixed (ch_val, 9), 9);
	end;
	call ios_$write ("od_output_", addr (dump_line), 0, length (string (dump_line)), nelemt, st); /* output the line */
	if st_code ^= 0 then go to err;		/* error */
	dump_line.star = " ";

dup_line:
	rel_addr = rel_addr + 8;			/* bump rel and abs addresses */
	cur_loc = cur_loc +8;
	locs_to_dump = locs_to_dump - 8;		/* see if done yet */
	if locs_to_dump <= 0 then do;

	     if dump_line.star = "*" then do;		/* last line of dump always gets displayed */
		rel_addr = rel_addr - 8;
		cur_loc = cur_loc - 8;
		go to skip_dup_test;
	     end;
	     call ioa_$rsnnl ("^/**DUMP FINISHED**^|", retstring, retl); /* let there be no misunderstanding */
	     call ios_$write ("od_output_", retp, 0, retl, nelemt, st);
	     if st_code ^= 0 then go to err;

	     return;				/* all done */
	end;

	curlp = addrel (curlp, 4);			/* bump pointer to next line */
	if cur_loc >= next_module_start then do;	/* if we are dumping a new module */

	     if cur_loc >= MEM_32K then rel_addr = cur_loc; /* reset relative address */
	     else rel_addr = cur_loc - next_module_start;
	     dump_line.module = modch.name (modx);	/* set name */
	     modx = modx + 1;			/* point to next chain entry */
	     next_module_start = modch.address (modx);

skip_chain_code:
	end;
	go to mem_dump_loop;			/* continue on */


     end online_355_dump_;




		    online_dump.pl1                 01/26/85  1314.2r w 01/22/85  1311.1      303102



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


/* ONLINE-DUMP --- process dump image created by BOS */
/* od_355 entry added by R. Mullen May 1973 */
/* modified for multiple fnps by Robert Coren 10/08/75 */
/* modified 7/25/76 by Noel I. Morris for MR4.1 */
/* modified 79 Aug 14 by Art Beattie to handle longer erf numbers and identify entry called to com_err_. */
/* modified 2/24/81 by J. A. Bush for larger fdump header size */

online_dump: od: proc;

dcl  procname char (16);				/* Identification for com_err_ calls */

dcl  arg char (argl) based (argp),			/* Variables used to access arguments */
     argp ptr,
     argl fixed bin;

dcl (erf_no char (18) aligned,			/* First arg aligned, ERF # */
     name char (32)) aligned;				/* Returned by "get_dump_ptrs_" */

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

dcl  num fixed bin init (1);
dcl  n_blocks fixed bin;
dcl  n_first fixed bin;

dcl (ioname init ("od_output_"),			/* Arguments for I/O attachment */
     iotype init ("prtdim"),
     ioname2 init ("prta")) char (168) aligned int static;

dcl  get_dump_ptrs_ entry (char (*) aligned, (0:31) ptr, (0:31) fixed bin, fixed bin, char (32) aligned),
     od_print_ entry options (variable),
     od_stack_ entry (ptr, fixed bin, ptr, ptr, ptr, ptr),
     ioa_ entry options (variable),
     ring0_get_$segptr_given_slt entry (char (*)aligned, char (*)aligned, ptr, fixed bin (35), ptr, ptr),
     hcs_$get_max_length_seg entry (ptr, fixed bin (18), fixed bin (35)),
     hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin (35)),
     com_err_ entry options (variable),
     ios_$attach entry (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned),
     ios_$detach entry (char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned);

dcl (od_print_$op_new_page, od_print_$op_finish) entry,	/* No args */
     od_print_$op_fmt_line entry (fixed bin, fixed bin, fixed bin (35)),
     od_print_$op_new_seg entry (fixed bin),
     od_print_$op_init entry (fixed bin, fixed bin (71)),
     online_355_dump_ entry (ptr, fixed bin),
     copy_dump_seg_ entry (fixed bin, fixed bin, (0:31) ptr, (0:31) fixed bin, ptr, fixed bin),
     print_dump_seg_name_ entry (fixed bin, fixed bin (71), ptr, ptr),
     print_dump_seg_name_$hard entry (fixed bin, fixed bin (71), ptr, ptr),
     hcs_$terminate_noname entry (ptr, fixed bin (35)),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));

dcl (addr, addrel, baseno, bin, divide, index, mod, null, size, substr) builtin; /* PSI! */

dcl (ds_seg_no int static init (0),			/* Seg # of descriptor segs */
     slt_seg_no, nam_seg_no, sstnt_seg_no, pds_seg_no, prds_seg_no, /* Miscellaneous system segment #-s */
     sst_seg_no) fixed bin;				/* .. */

dcl (dslen, sstntlen, sltlen, namlen, sstlen, pdslen, prdslen, stklen) fixed bin; /* Lengths of copies of segs */

dcl (slt_seg init (null), nam_seg, sst_seg, sstnt_seg, ds_seg, pds_seg, /* Static pointers to created segments */
     prds_seg /* , tc_data_seg, lot_seg */, stk_seg, shut_seg) ptr int static;

dcl ( /* sstp, sltp, */ namp, dsp, pdsp, prdsp /* , tc_datap, lotp */) ptr; /* Automatic copies */

dcl (astep, ptwp) ptr,
     code fixed bin (35);

dcl ((m1 init (-1),
     five init (5),
     four init (4),
     three init (3),
     two init (2),
     one init (1)) fixed bin,
     seg_mode fixed bin (5) init (1011b),
     max_fnps fixed bin init (4),
     fnp_size fixed bin init (16384),			/* size of core image in 36-bit words */
     wps fixed bin (18)) int static;



dcl  onechar char (1) aligned;
dcl  twochar char (2) aligned;

dcl  dsbr_stk_no fixed bin;				/* the first stack segno, judged by dsbr.stack */
dcl  xreg (0:7) fixed bin (17) unaligned based;
dcl  cv_oct_check_ entry (char (*), fixed bin) returns (fixed bin);
dcl  ioargloc fixed bin init (2);
dcl  seg_no fixed bin;
dcl  restartsw bit (1) init ("0"b);
dcl (rt_seg_no, rt_proc_no, cur_proc_no) fixed bin;
dcl  fnp_index fixed bin;
dcl  tag char (1);
dcl  all_fnps bit (1);				/* indicator of whether dumping all fnps */
dcl  segselsw bit (1) init ("0"b),
     wants_regs bit (1) init ("0"b),
     wants_seg (0:1151) bit (1) unal,
     ws16x72 (16) fixed bin (71) based,
     ask_ ext entry options (variable),
     zilch (16) fixed bin (71) init ((16) 0),
     ask_$ask_clr ext entry options (variable),
     argno fixed bin,
     fnp_only bit (1),
     seg_id char (32);

dcl  based_ptr based ptr;

dcl (fmtdbrh char (31) init ("^-^-DBR  ADDR   BOUND U STACK^/"),
     fmtdbr char (34) init ("^-^-  ^8.3b  ^5.3b ^1.3b ^4.3b^/^/"),
     fmtpprh char (28) init ("^-^-PPR  PRR   PSR      IC^/"),
     fmtppr char (35) init ("^-^-      ^1.3b   ^5.3b   ^6.3b^/^/"),
     fmtrar char (17) init ("^-^-RAR   ^1.3b^/"),
     fmtind char (17) init ("^-^-IND   ^6.3b^/"),
     fmta char (14) init ("^-^-A     ^12w"),
     fmtq char (14) init ("^-^-Q     ^12w"),
     fmte char (15) init ("^-^-EXP   ^3.3b"),
     fmtt char (20) init ("^-^-TIMER    ^9.3b^/"),
     fmtbar char (14) init ("^-^-BAR   ^w^/"),
     fmtx char (13) init ("^-^-X^o   ^7o"),
     fmtinter char (16) init ("^/^-^-INTER ^12w"),
     fmtmode char (22) init ("^/^-^-MODE  ^12w  ^12w"),
     fmtflt char (14) init ("^-^-FAULT ^12w"),
     fmtprh char (39) init ("^/^/^-^-PR    R    SEG     WORD  BITS^/"),
     fmtpr char (39) init ("^-       ^2a (^o)   ^o   ^5o   ^6o  ^2o"),
     fmtamsdwh char (81) init ("^/^/^-AM: SDW^/^-^-  ADDR   R1R2R3  F  BOUND  REWPUG    CL  POINTER  F/E  USAGE^/"),
     fmtamsdw char (51) init ("^-^-^8o  ^o ^o ^o     ^5o  ^8a^5o  ^5o    ^a    ^2o"),
     fmtamptwh char (63) init ("^/^/^-AM: PTW^/^-^- ADDR    M   POINTER    PAGE    F/E  USAGE^/"),
     fmtamptw char (41) init ("^-^-^6o   ^2a   ^5o     ^4o     ^a    ^2o"),
     fmtcbh char (33) init ("^/^/^-^-COREBLOCKS: FIRST   NUM^/"),
     fmtcbno char (13) init ("^-^-^- NO MEM"),
     fmtmcmh char (33) init ("^/^/^-^-MEMORY CONTROLLER MASKS^/"),
     fmtmcm char (40) init ("^-  ^2o ^14w^14w^14w^14w^14w^14w^14w^14w"),
     fmthrh char (29) init ("^/^/^-^-^-HISTORY REGISTERS^/")) aligned int static;

dcl (fmteight char (37) init ("^-^4o^16w^14w^14w^14w^14w^14w^14w^14w"), /* For page table printing */
     fmtdesc char (66) init ("^-^-  ADDR   R1R2R3  F  BOUND  REWPUG    CL     SEGMENT     NAME^/"),
     fmtast char (64) init ("^/      ASTE      ^14w^14w^14w^14w^14w^14w^14w^14w^/PAGE TABLE^/"),
     fmtlth char (14) init ("^2-LENGTH = ^o"),
     fmteject char (2) init ("^|"),
     fmthdr char (11) init ("^|^a ERF ^a"),
     fmteq char (21) init ("^-^7o line^a repeated")) aligned int static;

dcl 1 dsbr based aligned,
   (2 add bit (24),
    2 pad1 bit (12),
    2 pad2 bit (1),
    2 bound bit (14),
    2 pad3 bit (4),
    2 unpaged bit (1),
    2 pad4 bit (4),
    2 stack bit (12)) unaligned;

dcl 1 scu based (scup) aligned,			/* SCU data needed by online_dump */
    2 ppr,					/* proceedure pointer register */
      3 prr bit (3) unal,				/* procedure ting register */
      3 psr bit (15) unal,				/* procedure segment register */
    2 pad1 bit (18) unal,				/*			*/
    2 pad2 (3) bit (36) unal,				/*			*/
    2 ilc bit (18) unal,				/* instruction counter */
    2 ir bit (18) unal,				/* indicator registers */
    2 pad3 (3) bit (36) unal;				/*		*/

dcl (ptr_array ptr,					/* Pointers to, lengths of component segments of image */
     len_array fixed bin) (0:31);

declare 1 cmp aligned,				/* Buffer containing contents of last printed line */
        2 (zero, two, four, six) fixed bin (71);

declare 1 temp aligned,				/* Buffer used when current 8 words straddle image segment boundary */
        2 (zero, two, four, six) fixed bin (71);

declare 1 dbl based aligned,				/* Template used to access current 8 words */
        2 (zero, two, four, six) fixed bin (71);

declare 1 sgl based aligned,				/* Template for printing individual words */
        2 (zero, one, two, three, four, five, six, seven) fixed bin (35);

dcl (cur, nxt, tmp, prt, eightp) ptr,			/* Pointers used in dumping */
    (ast_off, sst_abs_loc, sst_high_loc, abs_loc, jbdry, page_no) fixed bin,
    (b72 bit (72),					/* I/O status */
     bl char (l) based,				/* For format overlay */
     s char (1),					/* for singular/plural printing */
     c0 char (0)) aligned,				/* = null string */
    (i, j, l, j1, j2, eq_print) fixed bin,		/* Misc values */
     bin_array (0:1023) based fixed bin (35),
     dbl_array (0:1023) based fixed bin (71),
     cur_orig fixed bin (35),
    (cur_proc_index, cur_seg_no, given_length, half_gl) fixed bin,
						/* Per-segment values */
    (nsegs, seg_index, ptr_index, wpsmsi) fixed bin (18);	/* More misc */

declare 1 io_status based aligned,			/* To check 72-bits from ios_ calls */
        2 code fixed bin,				/* error code */
        2 substatus bit (36);				/* Bits */

dcl  axbitsp ptr;
dcl  axstring char (8) aligned;
dcl  axbits (6) bit (1) unaligned based (axbitsp);

dcl (amrp, ampp, scup) ptr;

% include assoc_mem;

% include slt;

% include sstnt;

% include ptw;

% include its;

% include sdw;

% include bos_dump;

% include sst;

/* Initialization */

	procname = "online_dump";
	prt = addr (wants_seg (0));
	prt -> ws16x72 = zilch;
	fnp_only = "0"b;
	go to get_erfno;

online_dump_355: od_355: entry;
	procname = "online_dump_355";
	fnp_only = "1"b;
	fnp_index = 1;				/* assume doing all starting with first */
	tag = "a";
	all_fnps = "1"b;

get_erfno: call cu_$arg_ptr (1, argp, argl, code);	/* Get mandatory first arg */
	if code ^= 0
	then do;
	     call com_err_ (code, procname, "ERF #");
	     return;
	end;

	if ^fnp_only then erf_no = arg;		/* Copy arg */
	else erf_no = arg || ".355";
	call get_dump_ptrs_ (erf_no, ptr_array, len_array, j, name); /* Get pointers to image segments */
	if j = 0
	then do;
	     call com_err_ (0, procname, "no pointers returned for arg ""^a""", erf_no);
	     return;
	end;

	ptr_array (j) = null;			/* For terminate loop */
	dumpptr = ptr_array (0);			/* Copy pointer for header access */
	call hcs_$get_max_length_seg (dumpptr, wps, code);
	if code ^= 0 then do;
	     call com_err_ (code, procname, "unable to get max length of ^a", name);
	     return;
	end;
						/* NEW STUFF */

get_args:
	argno = 1;

next_arg:
	argno = argno + 1;
	call cu_$arg_ptr (argno, argp, argl, code);	/* any more args */
	if code ^= 0 | argl = 0 then do;		/* if not, then leave */
	     if fnp_only then go to no_more_segs;	/* nothing more to do before attach call */
	     else go to no_more_args;
	end;

	if arg = "-dim" then do;			/* next arg is name of dim */
	     argno = argno + 1;
	     call cu_$arg_ptr (argno, argp, argl, code);
	     if code ^= 0 | argl = 0 then do;
		seg_id = "dim";
		go to call_com;
	     end;
	     iotype = arg;
	end;

	else if arg = "-dev" then do;			/* next arg is name of device or stream */
	     argno = argno + 1;
	     call cu_$arg_ptr (argno, argp, argl, code);
	     if code ^= 0 | argl = 0 then do;
		seg_id = "device";
		go to call_com;
	     end;
	     ioname2 = arg;
	end;

	else if arg = "-restart" & ^fnp_only then do;	/* if we are restarting */
	     restartsw = "1"b;			/* note it so no segs will be dumped */
	     argno = argno + 1;
	     call cu_$arg_ptr (argno, argp, argl, code);
	     if code ^= 0 | argl = 0 then do;
		seg_id = "restart process_number";
		go to call_com;
	     end;
	     rt_proc_no = cv_oct_check_ (arg, i);	/* except those following the seg with this proc_no */
	     if i ^= 0 then do;
		seg_id = "restart process_no is not octal";
		go to call_com_oct;
	     end;
	     argno = argno + 1;
	     call cu_$arg_ptr (argno, argp, argl, code);
	     if code ^= 0 | argl = 0 then do;
		seg_id = "restart segment number";
		go to call_com;
	     end;
	     rt_seg_no = cv_oct_check_ (arg, i);	/* AND this seg_no */
	     if i ^= 0 then do;
		seg_id = "restart segment_no is not octal";
		go to call_com_oct;
	     end;
	end;

	else if arg = "-segs" & ^fnp_only then do;
	     segselsw = "1"b;			/* later we will pick up selected segs */
	end;

	else if arg = "-tag" & fnp_only then do;
	     argno = argno + 1;
	     call cu_$arg_ptr (argno, argp, argl, code);
	     if code ^= 0 | argl = 0 then do;
		seg_id = "tag";
		go to call_com;
	     end;

	     tag = arg;
	     all_fnps = "0"b;			/* not doing all now */
	     fnp_index = index ("abcdefgh", tag);	/* convert to number */
	     if fnp_index = 0 then do;		/* not legal tag */
		seg_id = "invalid tag";
		go to call_com_oct;
	     end;

	     dumpptr = addrel (dumpptr, fnp_size* (fnp_index-1)); /* point to relevant core image */
	end;

	else do;
	     seg_id = arg;
	     code = error_table_$badopt;
	     go to call_com;
	end;

	go to next_arg;

call_com:
	call com_err_ (code, procname, "^a", seg_id);
	return;
call_com_oct:
	call com_err_ (0, procname, "^a:  ^a", seg_id, arg);
	return;

no_more_args:
						/* Extract various system segment numbers, and copy per-system data bases */
	if slt_seg = null
	then do;
	     call hcs_$make_seg (c0, "od.slt--", c0, seg_mode, slt_seg, code);
	     call hcs_$make_seg (c0, "od.nam--", c0, seg_mode, nam_seg, code);
	     call hcs_$make_seg (c0, "od.sst--", c0, seg_mode, sst_seg, code);
	     call hcs_$make_seg (c0, "od.sstnt", c0, seg_mode, sstnt_seg, code);
	     call hcs_$make_seg (c0, "od.dseg-", c0, seg_mode, ds_seg, code);
	     call hcs_$make_seg (c0, "od.pds--", c0, seg_mode, pds_seg, code);
	     call hcs_$make_seg (c0, "od.prds-", c0, seg_mode, prds_seg, code);
	     call hcs_$make_seg (c0, "od.shut-", c0, seg_mode, shut_seg, code);
	     call hcs_$make_seg (c0, "od.stk--", c0, seg_mode, stk_seg, code);
						/* Following calls temporarily commented out:
						   call hcs_$make_seg(c0, "od.pdf--", c0, seg_mode, pdf_seg, code);
						   /* Need more temporary segments?  Add above this line */
	end;
	cur_proc_index = 1;				/* For copy_dump_seg_ */
	namp, dsp, sstnp, sstp = null;		/* Just in case */
	slt_seg_no = 7;

	call copy_dump_seg_ (7, cur_proc_index, ptr_array, len_array, slt_seg, sltlen);
	if sltlen = 0
	then do;
	     call ioa_ ("Can't find ""^a""", "slt");
NOT_SLT:	     sltp = null;
	     sst_seg_no = 10;			/* Subject to change */
	     go to copy_sst;
	end;

	else do;					/* Pick out all interesting segment #-s */
	     sltp = slt_seg;
	     nam_seg_no = bin (baseno (sltp -> based_ptr), 18);
	     call copy_dump_seg_ (nam_seg_no, cur_proc_index, ptr_array, len_array, nam_seg, namlen);
	     if namlen ^= 0 then namp = nam_seg;
	     else do;				/* well at best the SLT is useless... */
		call ioa_ ("Cannot find name_table for slt");
		go to NOT_SLT;
	     end;

	     call ring0_get_$segptr_given_slt ("", "slt", prt, code, sltp, namp); /* remember we guessed slt_seg_no = 7 */
	     if bin (baseno (prt), 18) ^= 7 then do;	/* alleged SLT not able to figure its own number! */
		call ioa_ ("Segments 7 and ^o not functioning as slt and name_table", nam_seg_no);
		namp = null;
		go to NOT_SLT;
	     end;

	     call ring0_get_$segptr_given_slt ("", "sst", prt, code, sltp, namp);
	     if code = 0 then do;
		sst_seg_no = bin (baseno (prt), 18);
	     end;
	     else do;
		sst_seg_no = 9;
	     end;
	     call ring0_get_$segptr_given_slt ("", "sst_names_", prt, code, sltp, namp);
	     sstnt_seg_no = bin (baseno (prt), 18);
	     call ring0_get_$segptr_given_slt ("", "pds", prt, code, sltp, namp);
	     pds_seg_no = bin (baseno (prt), 18);
	     call ring0_get_$segptr_given_slt ("", "prds", prt, code, sltp, namp);
	     prds_seg_no = bin (baseno (prt), 18);

copy_sst:						/* Copying of SST must be the last in this sequence */
	     call copy_dump_seg_ (sst_seg_no, cur_proc_index, ptr_array, len_array, sst_seg, sstlen);
	     if sstlen = 0
	     then do;
		call ioa_ ("Can't find ""^a""", "sst");
		sstp = null;
	     end;
	     else do;
		sstp = sst_seg;
		sst_abs_loc = sstp -> sst.ptwbase;
		sst_high_loc = sst_abs_loc + sstlen ;
		ast_off = - (sstp -> sst.astsize);
	     end;
						/* Copy the SST name table */

	     call copy_dump_seg_ (sstnt_seg_no, cur_proc_index, ptr_array, len_array, sstnt_seg, sstntlen);
	     if sstntlen = 0 then do;
		call ioa_ ("Cannot find SST name table.");
		sstnp = null;
	     end;
	     else do;
		sstnp = sstnt_seg;
		if ^sstnp -> sstnt.valid then do;
		     call ioa_ ("SST name  table not filled in.");
		     sstnp = null;
		end;
	     end;
	end;
	if segselsw then do;			/* now we pick up selected segnames or numbers */
	     call ask_$ask_clr;			/* clear ask's internal line buffer */
get_next_seg:
	     call ask_ (c0, seg_id);			/* pick up specification of a seg */
	     if seg_id = "quit" then go to no_more_segs;	/* no more  wanted */
	     if seg_id = "regs" then do;
		wants_regs = "1"b;
		go to get_next_seg;
	     end;
	     seg_no = cv_oct_check_ (seg_id, i);	/* try it as octal segno */
	     if i = 0 then wants_seg (seg_no) = "1"b;	/* it is octal and we mark it wanted */
	     else if sltp ^= null then do;		/* not octal, see if its a name in SLT, if any */
		call ring0_get_$segptr_given_slt ("", (seg_id), prt, code, sltp, namp);
		if code = 0 then do;		/* it was found in SLT */
		     seg_no = bin (baseno (prt), 18);
		     wants_seg (seg_no) = "1"b;	/* and we mark it's segno as wanted */
		end;
		else do;				/* not in SLT,wasn't octal=> it loses */
		     call ioa_ ("Cannot find segment ^a in slt", seg_id); /* name or slt is nonsense */
		end;
	     end;
	     go to get_next_seg;			/* see if there are more */
	end;
no_more_segs:
	call ioa_ ("Segment ""^a"", device ""^a"", module ""^a""", /* Print current attachment info etc */
	     name, ioname2, iotype);
	call ios_$attach (ioname, iotype, ioname2, "w", b72); /* Attach printer or other device */
	tmp = addr (b72);				/* Pro _t_e_m_pore */
	if tmp -> io_status.code ^= 0
	then do;
	     call com_err_ (tmp -> io_status.code, procname,
		"attach call, sub-status ^w, contact programming staff", tmp -> io_status.substatus);
	     return;
	end;
	call od_print_$op_init (bin (dumpptr -> dump.erfno, 17), dumpptr -> dump.time); /* Initialize print program */
	call od_print_ (m1, fmthdr, "Start", erf_no);	/* Print header */
	tmp = addr (temp);				/* For short lines, boundary conditions, etc */
	eightp = addr (fmteight);			/* For page-table printout */
	if restartsw then call ioa_ ("Continue dumping ^a", erf_no);
	else
	call ioa_ ("Begin dumping ^a", erf_no);		/* Send message to console */
	if fnp_only then do while ("1"b);
	     call od_print_$op_finish;
	     call online_355_dump_ (dumpptr, fnp_index);
	     if all_fnps & fnp_index < max_fnps then do;	/* more fnp dumps to process */
		fnp_index = fnp_index + 1;
		dumpptr = addrel (dumpptr, fnp_size);	/* point to next core image */
	     end;

	     else go to tm_loop;
	end;

/* Print register contents */

	prt = addr (dumpptr -> dump.dbr);
	dsbr_stk_no = bin (prt -> dsbr.stack, 12) * 8;
	if (restartsw | (segselsw & ^wants_regs)) then go to skip_regs;

	call od_print_ (two, fmtdbrh);		/* descriptor base register */
	call od_print_ (three, fmtdbr,
	     prt -> dsbr.add, prt -> dsbr.bound, prt -> dsbr.unpaged, prt -> dsbr.stack);


	call od_print_ (four, fmtpprh);		/* proceedure pointer register */
	scup = addr (dumpptr -> dump.scu (0));
	call od_print_ (one, fmtppr,
	     scup -> scu.ppr.prr, scup -> scu.ppr.psr, scup -> scu.ilc);


	call od_print_ (two, fmtrar, dumpptr -> dump.regs.ralr);
	call od_print_ (two, fmtind, scup -> scu.ir);
	call od_print_ (one, fmta, dumpptr -> dump.regs.a);
	call od_print_ (one, fmtq, dumpptr -> dump.regs.q);
	call od_print_ (one, fmte, dumpptr -> dump.regs.e);
	call od_print_ (two, fmtt, dumpptr -> dump.regs.t);

	call od_print_ (two, fmtbar, dumpptr -> dump.bar);


	prt = addr (dumpptr -> dump.regs.x (0));
	do j = 0 by 1 while (j < 8);			/* index registers */
	     call od_print_ (one, fmtx, j, prt -> xreg (j));
	end;


	call od_print_ (two, fmtmode, dumpptr -> dump.modereg, dumpptr -> dump.cmodereg);
	call od_print_ (one, fmtflt, dumpptr -> dump.faultreg);


	call od_print_ (two, fmtinter, dumpptr -> dump.intrpts); /* interrupts */


	call od_print_ (four, fmtprh);		/* pointer registers */
	do j = 0 by 1 while (j < 8);
	     prt = addr (dumpptr -> dump.prs (j));
	     call od_print_ (one, fmtpr,
		substr ("APABBPBBLPLBSPSB", j*2+1, 2),
		j,
		bin (prt -> its.ringno, 3),
		bin (prt -> its.segno, 15),
		bin (prt -> its.offset, 18),
		bin (prt -> its.bit_offset, 6));
	end;

	call od_print_$op_new_page;

	call od_print_ (five, fmtamsdwh);		/* assoc. mem. segment descriptor words */

	do j = 0 by 1 while (j < 16);
	     amrp = addr (dumpptr -> dump.amsdwregs (j));
	     ampp = addr (dumpptr -> dump.amsdwptrs (j));

	     axstring = "REWPUG  ";			/* check some bits */
	     axbitsp = addr (amrp -> amsdwreg.read);
	     do l = 1 to 6;
		if axbitsp -> axbits (l) = "0"b then substr (axstring, l, 1) = " ";
	     end;

	     call od_print_ (one, fmtamsdw,
		bin (amrp -> amsdwreg.addr, 24),
		bin (amrp -> amsdwreg.r1, 3),
		bin (amrp -> amsdwreg.r2, 3),
		bin (amrp -> amsdwreg.r3, 3),
		bin (amrp -> amsdwreg.bound, 14),
		axstring,
		bin (amrp -> amsdwreg.cl, 14),
		bin (ampp -> amsdwptr.pointer, 15),
		substr ("EF", bin (ampp -> amsdwptr.valid, 1)+1, 1),
		bin (ampp -> amsdwptr.usage, 4));
	end;


	call od_print_ (five, fmtamptwh);		/* assoc. mem. page table words */
	do j = 0 by 1 while (j < 16);

	     amrp = addr (dumpptr -> dump.amptwregs (j));
	     ampp = addr (dumpptr -> dump.amptwptrs (j));

	     if amrp -> amptwreg.modif then twochar = "  "; else twochar = "NO";
	     if ampp -> amptwptr.valid then onechar = "F"; else onechar = "E";

	     call od_print_ (one, fmtamptw,
		bin (amrp -> amptwreg.addr, 18),
		twochar,
		bin (ampp -> amptwptr.pointer, 15),
		bin (ampp -> amptwptr.pageno, 12),
		onechar,
		bin (ampp -> amptwptr.usage, 4));
	end;

	call od_print_$op_new_page;

	call od_print_ (four, fmtcbh);		/* coreblocks */
	do j = 0 by 1 while (j < 8);
	     prt = addr (dumpptr -> dump.coreblocks (j).num_first);
	     if prt -> sgl.zero = -1 then call od_print_ (one, fmtcbno);
	     else do;
		n_first = bin (dumpptr -> dump.coreblocks (j).num_first, 18);
		n_blocks = bin (dumpptr -> dump.coreblocks (j).num_blocks, 18);
		call od_print_ (one, "^-^-^- ^6o ^4o", n_first, n_blocks);
	     end;
	end;

	call od_print_ (four, fmtmcmh);		/* memory controller masks */
	do j = 0 by 4 while (j< 8);
	     prt = addr (dumpptr -> dump.mcm (j));
	     call od_print_ (1, fmtmcm,
		2*j,
		prt -> sgl.zero, prt -> sgl.one, prt -> sgl.two, prt -> sgl.three,
		prt -> sgl.four, prt -> sgl.five, prt -> sgl.six, prt -> sgl.seven);
	end;

	call od_print_ (four, fmthrh);
	call od_print_ (two, "^/^-OU");
	do j = 0 by 4 while (j < 16);
	     prt = addr (dumpptr -> dump.ouhist (j));	/* operations unit history regs */
	     call od_print_ (one, fmtmcm,
		2*j,
		prt -> sgl.zero, prt -> sgl.one, prt -> sgl.two, prt -> sgl.three,
		prt -> sgl.four, prt -> sgl.five, prt -> sgl.six, prt -> sgl.seven);
	end;

	call od_print_ (two, "^/^-CU");
	do j = 0 by 4 while (j < 16);
	     prt = addr (dumpptr -> dump.cuhist (j));	/* control unit history registers */
	     call od_print_ (one, fmtmcm,
		2*j,
		prt -> sgl.zero, prt -> sgl.one, prt -> sgl.two, prt -> sgl.three,
		prt -> sgl.four, prt -> sgl.five, prt -> sgl.six, prt -> sgl.seven);
	end;

	call od_print_ (two, "^/^-AU");
	do j = 0 by 4 while (j < 16);
	     prt = addr (dumpptr -> dump.auhist (j));	/* appending unit history registers */
	     call od_print_ (one, fmtmcm,
		2*j,
		prt -> sgl.zero, prt -> sgl.one, prt -> sgl.two, prt -> sgl.three,
		prt -> sgl.four, prt -> sgl.five, prt -> sgl.six, prt -> sgl.seven);
	end;

	call od_print_ (two, "^/^-DU");
	do j = 0 by 4 while (j < 16);
	     prt = addr (dumpptr -> dump.duhist (j));	/* decimal unit history registers */
	     call od_print_ (one, fmtmcm,
		2*j,
		prt -> sgl.zero, prt -> sgl.one, prt -> sgl.two, prt -> sgl.three,
		prt -> sgl.four, prt -> sgl.five, prt -> sgl.six, prt -> sgl.seven);
	end;

/* Now dump individual segments/processes */

skip_regs:
	nsegs = dumpptr -> dump.num_segs;		/* Copy for quicker reference */
	cur_proc_no = 0;
	do i = 1 to nsegs;
	     cur_seg_no = bin (dumpptr -> dump.segs (i).segno, 18);
	     if i > 1 then cur_orig = bin (dumpptr -> dump.segs (i-1).length, 18) * 64 + cur_orig ;
	     else cur_orig = size (dump);
	     given_length = bin (dumpptr -> dump.segs (i).length, 18) * 64;
	     call od_print_$op_new_seg (cur_seg_no);
	     if cur_seg_no = ds_seg_no then cur_proc_no = cur_proc_no + 1;
	     if cur_seg_no = rt_seg_no then if cur_proc_no = rt_proc_no then restartsw = "0"b;
	     if restartsw then if cur_seg_no ^= ds_seg_no then go to next_seg;
	     if cur_seg_no = ds_seg_no & (^restartsw | cur_proc_no = rt_proc_no) /* Is it a new descriptor seg */
	     then do;
		cur_proc_index = i;			/* Yes, remember position for info for new process */
		prdsp, pdsp = null;
		if sltp ^= null then if namp ^= null	/* If we know where KST, PDS,PRDS are, copy them */
		     then do;
			call copy_dump_seg_ (pds_seg_no, cur_proc_index, ptr_array, len_array, pds_seg, pdslen);
			if pdslen ^= 0 then pdsp = pds_seg;
			call copy_dump_seg_ (prds_seg_no, cur_proc_index, ptr_array, len_array, prds_seg, prdslen);
			if prdslen ^= 0 then prdsp = prds_seg;
		     end;
		call copy_dump_seg_ (cur_seg_no, cur_proc_index, ptr_array, len_array, ds_seg, dslen);
						/* Copy descriptor segment for this process */
		if dslen = 0
		then dsp, sdwp = null;
		else do;
		     dsp = ds_seg;
		     if (restartsw | (segselsw & ^wants_seg (ds_seg_no))) then go to next_seg;
		     else do;
			eq_print = 0;
			call od_print_ (four, "^/^/^4-DESCRIPTOR SEGMENT^/");
			call od_print_ (two, fmtdesc);
			half_gl = divide (given_length, 2, 17, 0);
			do j = 0 by 1 while (j ^= half_gl); /* Print symbolic breakout of descriptors */
			     if dsp -> dbl_array (j) = 0 /* Don't print null SDW */
			     then eq_print = eq_print + 1; /* merely note it for blank line later */
			     else do;
				if eq_print ^= 0
				then call od_print_ (one, c0); /* Print blank line */
				if sltp = null then go to CALL_PDSN_1;
				if sltp -> slt.last_sup_seg >= j then do;
				     call print_dump_seg_name_$hard (j, dsp -> dbl_array (j), sltp, namp);
				end;
				else do;
CALL_PDSN_1:			     call print_dump_seg_name_ (j, dsp -> dbl_array (j), sstp, sstnp);
				end;
				eq_print = 0;	/* Reset counter */
			     end;
			end;
		     end;
		end;
		call od_print_$op_new_page;		/* After descriptor breakout, new page for segment */
	     end;

	     if segselsw then if ^wants_seg (cur_seg_no) then go to next_seg;
	     abs_loc = -wps;			/* Generate large negative number */
	     jbdry = -1;				/* Such that comparison below will never succeed */
	     if dsp ^= null
	     then do;
		sdwp = addr (dsp -> dbl_array (cur_seg_no));
		call od_print_ (two, fmtdesc);
		if sltp = null then go to CALL_PDSN_2;
		if sltp -> slt.last_sup_seg >= cur_seg_no
		then call print_dump_seg_name_$hard (cur_seg_no, dsp -> dbl_array (cur_seg_no), sltp, namp);
		else do;
CALL_PDSN_2:	     call print_dump_seg_name_ (cur_seg_no, dsp -> dbl_array (cur_seg_no), sstp, sstnp);
		end;
		if sdwp -> sdw.add
		then if sdwp -> sdw.unpaged = "0"b
		     then do;
			if sstp ^= null		/* Get AST entry and page table */
			then do;
			     j = bin (sdwp -> sdw.add, 24);
			     if j > sst_high_loc	/* Check for address beyond end of SST */
			     then go to use_abs;
			     jbdry = 0;		/* Where absolute location is next computed */
			     page_no = 0;		/* for indexing into page table */
			     ptp = addrel (sstp, j - sst_abs_loc);
			     prt = ptp;
			     astep = addrel (ptp, ast_off);

			     j1 = bin (sdwp -> sdw.bound, 14) + 1; /* Extract bounds field */
			     j2 = divide (j1 + 63, 64, 17, 0);
			     j1 = divide (j2, 8, 17, 0);
			     j2 = j2 - j1 * 8;

			     call od_print_ (four, fmtast,
				astep -> sgl.zero, astep -> sgl.one, astep -> sgl.two, astep -> sgl.three,
				astep -> sgl.four, astep -> sgl.five, astep -> sgl.six, astep -> sgl.seven);
			     do j = 0 by 8 while (j < j1); /* Print full lines */
				call od_print_ (one, fmteight, j,
				     prt -> sgl.zero, prt -> sgl.one, prt -> sgl.two, prt -> sgl.three,
				     prt -> sgl.four, prt -> sgl.five, prt -> sgl.six, prt -> sgl.seven);
				prt = addrel (prt, 8);
			     end;
			     if j2 ^= 0
			     then do;
				l = j2 * 4 + 5;	/* # of characters to use */
				call od_print_ (one, eightp -> bl, j,
				     prt -> sgl.zero, prt -> sgl.one, prt -> sgl.two, prt -> sgl.three,
				     prt -> sgl.four, prt -> sgl.five, prt -> sgl.six);
			     end;
			end;
		     end;
		     else				/* ! */
use_abs:		     abs_loc = bin (sdwp -> sdw.add, 24);
		call od_print_ (one, c0);		/* Separate contents from header by blank line */
	     end;
	     if given_length <= 0
	     then do;
		call od_print_ (one, fmtlth, given_length);
		go to next_seg;
	     end;

/* All preliminary work done, start to dump seg */
/* Note: given_length is in words */

	     prt = null;
	     if cur_seg_no ^= 0 then do;
		if (cur_seg_no = pds_seg_no & pdsp ^= null) then prt = pdsp;
		else if (cur_seg_no = prds_seg_no & prdsp ^= null) then prt = prdsp;
		else if (cur_seg_no >= dsbr_stk_no & dsbr_stk_no ^= 0 & cur_seg_no - dsbr_stk_no < 8) then do;
		     call copy_dump_seg_ (cur_seg_no, cur_proc_index, ptr_array, len_array, stk_seg, stklen);
		     if stklen ^= 0 then prt = stk_seg;
		end;
	     end;
	     if prt = null then go to NOT_STACK;
	     call od_stack_ (prt, given_length, sltp, namp, sstp, sstnp);
	     go to next_seg;			/* this one is done */
NOT_STACK:
	     j1 = given_length;			/*  num lines in seg as dumped by bos, which dumps 64 wd blocks */
	     if sdwp -> sdw.unpaged then do;
		j2 = (bin (sdwp -> sdw.bound, 14) + 1) * 16; /* unpaged segs' lengths not necess multiple of 64 really */
		if j2 < j1 then j1 = j2;		/* so we use the bounds field which gives num of 16 wd units */
	     end;

	     ptr_index = divide (cur_orig, wps, 17, 0);
	     seg_index = mod (cur_orig, wps);
	     cur = addrel (ptr_array (ptr_index), seg_index);

	     eq_print = 0;				/* No suppressed lines */

/* Note re-entry to loop at "compare": if Version II PL/I makes noises, change to "do while", etc */

	     do j = 0 by 8 while (j < j1);		/* print all full lines */

		wpsmsi = wps - seg_index;		/* Calculate # of words remaining in current image seg */

		if wpsmsi >= 8			/* 8 or more, print directly */
		then do;
retry_8:
		     prt = cur;
compare:						/* Come here at most once after main loop to compare and */
						/* print partial line */

		     if j = jbdry
		     then do;
			ptwp = addr (ptp -> bin_array (page_no));
			if ptwp -> ptw.df
			then abs_loc = bin (ptwp -> ptw.add, 18) * 64;
			else abs_loc = -wps;	/* Page not in core */

			jbdry = jbdry + 1024;
			page_no = page_no + 1;
		     end;

		     if j ^= 0			/* Don't check first time through */
		     then if prt -> dbl.six = cmp.six	/* See if this line equals previous line */
			then if prt -> dbl.four = cmp.four
			     then if prt -> dbl.two = cmp.two
				then if prt -> dbl.zero = cmp.zero
				     then do;
					eq_print = eq_print + 1; /* Note occurence of repeated line */
					go to endj;
				     end;

		     if eq_print ^= 0		/* Line was different, were there suppressed lines? */
		     then do;
			if eq_print = 1		/* How many? */
			then s = " ";
			else s = "s";
			call od_print_ (one, fmteq, eq_print, s);
			eq_print = 0;		/* Reset counter */
		     end;


/*		     call od_print_(one, fmt, abs_loc, j,
   prt -> sgl.zero, prt -> sgl.one, prt -> sgl.two, prt -> sgl.three,
   prt -> sgl.four, prt -> sgl.five, prt -> sgl.six, prt -> sgl.seven); /* Print line */

		     call od_print_$op_fmt_line (abs_loc, j, prt -> sgl.zero);

		     cmp.six = prt -> dbl.six;	/* Copy for next comparison */
		     cmp.four = prt -> dbl.four;
		     cmp.two = prt -> dbl.two;
		     cmp.zero = prt -> dbl.zero;
		end;


		else do;				/* fewer than 8, switch to next seg of image */
		     nxt = ptr_array (ptr_index + 1);
		     if wpsmsi = 0			/* If zero, trivial */
		     then do;
			cur = nxt;
			seg_index = 0;
			go to retry_8;
		     end;

		     seg_index = -wpsmsi;		/* Set for advancing at "endj" */
		     cur = addrel (nxt, seg_index);
		     prt = tmp;			/* Compare/print from special buffer */
		     go to compare;
		end;

endj:		cur = addrel (cur, 8);		/* Advance pointer */
		seg_index = seg_index + 8;		/* and index in parallel */
		abs_loc = abs_loc + 8;		/* Augment absolute address */
	     end;


	     if eq_print ^= 0			/* See if last line was identical to last printed line */
	     then do;
		if eq_print = 1
		then s = " ";
		else s = "s";
		call od_print_ (one, fmteq, eq_print, s);
	     end;


next_seg:
	end;

/* Cleanup */
tm_loop:
	do j = 0 by 1 to 9 while (ptr_array (j) ^= null); /* Terminate all segs of image */
	     call hcs_$terminate_noname (ptr_array (j), code);
	end;

	call od_print_ (m1, fmthdr, "End", erf_no);

od_cleanup: entry;					/* To close buffer and detach printer */
	call od_print_ (m1, fmteject);

	call od_print_$op_finish;
	call ios_$detach (ioname, c0, c0, b72);
	call ioa_ ("Finished dump");
     end online_dump;




		    online_dump_fnp.pl1             11/15/82  1847.9rew 11/15/82  1517.2       69804



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


od_fnp: online_dump_fnp: proc;

/* Command to access a dump created online by fdump_fnp_
   *  Dump (in >dumps) has entry name of the form fnp.TAG.MMDDYY.HHMM
   *
   *  Usage:  od_fnp -dt MMDDYY -device DEVICE -dim DIM [-tm HHMM] [-tag TAG]
   *
   *  If time or tag is not supplied, a starname will be formed, but if more than one entry
   *  matches it, an error code will be returned.
*/


/* ARGUMENT STUFF */

dcl  nargs fixed bin;
dcl  iarg fixed bin;
dcl  argptr ptr;
dcl  arglen fixed bin;
dcl  arg char (arglen) based (argptr);


/* ENTRIES */

dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  clock_ entry returns (fixed bin (71));
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  ioa_$rs entry options (variable);
dcl  get_system_free_area_ entry (ptr);
dcl  hcs_$star_ entry (char (*), char (*), fixed bin, ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  ios_$attach entry (char (*), char (*), char (*), char (*), bit (72) aligned);
dcl  ios_$detach entry (char (*), char (*), char (*), bit (72) aligned);
dcl  ios_$write entry (char (*), ptr, fixed bin, fixed bin, fixed bin, bit (72) aligned);
dcl  online_355_dump_ entry (ptr, fixed bin);
dcl  parse_fnp_name_ entry (char (*), fixed bin);

/* AUTOMATIC */

dcl  ap ptr;
dcl  code fixed bin (35);
dcl  starname char (32);
dcl  namelen fixed bin;

dcl  tag char (1) init ("*");
dcl  date char (6) init ("*");
dcl  time char (4) init ("*");
dcl  device char (168) init ("*");
dcl  dim char (32) init ("*");
dcl  path char (168) init ("*");

dcl  outline char (64);
dcl  iostat bit (72) aligned;
dcl  init bit (1) init ("0"b);
dcl  date_string char (24);
dcl  pathlen fixed bin;
dcl  dirname char (168);
dcl  segname char (32);
dcl  count fixed bin;
dcl  ep ptr;
dcl  np ptr;
dcl  dump_ptr ptr;
dcl  fnp_no fixed bin;

/* INTERNAL STATIC */

dcl  myname char (15) internal static options (constant) init ("online_dump_fnp");
dcl  DUMP_DIR char (6) internal static options (constant) init (">dumps");
dcl  output_stream char (32) internal static options (constant) init ("od_output_");


/* EXTERNAL STATIC */

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


/* BASED */

dcl  the_area area (50) based (ap);
dcl  based_name char (32) based;
dcl  names (count) char (32) aligned based (np);
dcl  entries (count) fixed bin based (ep);

dcl 1 io aligned based (addr (iostat)),
    2 code fixed bin (35),
    2 junk bit (36);


/* CONDITIONS & BUILTINS */

dcl  cleanup condition;

dcl (addr, index, null, substr) builtin;
						/*  */
	call cu_$arg_count (nargs);
	if nargs < 2
	then do;
	     call com_err_ (0, myname, "Usage: online_dump_fnp -device DEVICE -dim DIM -date MMDDYY [-time HHMM] [-tag FNP_TAG] [-pathname PATH]");
	     return;
	end;

	do iarg = 1 to nargs by 2;
	     call cu_$arg_ptr (iarg, argptr, arglen, code);

	     if arg = "-tag"
	     then call get_value (tag);

	     else
	     if arg = "-date" | arg = "-dt"
	     then call get_value (date);

	     else
	     if arg = "-time" | arg = "-tm"
	     then call get_value (time);

	     else
	     if arg = "-device" | arg = "-dv" | arg = "-dev"
	     then call get_value (device);

	     else
	     if arg = "-dim"
	     then call get_value (dim);

	     else
	     if arg = "-pn" | arg = "-pathname"
	     then do;
		call get_value (path);
		pathlen = arglen;
	     end;

	     else code = error_table_$badopt;

	     if code ^= 0				/* either set by preceding statement or by get_value */
	     then do;
		call com_err_ (code, myname, arg);
		return;
	     end;
	end;

/* make sure required arguments were specified */

	if device = "*" then call noarg ("device");
	if dim = "*" then call noarg ("dim");
	if code ^= 0 then return;			/* noarg sets code */

	if path ^= "*"				/* pathname of dump specified */
	then do;
	     call expand_path_ (addr (path), pathlen, addr (dirname), addr (segname), code);
	     if code ^= 0 then do;
		call com_err_ (code, myname, path);
		return;
	     end;

	     if tag = "*" then tag = "a";		/* fake it */
	end;

/* else apply starname */

	else do;
	     dirname = DUMP_DIR;
	     if date = "*"				/* date defaults */
	     then do;
		call date_time_ (clock_ (), date_string);
		date = substr (date_string, 1, 2) || substr (date_string, 4, 2) || substr (date_string, 7, 2);
	     end;

	     call ioa_$rsnnl ("fnp.^a.^a.^a", starname, namelen, tag, date, time);
	     call get_system_free_area_ (ap);

	     call hcs_$star_ (DUMP_DIR, substr (starname, 1, namelen), 2, ap, count, ep, np, code);
	     if code ^= 0 then do;
		call com_err_ (code, myname, starname);
		return;
	     end;

	     segname = np -> based_name;
	     free entries in (the_area);
	     free names in (the_area);

	     if count > 1 then do;
		call com_err_ (0, myname, "^a identifies more than one dump.", starname);
		return;
	     end;

	     if tag = "*" then tag = substr (segname, 5, 1);
	     if time = "*" then time = substr (segname, 14, 4);
	end;


	call ios_$attach (output_stream, dim, device, "w", iostat);
	if io.code ^= 0
	then do;
	     call com_err_ (io.code, myname, "Could not make attachment.");
	     return;
	end;

	on cleanup call clean;

	call hcs_$initiate (dirname, segname, "", 0, 1, dump_ptr, code);
	if dump_ptr = null
	then do;
	     call com_err_ (code, myname, "Could not initiate ^a", segname);
	     call clean;
	     return;
	end;
	else init = "1"b;

/* now we do what we came here to do */

	if path ^= "*"
	then call ioa_$rs ("FNP dump ^a>^a", outline, namelen, dirname, segname);
	else call ioa_$rs ("Dump of FNP ^a taken on ^a at ^a", outline, namelen, tag, date, time);
	call ios_$write (output_stream, addr (outline), 0, namelen, (0), iostat);

	call parse_fnp_name_ (tag, fnp_no);
	if fnp_no = -1 then fnp_no = 0;
	call online_355_dump_ (dump_ptr, fnp_no);

	call clean;
	call ioa_ ("Finished dump");
	return;
						/*  */
get_value: proc (result);

/* Internal procedure to get value for keyword parameter */

dcl  result char (*);
dcl  oldarg char (6);

	     if result ^= "*"			/* this one has already been specified */
	     then code = error_table_$inconsistent;

	     else do;
		oldarg = arg;
		call cu_$arg_ptr (iarg+1, argptr, arglen, code);
		if code ^= 0
		then arg = oldarg;

		else result = arg;
	     end;

	     return;
	end /* get_value */ ;
						/*  */
noarg:	proc (name);

/* Internal procedure to print error message for unspecified keyword */

dcl  name char (*);

	     code = error_table_$noarg;
	     call com_err_ (code, myname, "-^a must be supplied.", name);
	     return;
	end /* noarg */ ;



clean:	proc;

/* cleanup handler, also called at normal exit */

	     call ios_$detach (output_stream, "", "", iostat);
	     if init then call hcs_$terminate_noname (dump_ptr, code);
	     return;
	end /* clean */ ;

     end /* od_fnp */ ;




		    print_dump_seg_name_.pl1        01/26/85  1314.2r w 01/22/85  1311.1       40590



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


print_dump_seg_name_: proc (segno, psdw, sstp, sstnp);
						/* Converted to 6180 and v2pl1 by R Mullen Feb 1973 */
dcl  segno fixed bin,				/* Parameters */
     psdw fixed bin (71),
    (xsltp, xnamp) ptr,				/* Pointers to copies of the SLT and Name Table in dump */
     astep ptr,					/* Pointer to AST entry of interest */
     np ptr,					/* r0 name table ptr */
     sstnp ptr;					/* Pointer to copy of SST name table */

dcl  axbitsp ptr;
dcl  ax char (8) aligned;
dcl  axbits (6) bit (1) unaligned based (axbitsp);

dcl (cl, esw) fixed bin;

dcl (line char (130),
     dirname char (168),
     name char (32),
     ename char (32),
     bline char (l) based (lp)) aligned,
     namebuf char (64),
    (lp, sltp, namp, segptr, xsegptr) ptr,
     expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)),
     get_ast_name_ entry (ptr, ptr, ptr, char (*)),
     hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1), fixed bin (2),
     ptr, fixed bin (35)),
    (l, maxl, minl, i) fixed bin;


dcl (fmtnl char (2) init ("^a"),
     fmtsstn char (5) init ("^a ^a"),
     fmtsdw char (46) init ("^-^-^8o  ^o ^o ^o  ^1a  ^5o  ^8a^5o        ^4o")) int static aligned;

dcl (ioa_$rsnnl, od_print_) entry options (variable);	/* Descriptors required */
dcl  ring0_get_$name_given_slt entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35), ptr, ptr);

dcl (addr, baseptr, bin, null, substr) builtin;

dcl  code fixed bin (35);
dcl  dfchar char (1);
dcl  dfno fixed bin;

/*  */
%include sst;
/*  */
% include sdw;
/* 
   Copy args, initialize for formatting SDW breakout */

	esw = 1;

	go to common;

print_dump_seg_name_$get_ptr: entry (segno, sstp, sstnp, xsegptr);
	xsegptr = null;
	esw = 0;
	go to common;


print_dump_seg_name_$hard: entry (segno, psdw, xsltp, xnamp);
	esw = 2;


common:	
	dirname = "";
	ename = "";
	if esw ^= 0 then do;
	     maxl = 100;
	     minl = 0;

	     lp = addr (line);
	     sdwp = addr (psdw);

	     ax = "REWPUG  ";			/* fill in letters for these 6 bits */
	     axbitsp = addr (sdwp -> sdw.read);		/* get pointer to the bits */

	     do i = 1 to 6;				/* look at each one */
		if axbitsp -> axbits (i) = "0"b then substr (ax, i, 1) = " "; /* if axbitsp ->  zero, remove the letter */
	     end;

	     if sdwp -> sdw.df then dfchar = " ";
	     else do;
		dfno = bin (sdwp -> sdw.df_no, 2);
		dfchar = substr ("0123", dfno + 1, 1);
	     end;

	     cl = bin (sdwp -> sdw.entry_bound, 17);

	     call ioa_$rsnnl (fmtsdw, line, l,
	     bin (sdwp -> sdw.add, 24),
	     bin (sdwp -> sdw.r1, 3),
	     bin (sdwp -> sdw.r2, 3),
	     bin (sdwp -> sdw.r3, 3),
	     dfchar,
	     bin (sdwp -> sdw.bound, 14),
	     ax,
	     bin (sdwp -> sdw.entry_bound, 14),
	     segno);
	end;

	if esw ^= 2 then do;			/* non hardcore segname/refname wanted */
	     if sstp = null | sstnp = null then go to print_line;
	     astep = ptr (sstp, bin (sdwp -> sdw.add, 24) - sstp -> sst.ptwbase
			- sstp -> sst.astsize);	/* Compute Astep */
	     call get_ast_name_ (astep, sstp, sstnp, namebuf);	/* Figure out the name */
	     if esw = 1 then call ioa_$rsnnl(fmtsstn, line, l, bline, namebuf);
	     else do;
		call expand_path_ (addr(namebuf), length (namebuf), addr (dirname), addr (ename), code);
		if code ^= 0 then go to pfail;
		if dirname = ">system_library_1" then dirname = ">ldd>hard>object";
		call hcs_$initiate (dirname, ename, "", 0, 1, segptr, code);
		if segptr = null then xsegptr = segptr;
		else
pfail:		xsegptr = null;
	     end;
	     go to print_line;
	end;
	else do;

	     sltp = xsltp;
	     namp = xnamp;
	     np = baseptr (segno);
	     call ring0_get_$name_given_slt (dirname, name, np, code, sltp, namp);
	     if code = 0 then call ioa_$rsnnl (fmtsstn, line, l, bline, name);
	end;


print_line:					/* Print accumulated line image */
	if esw = 0 then return;
	if l > minl				/* See if anything significant in buffer */
	then call od_print_ (1, fmtnl, bline);
     end print_dump_seg_name_;





		    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
