



		    display_entry_point_dcl.pl1     05/01/86  0830.7rew 05/01/86  0808.2       49437



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



	

/****^  HISTORY COMMENTS:
  1) change(84-12-30,Ranzenbach), approve(86-03-12,MCR7144),
     audit(86-03-12,GWMay), install(86-05-01,MR12.0-1051):
     Added support for archive pathnames and ability to requote declaration
     for active functions (phx11853, phx12764).
                                                   END HISTORY COMMENTS */


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/* 									*/
	/* Name:  display_entry_point_dcl						*/
	/* 									*/
	/* This command/af displays the calling sequence of a PL/I procedure entry point as a	*/
	/* PL/I declare statement.  It also displays the PL/I declare statement for error_table_	*/
	/* code (but not for codes in non-system error tables).				*/
	/* 									*/
	/* Status									*/
	/* 									*/
	/* 0) Created in May, 1979  by  G. C. Dixon					*/
	/* 1) Modified in January, 1981 by G. C. Dixon - (1) remove dir part of pathname from	*/
	/* 	entry point name display in declaration; (2) for command output, if		*/
	/* 	get_line_length_ returns nonzero code, don't break declaration at all		*/
	/* 	(probably file_output).						*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **/


display_entry_point_dcl:
depd:	procedure options(variable);
	
     dcl	Larg			fixed bin,
	Parg			ptr,
	arg			char(Larg) based(Parg);

     dcl  Lret			fixed bin(21),
	Pret			ptr,
	ret			char (Lret) varying based(Pret);

     dcl  Nargs			fixed bin,
	Saf			bit(1),
	cleanup			condition,
	code			fixed bin(35),
         (dcl_style, line_length)	fixed bin,
	ent			char(289) varying,	/* 32 char ref_name + 256 char ep_name + $	*/
	type			char(32) varying;

     dcl (active_fnc_err_,
	com_err_,
	err			variable)
				entry options(variable),
         (arg_ptr			variable,
	cu_$af_arg_ptr,
	cu_$arg_ptr)		entry (fixed bin, ptr, fixed bin, fixed bin(35)),
	cu_$af_return_arg		entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
	get_entry_point_dcl_	entry (char(*), fixed bin, fixed bin, char(*) var, char(32) var,
				     fixed bin(35)),
	get_line_length_$switch	entry (ptr, fixed bin(35)) returns(fixed bin),
         (get_temp_segment_,
	release_temp_segment_) 	entry (char(*), ptr, fixed bin(35)),
	requote_string_		entry (char(*)) returns(char(*)),
	iox_$put_chars 		entry (ptr, ptr, fixed bin(21), fixed bin(35)),
	iox_$user_output 		ptr external static;

     dcl (addr, before, length, null, reverse, substr)
				builtin;

     dcl (FALSE			init("0"b),
	TRUE			init("1"b)) bit(1) int static options(constant),
	NL			char(1) int static options(constant) init("
"),
	error_table_$wrong_no_of_args fixed bin(35) ext static,
	sys_info$max_seg_size	fixed bin(35) ext static;
	

	call cu_$af_return_arg (Nargs, Pret, Lret, code);
	if code = 0 then do;
	     ret = "";
	     err = active_fnc_err_;
	     arg_ptr = cu_$af_arg_ptr;
	     dcl_style = 0;
	     line_length = 0;
	     Saf = TRUE;
	     end;
	else do;
	     err = com_err_;
	     arg_ptr = cu_$arg_ptr;
	     Pret = null;
	     on cleanup begin;
		if Pret ^= null then
		     call release_temp_segment_ ("display_entry_point_dcl", Pret, code);
		end;
	     call get_temp_segment_ ("display_entry_point_dcl", Pret, code);
	     if code ^= 0 then go to bad_temp_seg;
	     Lret = (sys_info$max_seg_size-1) * 4;
	     ret = "";
	     Saf = FALSE;
	     dcl_style = 1;
	     line_length = get_line_length_$switch (iox_$user_output, code);
	     if code ^= 0 then do;			/* If no line length given in current mode string,*/
		line_length = 0;			/*   probably file_output, so don't break dcl.	*/
		dcl_style = 0;
		end;
	     end;

	if Nargs ^= 1 then go to WNOA;
	call arg_ptr (1, Parg, Larg, code);

	call get_entry_point_dcl_ (arg, dcl_style, line_length, ret, type, code);
	if code ^= 0 then go to BAD_ARG;

	ent = before (reverse(arg), ">");		/* Remove any dir part of pathname from arg.	*/
	ent = before (ent, "::");			/* and archive name...			*/
	ent = reverse(ent);
	if dcl_style = 0 then
	     ret = "dcl " || ent || " " || ret || ";";
	else ret = "dcl  " || ent  || ret || ";";
	
	if ^Saf then do;
	     ret = ret || NL;
	     call iox_$put_chars (iox_$user_output, addr(substr(ret,1)), length(ret), code);
	     end;
	else ret = requote_string_ ((ret));				/* requote for active functions...	*/

RETURN:	if ^Saf then 
	     if Pret ^= null then 
		call release_temp_segment_ ("display_entry_point_dcl", Pret, code);
	return;


WNOA:	call err (error_table_$wrong_no_of_args, "display_entry_point_dcl", "
  Usage:  ^[[^]display_entry_point_dcl  entryname^[]^]", Saf, Saf);
	go to RETURN;

BAD_ARG:	call err (code, "display_entry_point_dcl", arg);
	go to RETURN;

bad_temp_seg:
	call err (code, "display_entry_point_dcl", "^/While obtaining temp segment.");
	return;

	end display_entry_point_dcl;
     




		    dump_machine_cond_.pl1          10/03/83  1732.6rew 10/03/83  1009.5       73026



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


dump_machine_cond_:
     procedure (cip, fsp, stream, mode);

/* DUMP_MACHINE_COND_ - Print out pretty machine conditions at time of fault.

   This routine can be called with the arguments given it by a condition handler
   or those returned by find_fault_frame_.

   It uses the default_error_handler_ routine reinterpret_condition_ and
   then attempts to print the source line, followed by the machine registers.
*/

dcl cip ptr,					/* ptr to structure returned by find_condition_info_ */
    fsp ptr,					/* fault sp */
    stream char (32) aligned,				/* output stream name */
    mode fixed bin;					/* output mode: 0 = brief */

dcl shortinfo char (8) aligned,			/* returned by convert_status_code_ */
    (i, j, k) fixed bin,				/* counters */
    time char (32) aligned,
    NL char (1) aligned int static init ("
"),
    strp ptr,					/* ptr to interpret_ptr_struc */
    longinfo char (100) aligned,			/* ... explanation of error code in SCU */
    prs (0:7) char (4) int static options (constant)
         init ("(ap)", "(ab)", "(bp)", "(bb)", "(lp)", "(lb)", "(sp)", "(sb)"),
    (tp, tp1) ptr,					/* working pointers */
    areap ptr,					/* pointer to area, where message allocated */
    mp ptr,					/* ptr to message, explains fault */
    ml fixed bin,					/* length of message (see berrm) */
    berrm char (ml) based (mp),			/* message from reinterpret_condition_ */
    barea area ((100)) based (areap),			/* dummy for free */
    w (8) fixed bin based,				/* based words, for regs */
    ec fixed bin (35),				/* error code, from scu */
    faultptr ptr,					/* ptr to fault */
    iocbp ptr,					/* io control block ptr */
    faultsp ptr;					/* stack ptr at time of fault */

dcl 1 condinfo based (cip) aligned,			/* structure returned by find_condition_info_ */
      2 mcptr ptr,
      2 version fixed bin,
      2 condition_name char (32) var,
      2 infoptr ptr,
      2 wcptr ptr,
      2 loc_ptr ptr,
      2 flags,
        3 crawlout bit (1) unal,
        3 pad1 bit (35) unal,
      2 user_loc_ptr ptr,
      2 pad (4) bit (36);

dcl interpret_ptr_ entry (ptr, ptr, ptr),
    interpret_ptr_$frame_owner entry (ptr, ptr, ptr),
    print_source_line_ entry (ptr, char (32) aligned),
    reinterpret_condition_ entry (ptr, ptr, fixed bin, fixed bin, ptr, char (*) aligned, ptr, ptr, ptr),
    get_system_free_area_ entry (ptr),
    convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned),
    prtscu_$on_line entry (ptr, ptr, bit (1)),
    iox_$find_iocb entry (char (*), ptr, fixed bin (35)),
    date_time_ entry (fixed bin (71), char (*) aligned),
    ioa_$rsnnl entry options (variable),
    ioa_$ioa_stream entry options (variable);

%include interpret_ptr_struc;

%include mc;

dcl (addr, fixed, index, null, rel, substr, verify) builtin;

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

	strp = addr (strbuf);			/* initialization. */
	faultsp = fsp;				/* ..copy args */
	mcp = condinfo.mcptr;
	if condinfo.flags.crawlout
	then if condinfo.wcptr ^= null then mcp = condinfo.wcptr;

	if mode = 0 then do;			/* brief mode */
	     call ioa_$ioa_stream (stream, "^a condition:", condinfo.condition_name);
	     return;
	     end;

	call get_system_free_area_ (areap);		/* obtain area for message */

/* This section gets the standard error message which explains the error, and prints it. */

	call reinterpret_condition_ (areap, mp, ml, 3, condinfo.mcptr, (condinfo.condition_name), condinfo.wcptr,
	     condinfo.infoptr, faultsp);
	j = 1;					/* got explanation of fault. now print it */
	i = index (berrm, "Error");			/* take off "error" */
	if i > 0
	then if i < 4 then j = i + 6;			/* .. if it's on the front */
	j = j + verify (substr (berrm, j), " ") - 1;	/* Trim leading blanks. */

	do k = j repeat k + i while (k < ml);		/* Print the error message. */
	     i = index (substr (berrm, k), NL);		/* .. one line at a time. */
	     call ioa_$ioa_stream (stream, "^a", substr (berrm, k, i - 1));
	end;
	free berrm in (barea);			/* done with error msg. free it */
	if mode = 0 then go to exit;			/* no registers if brief mode */
	if mcp = null then do;			/* might be given null. */
	     call ioa_$ioa_stream (stream, "Machine conditions not available.^/");
	     return;
	     end;
	scup = addr (mc.scu);

/* This section attempts to print the source statement which encountered the fault. */

	faultptr = condinfo.user_loc_ptr;
	call interpret_ptr_$frame_owner (faultptr, faultsp, strp);
	if struc.text_ptr ^= null
	then					/* if can print source line, do so. */
	     call print_source_line_ (strp, stream);

/* This section formats the machine conditions and prints them out pretty. */

	call ioa_$ioa_stream (stream, "^/Machine registers at time of fault^/");
p_mc_only:					/* common code for mc_only entry */
	do j = 0 to 7;
	     call printreg (j);
	end;
	call ioa_$ioa_stream (stream, "");

	call ioa_$ioa_stream (stream, "x0 ^6o^3xx1 ^6o^3xx2 ^6o^3xx3 ^6o", fixed (mc.x (0), 18), fixed (mc.x (1), 18),
	     fixed (mc.x (2), 18), fixed (mc.x (3), 18));
	call ioa_$ioa_stream (stream, "x4 ^6o^3xx5 ^6o^3xx6 ^6o^3xx7 ^6o", fixed (mc.x (4), 18), fixed (mc.x (5), 18),
	     fixed (mc.x (6), 18), fixed (mc.x (7), 18));
	call ioa_$ioa_stream (stream, "a ^w  q ^w  e ^o", fixed (mc.a, 35), fixed (mc.q, 35), fixed (mc.e, 8));
	call ioa_$ioa_stream (stream, "Timer reg - ^o, Ring alarm reg - ^1.3b", fixed (mc.regs.t, 27), mc.regs.ralr);
	if mc.fault_reg ^= "0"b
	then					/* display fault reg if present */
	     call ioa_$ioa_stream (stream, "Fault reg - ^12.3b", mc.fault_reg);

	call ioa_$ioa_stream (stream, "^/SCU Data:^/");
	call iox_$find_iocb ((stream), iocbp, ec);	/* find iocb ptr */
	call prtscu_$on_line (iocbp, scup, "1"b);
	call ioa_$ioa_stream (stream, " ");		/* Put out new line  char */
	if mc.fault_time then do;			/* print out time of day if available */
	     call date_time_ (fixed (mc.fault_time, 71), time);
	     call ioa_$ioa_stream (stream, "Time stored: ^a (^18.3b)", time, mc.fault_time);
	     end;
	call ioa_$ioa_stream (stream, "Ring:^10x^d", fixed (scu.ppr.prr, 3));
	ec = mc.errcode;
	if ec ^= 0 then do;				/* Interpret code. */
	     call convert_status_code_ (ec, shortinfo, longinfo);
	     if shortinfo = (8)"x" then call ioa_$rsnnl ("^w", longinfo, i, ec);
	     call ioa_$ioa_stream (stream, "Code:^10x^a", longinfo);
	     end;

	if substr (scu.even_inst, 28, 1) then do;	/* if bit 27 of instruction on display spl data */
	     call ioa_$ioa_stream (stream, "^/EIS Pointers and Lengths:^/");
	     tp1 = addr (mc.eis_info);		/* set up pointer */
	     call ioa_$ioa_stream (stream, "^6o^-^w ^w ^w ^w^/^-^w ^w ^w ^w", fixed (rel (tp1)), tp1 -> w (1),
		tp1 -> w (2), tp1 -> w (3), tp1 -> w (4), tp1 -> w (5), tp1 -> w (6), tp1 -> w (7), tp1 -> w (8));
	     end;
exit:
	call ioa_$ioa_stream (stream, "");
	return;

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

/* mc_only - entry to display a set of machine conditions  only */

mc_only:
     entry (a_mcp, stream);
dcl a_mcp ptr;					/* machine condition pointer */

	mcp = a_mcp;				/* copy arguments */
	strp = addr (strbuf);
	scup = addr (mc.scu);
	go to p_mc_only;				/* join common code */



printreg:
     proc (v1);

dcl v1 fixed bin;

dcl tpx char (20) aligned;
dcl tpxi fixed bin;

	tp = mc.prs (v1);
	call ioa_$rsnnl ("^p", tpx, tpxi, tp);
	call interpret_ptr_ (tp, null, strp);
	call ioa_$ioa_stream (stream, "pr^d ^4a^2x^20a^a^a|^a ^a ^a", v1, prs (v1), tpx, struc.segment, struc.entryn,
	     struc.offset, struc.modifier, struc.comment);

     end printreg;


     end dump_machine_cond_;




		    find_source_line_.pl1           10/03/83  1732.6rew 10/03/83  1009.5       19890



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


find_source_line_:
     procedure (strp, Line_no, Dirname, Ename, Offset, Length, Code);

dcl strp ptr parameter;
dcl Line_no char (*) parameter;
dcl Dirname char (*) parameter;
dcl Ename char (*) parameter;
dcl Offset fixed bin (21) parameter;
dcl Length fixed bin (21) parameter;
dcl Code fixed bin (35);

dcl source_name_ptr ptr;
dcl source_name_len fixed bin (21);
dcl source_name char (source_name_len) based (source_name_ptr);

dcl code fixed bin (35);
dcl (l_comp, l_num) fixed bin;
dcl source_map_ptr ptr;

dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl ioa_$rsnnl entry options (variable);
dcl stu_$get_line entry (ptr, fixed bin, fixed bin, fixed bin, fixed bin (21), fixed bin (21), fixed bin);

dcl (addrel, binary) builtin;

/* * * * * * * * * * FIND_SOURCE_LINE_ * * * * * * * ** */

	Code = 0;
	Offset, Length = 0;
	Line_no, Dirname, Ename = "";

	if ^struc.std_flag then return;
	call stu_$get_line (struc.symbolp, struc.instruction_counter, 1, l_num, Offset, Length, l_comp);
	if l_num = -1 then return;
	call ioa_$rsnnl ("(line ^[^d-^;^s^]^d)", Line_no, (0), (l_comp ^= 0), l_comp, l_num);
	if struc.sourcemap = 0 then return;
	source_map_ptr = addrel (struc.symbolp, struc.sourcemap);
	source_name_ptr = addrel (struc.symbolp, source_map_ptr -> source_map.map (l_comp + 1).pathname.offset);
	source_name_len = binary (source_map_ptr -> source_map.map (l_comp + 1).pathname.size, 21);
	call expand_pathname_ (source_name, Dirname, Ename, code);
	if code ^= 0 then do;
	     Dirname, Ename = "";
	     return;
	     end;
	return;

/* * * * * * * * * * * * * * * * * * */

%include interpret_ptr_struc;
%include source_map;

     end find_source_line_;




		    get_entry_arg_descs_.pl1        11/20/86  1410.0r w 11/20/86  1145.0       87129



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




/****^  HISTORY COMMENTS:
  1) change(84-11-29,Ranzenbach), approve(86-03-12,MCR7144),
     audit(86-03-12,GWMay), install(86-05-01,MR12.0-1051):
     added version 2 entry_desc_info, allowing the processing of
     archive components.
                                                   END HISTORY COMMENTS */


get_entry_arg_descs_$info:
	proc (entry_ptr, nargs, descps, entry_desc_info_ptr, code);

 	ret_info = "1"b;
	if entry_desc_info.version ^= entry_desc_info_version_1 &
	   entry_desc_info.version ^= entry_desc_info_version_2  then do;
	     code = error_table_$unimplemented_version;
	     return;
	     end;
	entry_desc_info.flags = "0"b;
	
	
get_entry_arg_descs_:
	entry (entry_ptr, nargs, descps, code);

/* GET_ENTRY_ARG_DESCS_ - Extract descriptors for procedure parameters.

   If entry_ptr points to an entry sequence or to a segdef, this procedure will
   attempt to extract a list of pointers to parameter descriptors for the entrypoint.
   The expected number of arguments and pointers to descriptors for the arguments will be returned.
   This only works for standard object segments.

   based on "get_entry_name_" by Melanie Weaver
   THVV 1/74
   modified 75-08-04 by M. Weaver to handle descriptor pointers in text
   modified 79-05-09 by J. Falksen and G. Dixon to add the two "info" entries
   */

dcl  entry_ptr ptr;					/* ptr to entry sequence (input)		*/
dcl  nargs fixed bin;				/* Number of arguments.			*/
dcl  descps (*) ptr;				/* array of ptrs to descriptors.		*/
dcl  code fixed bin (35);				/* status code (output)			*/
	
dcl (addwordno, addr, addrel, bin, min, null, ptr, rel, hbound, size) builtin;

dcl (i, j) fixed bin;
dcl  type fixed bin (2);
dcl  mode fixed bin (5);
dcl  bitcnt fixed bin (24);
dcl  no_descrs bit(1);
dcl  ret_info bit(1) init("0"b);			/* Off by default.  Turned on for $info entries.	*/
	
dcl (error_table_$nodescr,
     error_table_$moderr,
     error_table_$dirseg,
     error_table_$unimplemented_version) fixed bin (35) ext;

dcl (segptr, np, defp, def_ptr, txp,  descpp) ptr;

dcl  hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
dcl  hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35));
dcl  object_info_$display ext entry (ptr, fixed bin (24), ptr, fixed bin (35));
dcl  component_info_$offset ext entry (ptr, fixed bin (18), ptr, fixed bin (35));
dcl  condition_ entry (char (*), entry);

dcl  entry_desc_info_version_1	fixed bin int static options(constant) init(1);

%include entry_sequence_info;

dcl 1 entry_sequence_w2 aligned like entry_sequence.word2 based (entry_sequence_w2p);
dcl entry_sequence_w2p ptr;

/* declaration of non class 3 definition (new format) in definition.incl.pl1 */
%include definition;

dcl 1 oi aligned like  object_info;

%include object_info;
%include component_info;

/* ====================================================== */

/* initialize some stuff */

	nargs = -1;

OLD_ENTRY_SEQUENCE:
	if bin (rel (entry_ptr), 18) = 0 then go to no_defs;
						/* Entry point at seg|0 is not preceded		*/
						/*   by a standard entry sequence.		*/
						/* Entry point at seg|1 is preceded by entry flags*/
						/*   but has no descriptors.			*/
	segptr = ptr (entry_ptr, 0);			/* get ptr to base of seg */
	def_ptr = segptr;				/* till we get something better */
	call hcs_$status_mins (segptr, type, bitcnt, code); /* get type and bitcnt */
	if code ^= 0 then return;
	if type = 2 then do;
	     code = error_table_$dirseg;		/* dirs don't have entry points */
	     return;
	end;
	call condition_ ("any_other", catch);		/* Guard against access faults. */
	call hcs_$fs_get_mode (segptr, mode, code);	/* get mode wrt validation level */
	if code ^= 0 then return;			/* don't see how this could happen */
	if mode < 4				/* no read or execute access			*/
	     then do;				/* can't see defs (probably none anyway)	*/
		code = error_table_$moderr;
		return;
	     end;

	if entry_desc_info.version = entry_desc_info_version_2 then do;
	     if entry_desc_info.object_ptr ^= null then do;/* previously assumed offset 0...		*/
		segptr = entry_desc_info.object_ptr;	/* user knows better...			*/
		def_ptr = segptr;
	     end;
	     if entry_desc_info.bit_count > 0 then bitcnt = entry_desc_info.bit_count;
	end;

	oi.version_number = object_info_version_2;
	call object_info_$display (segptr, bitcnt, addr (oi), code); /* may need def ptr */
	if code ^= 0 then return;
	def_ptr = oi.defp;				/* now we have ptr to actual defs */
	txp = oi.textp;

	i = bin (rel (entry_ptr), 18);		/* get offset of input ptr */
	j = bin (rel (oi.textp), 18);			/* get offset of beginning of text */
	if i < j then go to no_defs;			/* If entry above text begin, or */
	if i > j+oi.tlng then go to no_defs;		/* .. if entry below end of text, fail. */

	if oi.compiler ^= "binder" then		/* this compiler generated all entries */
	     if ^oi.format.standard then go to no_defs;	/* This entry must be in std object. */
	     else;
	else do;					/* consult the bind map for this component */
	     call component_info_$offset (segptr, bin (rel (entry_ptr), 18), addr (ci), code);
	     if code ^= 0 then go to no_defs;		/* offset is illegal. fail. */
	     if ^ci.standard then go to no_defs;	/* Must be a standard object. */
	end;

	entry_sequence_w2p = addrel (entry_ptr, -1);	/* get ptr to entry sequence info		*/
	
	if ret_info
	then entry_desc_info.flags = entry_sequence_w2.flags;

	if bin (entry_sequence_w2.def_relp, 18) > oi.dlng then do;
no_defs:	     code = error_table_$nodescr;		/* not in def section			*/
	     return;
	end;
	defp = addrel (oi.defp, entry_sequence_w2.def_relp);	/* get ptr to entry's def		*/
	if ^defp -> definition.new then go to no_defs;	/* Must be new format.			*/
	if ^defp -> definition.entry then go to no_defs;	/* Must have entrypoint flag on. 		*/
	nargs = 0;				/* Assume proc has no args.			*/
	
common:
	if entry_sequence_w2.flags.revision_1		/* descr ptrs are in text if at all.		*/
	then do;
	     if ^entry_sequence_w2.flags.has_descriptors then goto no_defs;
	     np = addrel (entry_ptr, -2);		/*   It has descriptors, so safe to reference	*/
						/*   the descriptor offset now.		*/
	     descpp =  addwordno (segptr, bin (np -> entry_sequence.descr_relp_offset));
	     no_descrs = "0"b;
	end;
	else if defp ^= null then do;			/* see if there are descr ptrs in def. section	*/
	     if ^defp -> definition.argcount then go to no_defs;  /* no parameter info			*/
	     if ^defp -> definition.descriptors
	     then no_descrs = "1"b;
	     else no_descrs = "0"b;
	     descpp = addrel(defp, size(definition));	/* descr array  appended to def		*/
	end;
	else go to OLD_ENTRY_SEQUENCE;		/* defp = null implies that we were entered 	*/
						/* via $text_only or $text_only_info entry point	*/
						/* with version 0 entry sequence in which arg	*/
						/* descriptors are located in definition section. */
						/* Must go through rigor of calling object_info_	*/
						/* in this case, even if given a text entry point.*/
	nargs = bin (descpp ->  parm_desc_ptrs.n_args);	/* Return number of  arguments expected		*/
	num_descs = nargs;

	if no_descrs then				/* No descriptors, but argcount was available.	*/
	     descps (*) = null;
	else do i = 1 to min (nargs, hbound (descps, 1));	/* Return pointers to descriptors.		*/
						/* ..  which are in the text section		*/

	     descps (i) = addwordno (txp, bin (descpp -> parm_desc_ptrs.descriptor_relp (i)));
	end;
	return;					/* Success. */



text_only_info: entry (entry_ptr, nargs, descps, entry_desc_info_ptr, code);

 	ret_info = "1"b;
	if entry_desc_info.version ^= entry_desc_info_version_1 &
	   entry_desc_info.version ^= entry_desc_info_version_2  then do;
	     code = error_table_$unimplemented_version;
	     return;
	     end;
	entry_desc_info.flags = "0"b;


text_only: entry (entry_ptr, nargs, descps, code);

/* assume entry ptr points  to a text entry sequence; do no validation */

	code = 0;
	nargs = -1;
	defp = null;				/* don't want ptr to definition		*/
	txp = ptr (entry_ptr, 0);
	if bin (rel (entry_ptr), 18) = 0 then go to no_defs;
						/* Entry point at seg|0 is not preceded		*/
						/*   by a standard entry sequence.		*/
						/* Entry point at seg|1 is preceded by entry flags*/
						/*   but has no descriptors.			*/
	entry_sequence_w2p = addrel (entry_ptr, -1);	/* get ptr to entry sequence word 2.		*/

	if ret_info
	then entry_desc_info.flags = entry_sequence_w2.flags;
	go to common;

catch:	proc (mcptr, condname, wcptr, infoptr, continue);

dcl (mcptr, wcptr, infoptr) ptr;
dcl  condname char (*);
dcl  continue bit (1) aligned;

	     if condname = "quit" then go to pass;
	     if condname = "alrm" then go to pass;
	     if condname = "cput" then go to pass;
	     if condname = "program_interrupt" then go to pass;
	     if condname = "finish" then go to pass;
	     if condname = "storage" then go to pass;
	     if condname = "mme2" then do;
pass:		continue = "1"b;
		return;
	     end;

	     if condname ^= "cleanup" then go to no_defs; /* probably access fault;
						   in any case, forget it */
	     return;
	end catch;

     end get_entry_arg_descs_$info;





		    get_entry_point_dcl_.pl1        04/19/88  0934.0rew 04/19/88  0838.0      240561



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



	

/****^  HISTORY COMMENTS:
  1) change(84-12-30,Ranzenbach), approve(86-03-12,MCR7144),
     audit(86-03-12,GWMay), install(86-05-01,MR12.0-1051):
     added support for archive component pathnames and repairs for:
     phx09270 - handle trailing blanks in arg.
     phx09340 - ""
     phx09592 - Illegal PL/I coding.
  2) change(88-01-01,Gilcrease), approve(88-02-01,MCR7836),
     audit(88-03-17,RBarstad), install(88-04-19,MR12.2-1040):
               Make error_table_ produce same out as >sl1>error_table_.
               Allow argument as ask_$ask_ = ask_ and in .dcl file.
                                                   END HISTORY COMMENTS */


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/* 									*/
	/* Name:  get_entry_point_dcl_						*/
	/* 									*/
	/*      This program obtains PL/I declare attributes for external procedure entry points, */
	/* and for error_table_ codes and other, system-wide external data.  The program obtains	*/
	/* the entry point dcl attributes from two sources:  data files declaring all unusual	*/
	/* procedure entry points (ALM segments, procedures written as subroutines but used as	*/
	/* functions, etc) and system-wide data values (eg, sys_info$max_seg_size);  the	*/
	/* argument descriptors included in the procedure entry point itself which describe the	*/
	/* entry point parameters.							*/
	/* 									*/
	/*      The data files declaring unusual entries are found via the "declare" search list. */
	/* The user may set this search list (via add_search_paths, etc) to use his own data	*/
	/* segments, or may use the default data file which get_entry_point_dcl_ sets to pl1.dcl	*/
	/* in its referencing dir if no declare search list has been set.			*/
	/* 									*/
	/*      The data files contain two kinds of entries, procedure entry point declarations	*/
	/* and user-defined abbreviations used by EMACS in PL/I mode.  Each entry appears on a	*/
	/* separate line.  Procedure entries have the form:				*/
	/* 									*/
	/*   proc_name  declaration							*/
	/* 									*/
	/* For example:								*/
	/* 									*/
	/*   ioa_	entry options (variable)						*/
	/* 									*/
	/* Note that the declaration does NOT end with a ; character.  System data entries are	*/
	/* declared in a similar manner.  For example					*/
	/* 									*/
	/*   iox_$user_output ptr external static					*/
	/* 									*/
	/* EMACS PL/I mode abbreviation entries have the form				*/
	/* 									*/
	/*   abbrev_name ==> abbrev_value						*/
	/* 									*/
	/* For example:								*/
	/* 									*/
	/*   fb ==> fixed bin							*/
	/*   cond ==> condition							*/
	/* 									*/
	/* Abbreviation entries are processed only by the $emacs entry, not			*/
	/* by get_entry_point_dcl_.							*/
	/* 									*/
	/* Entry:  get_entry_point_dcl_						*/
	/* 									*/
	/*      This entry point returns the declaration for an external value, either from one	*/
	/* of the data files, or by using the parameter argument descriptors associated with the	*/
	/* procedure entry point.  It special cases error_table_ values by always returning 	*/
	/* 'fixed bin(35) ext static' for them.  For example, given the name iox_$put_chars, it	*/
	/* might return								*/
	/* 									*/
	/*   entry (ptr, ptr, fixed bin(21), fixed bin(35))				*/
	/* 									*/
	/* Usage									*/
	/* 									*/
	/*   dcl get_entry_point_dcl_ entry (char(*), fixed bin, fixed bin, 			*/
	/*	char(*) varying, char(32) varying, fixed bin(35));			*/
	/* 									*/
	/*   call get_entry_point_dcl_ (name, dcl_style, line_length, dcl, type, code);		*/
	/* 									*/
	/* where									*/
	/* 1. name								*/
	/* 	is the name of the external entry point or data item whose declaration must be	*/
	/* obtained. (Input)							*/
	/* 									*/
	/* 2. dcl_style								*/
	/* 	is the style of indentation to be performed for the name.  			*/
	/* (Input)								*/
	/*    0 = no indentation, entire dcl on a single line				*/
	/*    1 = indentation as for the indent command					*/
	/*    2 = indentation as preferred by Gary Dixon					*/
	/* 									*/
	/* 3. line_length								*/
	/* 	is maximum length lines in return value are allowed to grow when indentation is */
	/* performed. (Input)							*/
	/* 									*/
	/* 4. dcl is the declaration which was obtained. (Output)				*/
	/* 									*/
	/* 5. type								*/
	/* 	is the type of declaration.  In the current implementation, this is always a	*/
	/* 	null string.							*/
	/* 									*/
	/* 6. code								*/
	/* 	is a standard status code describing any failure to obtain the declaration.	*/
	/* 									*/
	/* Entry:  get_entry_point_dcl_$emacs						*/
	/* 									*/
	/*   dcl get_entry_point_dcl_$emacs entry (char(*), fixed bin, fixed bin, 		*/
	/* 	char(*) var, char(32) var, char(100) var);				*/
	/* 									*/
	/*   call get_entry_point_dcl_$emacs (name, dcl_type, line_length, dcl, type, error);	*/
	/* 									*/
	/* where:									*/
	/* 									*/
	/* 1. - 4.								*/
	/* 	are as above.							*/
	/* 									*/
	/* 5. type								*/
	/* 	is "abbrev" if an abbreviation was found, and "" otherwise. (Output)		*/
	/* 									*/
	/* 6. error								*/
	/* 	is a converted error code (if an error occurred), or a description of how the	*/
	/* 	declaration was obtained, if not found in one of the data files. (Output)	*/
	/* 									*/
	/* Status									*/
	/* 									*/
	/* 0) Created   May, 1979  by  Gary C. Dixon					*/
	/* 1) Modified  Jan, 1981  by G. C. Dixon - handle non-system error table codes.	*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **/


get_entry_point_dcl_:
	procedure (arg, dcl_style, line_length, ret, type, Acode);

	Semacs = FALSE;
	Acode = 0;
	go to COMMON;

emacs:	entry (arg, dcl_style, line_length, ret, type, error);

	Semacs = TRUE;
	error = "";
	go to COMMON;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **/


     dcl  arg			char(*),
	dcl_style			fixed bin,
	line_length		fixed bin,
	ret			char(*) varying,
	type			char(32) varying,
	error			char(100) varying,
	Acode			fixed bin(35);

     dcl	
         (Idir, Ihunt, Istart_of_line)	fixed bin,
	Iparen_depth		fixed bin,
	Lfile			fixed bin(21),
         (Lparm, Lword)		fixed bin,
         (Ldcl_begin, Lindent, Ipos)	fixed bin,
	Nsearch_paths		fixed bin,
         (Pfile, Pparm, Pseg, Pword)	ptr,
	Semacs			bit(1),
	Serror_table		bit(1),
	bc			fixed bin(24),
	cleanup			condition,
	code			fixed bin(35),
	component			char(32),
	dir			char(168),
	ent			char(32),
	long			char(100),
	result			char(2000) varying,
	short			char(8);

     dcl
	area			area based(Parea),
	file			char(Lfile) based(Pfile),
	file_ch (Lfile)		char(1) based(Pfile),
	parm			char(Lparm) based(Pparm),
	word			char(Lword) based(Pword);

     dcl (addr, addrel, before, codeptr, copy, divide, index, length, ltrim, mod,
	null, ptr, rel, reverse, rtrim, search, substr, verify)
				builtin;

     dcl	convert_status_code_	entry (fixed bin(35), char(8), char(100)),
	expand_pathname_$component	entry (char(*), char(*), char(*), char(*), fixed bin(35)),
	get_system_free_area_	entry returns (ptr),
	initiate_file_$component	entry (char(*), char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)),
	search_paths_$get		entry (char(*), bit(36), char(*), ptr, ptr, fixed bin, ptr,
				     fixed bin(35)),
	terminate_file_		entry (ptr, fixed bin(24), bit(*), fixed bin(35));

     dcl (error_table_$new_search_list,
	error_table_$nodescr,
	error_table_$no_search_list,
	error_table_$zero_length_seg)	fixed bin(35) ext static;

     dcl
         (FALSE			init("0"b),
	TRUE			init("1"b)) bit(1) int static options(constant),
	HT			char(1) int static options(constant) init("	"),
	HT_SP			char(2) int static options(constant) init("	 "),
	HT_SP_NL			char(3) int static options(constant) init("	 
"),
	NL			char(1) int static options(constant) init("
"),
	Parea			ptr int static init(null),
	SP			char(1) int static options(constant) init(" ");
	







COMMON:	ret = "";					/* Initialize return values.			*/
	type = "";

	Pseg = null;				/* Prepare for cleanup on unit.		*/
	sl_info_p = null;

	on cleanup call janitor();
	result = "";				/* No result found so far.			*/

	if Parea = null then
	     Parea = get_system_free_area_();

	call search_paths_$get ("declare", sl_control_default, "", null(),
	     Parea, sl_info_version_1, sl_info_p, code);
	if  code = error_table_$no_search_list  then 
	     Nsearch_paths = 0;
	else if code = error_table_$new_search_list | code = 0 then
	     Nsearch_paths = sl_info.num_paths;
	else if code ^= 0 then go to ERROR;

	if index (arg, "$") ^= 0 then do;	/* is arg in form "frog_$frog_"? */
	     if substr (arg, 1, index (arg, "$") - 1) =
	     substr (arg, index (arg, "$") + 1, length (rtrim (arg)) - index (arg, "$")) 
		then do Ihunt = index (arg, "$") to length (rtrim (arg));
		     substr (arg, Ihunt, 1) = " ";	/* clear "$frog_" */
		end;
	end;

	do Idir = 1 to Nsearch_paths while(result = "");
						/* In each segment identified in the search	*/
	     dir, ent, component = "";
	     call expand_pathname_$component (sl_info.paths(Idir).pathname, dir, ent, component, code);
	     call initiate_file_$component (dir, ent, component, R_ACCESS, Pseg, bc, code);
	     if Pseg ^= null then do;
		Pfile = Pseg;			/* Address the segment.			*/
		Lfile = divide(bc, 9, 24, 0);
		do while(Lfile > 0  &  result = "");
		     Ihunt = index(file, rtrim(arg));	/* Make quick check to see if any hope at all	*/
		     if Ihunt = 0 then		/*   of finding entry point dcl, or abbrev.	*/
			Lfile = 0;
		     else do;
			Istart_of_line = index(reverse(substr(file,1,Ihunt-1)),NL);
			if Istart_of_line > 0 then do;/* Address potential matching line.		*/
			     Pfile = addr(file_ch(Ihunt-Istart_of_line+1));
			     Lfile = Lfile - (Ihunt-Istart_of_line);
			     end;			/* Toss away stuff preceding matching line.	*/
			call find_word_and_skip();	/* If first word on line names entry point or	*/
			if word_equal_arg () then do;	/*   abbrev we want, then EUREKA!		*/
			     call skip_whitespace();	/* Skip whitespace following name.		*/
			     result = rest_of_line(); /* Assume entry point dcl, make dcl the result.	*/
			     call find_word_and_skip();
			     if  word = "==>"  then	/* But check for an EMACS abbrev.		*/
				if Semacs then do;	/* If looking for EMACS abbrev's, we've found it. */
				     type = "abbrev";
				     error = "abbrev";
				     call skip_whitespace();
				     result = rest_of_line();
				     end;
				else result = "";	/* Other, continue looking since matching EMACS	*/
			     end;			/*   abbrev does not signify end of search for	*/
						/*   an entry point dcl.			*/
			call skip_line();
			end;
		     end;
		call terminate_file_ (Pseg, 0, TERM_FILE_TERM, code);
		Pseg = null;			/* Done looking at this seg.			*/
		end;
	     end;

	if result = "" then do;			/* dcl or abbrev not found in dcl segs.		*/
	     call get_entry_point_dcl_from_desc  (rtrim(arg), result, Serror_table, code);
	     if code ^= 0 then do;			/* Check the entry point descriptors.		*/
ERROR:		if Semacs then do;			/* Be kind to emacs, do error code conversion.	*/
		     call convert_status_code_ (code, short, long);
		     error = rtrim(long);
		     end;
		else Acode = code;
		end;
	     else if Semacs then do;			/* Tell EMACS user how declaration was found.	*/
		if Serror_table then
		     error = "dcl error_table_ code";
		else do;
		     Pfile = addrel(addr(result),1);	/* To do this, overlay result so we can use the	*/
		     Lfile = length(result);		/*   find_word_and_skip primitive.		*/
		     call find_word_and_skip();
		     if word = "entry()" then		/* entry() ==> all parm descriptors valid.	*/
			error = "dcl via parm descriptors";
		     else if  word = "entry"  then do;
			call find_word_and_skip();
			if  word = "options(variable)"  then
			     error = "no parm descriptors available";
			else error = "dcl via parm descriptors";
			end;
		     else error = "dcl via parm descriptors";
		     end;
		end;
	     end;

	if  result = ""  then;
	else if  type = "abbrev"  then		/* Output abbrev's as they stand.		*/
	     ret = result;
	
	else if  dcl_style = 0  then			/* No formatting dcl style.			*/
	     ret = result;
	else do;					/* Split non-abbrev's across lines, etc.	*/

	     if  dcl_style = 1  then do;		/*   dcl style used by indent.		*/
		Ipos = 6;
		Ldcl_begin = Ipos + length(arg) + 1;
		Lindent = 11;
		end;
	     else do;				/*   dcl style used by Gary Dixon.		*/
		Ipos = 11;
		Ldcl_begin = 41;
		Lindent = 46;
		end;
	     Ipos = Ipos + length(arg);		/*   Record current line position.		*/
	     if Ipos >= Ldcl_begin then do;		/*   Entry point name already beyond the dcl	*/
		ret = ret || NL;			/*     indent column.  Skip to next line.	*/
		Ipos = 1;
		end;
	     if Ipos < Ldcl_begin then do;		/*   Skip out to dcl column.			*/
		ret = ret || whitespace_to_pos (Ldcl_begin);
		Ipos = Ldcl_begin;
		end;
	     if length(result) + Ipos <= line_length then
		ret = ret || result;		/*   Handle simple case first.		*/
	     else do;				/*   The dcl is too long to fit on one line.	*/
		Pfile = addrel(addr(result),1);	/*   Address the dcl.			*/
		Lfile = length(result);
		Iparen_depth = 0;			/*   Prepare find_parm_and_skip for use.	*/
		do while (Lfile > 0);		/*   Add successive parameter descriptors to line */
		     call find_parm_and_skip();	/*     until they no longer fit.  Then, skip	*/
						/*     to next line.  Continue until all of dcl	*/
						/*     processed.				*/
		     if  Ipos + length(parm) <= line_length  then do;
			ret = ret || parm;
			Ipos = Ipos + length(parm);
			end;
		     else do;
			ret = ret || NL;
			Ipos = 1;
			ret = ret || whitespace_to_pos(Lindent);
			Ipos = Lindent;
			ret = ret || ltrim(parm);
			Ipos = Ipos + length(ltrim(parm));
			end;
		     end;
		end;
	     end;
	call janitor();
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **/

word_equal_arg: proc returns (bit (1));	/* special-case "frog_$frog_" */

	if index (word, "$") ^= 0 then 
	     if substr (word, 1, index (word, "$") - 1) =
	     substr (word, index (word, "$") + 1, Lword - index (word, "$")) then
		return (rtrim (arg) = substr (word, 1, index (word, "$") - 1 ));

	return (rtrim (arg) = word);

end word_equal_arg;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **/


find_parm_and_skip:					/* Simple heuristic to find next parm desc.	*/
	proc;					/* Parm ends with first , or ) not inside of ().	*/
	
     dcl (Idelim)			fixed bin,
	Sparm_not_found		bit(1),
	ch			char(1);

	Pparm = Pfile;
	Lparm = 0;
	Sparm_not_found = TRUE;
	do while(Sparm_not_found);
	     Idelim = search(file,"(),");
	     if Idelim = 0 then do;
		Lparm = Lfile;
		Lfile = 0;
		Sparm_not_found = FALSE;
		end;
	     else do;
		ch = substr(file,Idelim);
		if ch = "(" then
		     Iparen_depth = Iparen_depth + 1;
		else if  ch = ")"  &  Iparen_depth = 1  then do;
		     Iparen_depth = 0;
		     Sparm_not_found = FALSE;
		     end;
		else if  ch = ")"  then
		     Iparen_depth = Iparen_depth - 1;
		else if  Iparen_depth = 1  then
		     Sparm_not_found = FALSE;
		Lparm = Lparm + Idelim;
		if Idelim = Lfile then
		     Lfile = 0;
		else do;
		     Pfile = addr(file_ch(Idelim+1));
		     Lfile = Lfile - Idelim;
		     end;
		end;
	     end;
	end find_parm_and_skip;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **/


find_word_and_skip:
	proc;

     dcl	Iwhite			fixed bin;
	
	Iwhite = verify (file, HT_SP);
	if Iwhite = 0 then do;			/* Remainder of file is whitespace.		*/
	     Lfile = 0;
	     Pword = Pfile;
	     Lword = 0;
	     end;
	else do;
	     if Iwhite > 1 then do;
		Pfile = addr(file_ch(Iwhite));
		Lfile = Lfile - (Iwhite-1);
		end;
	     Pword = Pfile;
	     Lword = search (file, HT_SP_NL);
	     if Lword = 0 then do;
		Lword = Lfile;
		Lfile = 0;
		end;
	     else do;
		Lword = Lword - 1;
		Pfile = addr(file_ch(Lword+1));
		Lfile = Lfile - Lword;
		end;
	     end;

	end find_word_and_skip;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **/


get_entry_point_dcl_from_desc:
	proc (Aep_name, Aret, Serror_table, Acode);
	
     dcl	Aep_name			char(*),		/* Name of entry point to be declared.		*/
	Aret			char(*) varying,	/* Declaration of entry point. (Out)		*/
	Serror_table		bit(1),		/* On if entry point is an error table code. (Out)*/
	Acode			fixed bin(35);	/* Status code.				*/

     dcl	Eproc			entry variable options(variable),
	Nproc_args		fixed bin,
 	Pproc			ptr,
	Pproc_desc (100)		ptr,
	ec_Pproc			ptr,
	code			fixed bin(35),
	i			fixed bin;

     dcl	Ppacked			ptr unal based;

     dcl	cv_entry_			entry (char(*), ptr, fixed bin(35)) returns(entry),
	cv_ptr_			entry (char(*), fixed bin(35)) returns(ptr),
	cv_ptr_$terminate		entry (ptr),
	get_pl1_parm_desc_string_	entry (ptr, char(*) var, fixed bin(35)),
	get_entry_arg_descs_$info	entry (ptr, fixed bin, (*) ptr, ptr, fixed bin(35));

	edi.version = entry_desc_info_version_2;	/* Get entry point parameter descriptors.	*/
	edi.object_ptr = null;
	edi.bit_count = 0;
	
	if index (Aep_name, "::") = 0 then do;		/* non-archive component path...	*/
	     Eproc = cv_entry_ (Aep_name, null(), Acode);	/* Convert entry point name to entry constant.	*/
	     if Acode ^= 0 then return;
	     Pproc = codeptr(Eproc);			/* Turn entry constant into a ptr.		*/
	end;
	else do;					/* the archive component case...		*/
	     Pproc = cv_ptr_ (Aep_name, Acode);		/* no sense snapping links...			*/
	     if Acode ^= 0 then return;
	     dir, ent, component = "";
	     call expand_pathname_$component (before (Aep_name, "$"), dir, ent, component, Acode);
	     if Acode ^= 0 then return;
	     call initiate_file_$component (dir, ent, component, R_ACCESS, edi.object_ptr, edi.bit_count, Acode);
	     if edi.object_ptr = null then return;
	end;
		
	Aret = "";
	call get_entry_arg_descs_$info (Pproc, Nproc_args, Pproc_desc, addr(edi), Acode);

	if Acode = error_table_$nodescr then do;
	     if index (Aep_name, "error_table_$") ^= 0 then do;
		Aret = Aret || "fixed bin(35) ext static";
		Acode = 0;			/* Check for error_table_ Acodes.		*/
		Serror_table = TRUE;
		end;

	     else do;				/* Handle no args case.			*/
		Acode = 0;
		go to NO_ARGS;
		end;
	     end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Hueristic for determining if entry point is in a non-system error table:		*/
	/*									*/
	/* Non-system error tables have messages in the text pointed to by error table codes	*/
	/* really packed pointers) which are stored in the linkage section for the error	*/
	/* table.  At first reference to the table, the linker copies the linkage template for	*/
	/* the table into the combined_linkage area, and a first_ref trap proc gets invoked to	*/
	/* set the segment numbers in all of the packed pointers to the segno of the text	*/
	/* section.								*/
	/*									*/
	/* (1) get_entry_parm_descs_ returns error_table_$zero_length_seg for such beasties,	*/
	/*     perhaps because they do not contain any entry points into their text section (ie,	*/
	/*     all entry points are into the linkage section.				*/
	/* (2) For this return code, the call to cv_entry_ above will have returned a pointer to	*/
	/*     the error code (packed ptr in the linkage section) corresponding to the error	*/
	/*     table entry.  This code points to the text of the error message.		*/
	/* (3) cv_ptr_ on the other hand, returns a pointer to the error code which appears in	*/
	/*     the linkage section template (contained in the error table segment itself).	*/
	/* (4) Thus, it is reasonably safe to assume entry to be a non-system error table if:	*/
	/*        baseno(cv_entry_(ep) -> packed_ptr) = baseno(cv_ptr_(ep));			*/
	/*           rel(cv_entry_(ep) -> packed_ptr) =    rel(cv_ptr_(ep));			*/
	/*     The above conditions are prima facia evidence that a trap proc was invoked to	*/
	/*     change the left half-word of the linkage template for the entry point to the	*/
	/*     segment number.  Only non-system error tables do this, to best of my knowledge.	*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	else if  Acode = error_table_$zero_length_seg  then do;
	     ec_Pproc = cv_ptr_ (Aep_name, code);
	     if ec_Pproc ^= null then do;
		if Pproc -> Ppacked = ptr(ec_Pproc, rel(ec_Pproc -> Ppacked)) then do; 
		     Aret = Aret || "fixed bin(35) ext static";
		     Acode = 0;
		     Serror_table = TRUE;
		     end;
		call cv_ptr_$terminate (ec_Pproc);
		end;
	     else return;
	     end;
	else if  Acode ^= 0  then return;		/* Diagnose unknown error.			*/
	else if  Nproc_args = 0  then do;		/* Check for no args.			*/
NO_ARGS:	     if  edi.flags.variable  then		/*   Proc says it is options(variable), so 	*/
						/*     include entry() indicating we are sure.	*/
		Aret = Aret || "entry() options(variable)";
	     else Aret = Aret || "entry options(variable)";/*   Proc does not say options(variable), but	*/
						/*     many commands/af do not have		*/
						/*     options(variable) in their proc/entry stmt.*/
	     end;					/*     So, use entry w/o () to indicate we're not */
						/*     sure.				*/

	else do;					/* Proc has declared args.			*/
	     do i = 1 to Nproc_args while (Pproc_desc(i) = null);
		end;				/*   Check for old procedure with declared arg	*/
	     if i > Nproc_args then go to NO_ARGS;	/*     count, but no arg descriptors.		*/

	     if Nproc_args = 1 & edi.flags.function then
		Aret = Aret || "entry(";
	     else Aret = Aret || "entry (";

	     if  edi.flags.function  then		/*   Check for functions.			*/
		Nproc_args = Nproc_args - 1;		/*     Exclude return arg from parm list.	*/

	     do i = 1 to Nproc_args;			/*   Put parms in the parm list.		*/
		call get_pl1_parm_desc_string_ (Pproc_desc(i), Aret, Acode);
		if Acode ^= 0 then return;
		Aret = Aret || ", ";
		end;

	     if Nproc_args > 0 then
		Aret = substr(Aret, 1, length(Aret)-2);	/*   Remove trailing ", " after last arg.	*/
	     if  edi.flags.function  then do;		/*   Handle function subcase.			*/
		Aret = Aret || ") returns(";
		call get_pl1_parm_desc_string_ (Pproc_desc(i), Aret, Acode);
		if Acode ^= 0 then return;
		Aret = Aret || ")";
		end;
	     else do;				/*   Handle subroutine subcase.		*/
		if  edi.flags.variable  then do;	/*     Handle options(variable) subroutine.	*/
		     Aret = Aret || ") options(variable)";
		     end;
		else Aret = Aret || ")";
		end;
	     end;

	end get_entry_point_dcl_from_desc;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **/


janitor:	proc();

	if Pseg ^= null then do;
	     call terminate_file_ (Pseg, 0, TERM_FILE_TERM, code);
	     Pseg = null;
	     end;
	if sl_info_p ^= null then
	     free sl_info in (area);
	end;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **/


rest_of_line:
	proc() returns (char(*));

     dcl	Inl			fixed bin,
	Lrest			fixed bin,
	Prest			ptr,
	rest			char(Lrest) based(Prest);

	Inl = index(file, NL);
	if Inl = 0 then
	     Inl = Lfile + 1;
	Prest = Pfile;
	Lrest = Inl - 1;
	return (rest);

	end rest_of_line;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


skip_line:
	proc();
	
     dcl	Inl			fixed bin;

	Inl = index(file, NL);
	if  Inl = 0  |  Inl = Lfile  then
	     Lfile = 0;
	else do;
	     Pfile = addr(file_ch(Inl+1));
	     Lfile = Lfile - Inl;
	     end;

	end skip_line;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **/


skip_whitespace:
	proc;
	
     dcl  Iwhite			fixed bin;
	
	Iwhite = verify (file, HT_SP);
	if Iwhite = 0 then
	     Lfile = 0;
	else if Iwhite > 1 then do;
	     Pfile = addr(file_ch(Iwhite));
	     Lfile = Lfile - (Iwhite-1);
	     end;
	
	end skip_whitespace;
     
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **/


whitespace_to_pos:
	proc (Inew_pos) returns(char(*));

     dcl	Inew_pos			fixed bin;
	
     dcl (Ispace, Itab)		fixed bin;
	
	if Inew_pos <= Ipos then			/* Already at or beyond desired position.	*/
	     return ("");				/*   Do nothing.				*/
	else do;
	     Ispace = mod(Inew_pos-1, 10);
	     Itab = divide (Inew_pos - Ispace - Ipos + 9, 10, 17, 0);
	     if Itab = 0 then
		Ispace = Inew_pos - Ipos;
	     return (copy(HT, Itab) || copy(SP, Ispace));
	     end;

	end whitespace_to_pos;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **/

%include access_mode_values;
%page;
%include entry_desc_info;

     dcl	1 edi			aligned like entry_desc_info;
%page;
%include sl_info;

%include sl_control_s;
%page;
%include terminate_file;

	end get_entry_point_dcl_;




		    get_pl1_parm_desc_string_.pl1   10/03/83  1732.6rew 10/03/83  1009.5      109134



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


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/* 									*/
	/* Name:  get_pl1_parm_desc_string_						*/
	/* 									*/
	/*      Given a pointer to the argument descriptor for an entry point parameter, and a	*/
	/* string in which the PL/I declaration of the entry point is being constructed, this	*/
	/* subroutine appends a description of the parameter to the string.			*/
	/* 									*/
	/* Status									*/
	/* 									*/
	/* 0) Created  in May, 1979  by  G. C. Dixon					*/
	/* 1) Modified  in Jan, 1981 by G. C. Dixon - handle decimal unaligned values;		*/
	/*				      reimplement handling of structure alignment */
	/* 2) Modified  in Jan, 1983 by T. G. Oke   - handle star extents for pl1 and fortran	*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **/


get_pl1_parm_desc_string_:	
	procedure	(Pdesc, string, Acode);

     dcl	Pdesc			ptr,		/* ptr to	descriptor to be printed.		*/
	string			char(*) varying,	/* return string, as supplied by caller.	*/
	Acode 			fixed bin(35);

	offset = 0;
	call recurse (Pdesc, 1, 0, "1"b, "0"b, offset, string, Acode);
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **/


recurse:	entry (Pdesc, level, Nignored_dim, Slast, ASpacked, Aoffset, string, Acode);

     dcl	level			fixed bin,	/* structure level of this descriptor.		*/
	Nignored_dim		fixed bin,	/* number of dimension inherited from containing	*/
						/*  structure, to be ignored on output.		*/
	Slast			bit(1) aligned,	/* on if last structure element at this structure	*/
						/*  is being output, or on for scalars.		*/
	ASpacked			bit(1) aligned,	/* on if prev structure level was packed.	*/
	Aoffset			fixed bin;	/* offset in words of next structure element	*/
						/*   descriptor from one being processed.	*/



     dcl	j			fixed bin;
     dcl	offset			fixed bin;
     dcl (type, Ndim, size, scale)	fixed bin,
	Spacked			bit(1) aligned;
     dcl	Pelement_desc		ptr;

     dcl	desc (0:Aoffset-1)		fixed bin(35) based(Pdesc);

     dcl	decode_descriptor_		entry (ptr, fixed bin, fixed bin, bit(1) aligned,	fixed bin, fixed bin, fixed bin);

     dcl	pl1_type (1:46)		char(24) varying int static init (
				     "fixed bin",
				     "fixed bin",
				     "float bin",
				     "float bin",
				     "complex fixed bin",
				     "complex fixed bin",
				     "complex float bin",
				     "complex float bin",
				     "fixed dec",
				     "float dec",
				     "complex fixed dec",
				     "complex float dec",
				     "ptr",
				     "offset",
				     "label",
				     "entry",
				     "",		/* structure */
				     "area",
				     "bit",
				     "bit",
				     "char",
				     "char",
				     "file",
				      (9)*,
				     "uns fixed bin",
				     "uns fixed bin",
				      (8)*,
				     "fixed dec",
				     "float dec",
				     "complex fixed dec",
				     "complex float dec");
     dcl  star_pl1_bits		bit (36) static initial ("400000000000"b3);
     dcl  star_fort_bits		bit (36) static initial ("377777777777"b3);

     dcl  star_pl1_size		fixed bin(35) based (addr (star_pl1_bits));
     dcl  star_fort_size		fixed bin(35) based (addr (star_fort_bits));

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

     dcl (addr, addrel, length, ltrim, mod, substr)
				builtin;

	Acode = 0;
	Aoffset = 1;
	call decode_descriptor_ (Pdesc, 0, type, Spacked,	Ndim, size, scale);
	if  (1 <= type & type <= 23) |		/* Support only PL/I data types.		*/
	    (33 <= type & type <= 34) |
	    (43 <= type & type <= 46) then;
	else do;					/* unimplemented or invalid descriptor.		*/
	     Acode = error_table_$bad_segment;
	     return;
	     end;

	if type = 17 then do;			/* Handle structure level.			*/
	     string = string || cv_num(level);
	     end;
	else if level > 1 then do;			/* Handle structure element level.		*/
	     string = string || cv_num(level);
	     string = string || " ";
	     end;
	else;					/* Do nothing for scalars.			*/

	Aoffset = Aoffset + 3*Ndim;			/* Handle arrays.				*/
	if Ndim - Nignored_dim > 0 then do;		/*   Dimensions reported in prev. recursions are	*/
	     string = string || "(";			/*     ignored.				*/
	do j = 3 * (Ndim-Nignored_dim-1) to 0 by -3;
		if desc(j+1) = 1 then string = string || cv_desc_num_(desc(j+2));
						/*   Omit lbound of 1.			*/
		else do;
		     if desc (j+1) = star_pl1_size |
			desc (j+1) = star_fort_size	/*   star extent */

		     then string = string || cv_desc_num_(desc (j+1));
		     else do;
			string = string || cv_desc_num_(desc(j+1));
			string = string || ":";
			string = string || cv_desc_num_(desc(j+2));
			end;
		     end;
		string = string || ",";
		end;
	     substr(string,length(string),1) = ")";	/*   Change final , to ) after last dimension.	*/
	     string = string || " ";
	     end;

	string = string || pl1_type(type);		/* Output PL/I data type.			*/

						/* Output precision and scale.		*/
	if  (type <= 8) | (33 <= type & type <= 34)  then do;   
						/* binary	numeric.				*/
	     if size = 17 & scale = 0 then;		/*   omit default size/scale.			*/
	     else do;
		string = string || "(";
		string = string || cv_num (size);

		if mod(type-1,4) < 2 then		/*   signed fixed binary.			*/
		     if scale ^= 0 then do;		/*     include scale when nonzero.		*/
			string = string || ",";
			string = string || cv_num (scale);
			end;
		     else;
		else if  (33 <= type & type <= 34)  then/*   unsigned fixed binary.			*/
		     if scale ^= 0 then do;		/*     include scale when nonzero.		*/
			string = string || ",";
			string = string || cv_num (scale);
			end;
		string = string || ")";
		end;
	     end;

	else if  (9 <= type & type <= 12) | 		/* decimal numeric				*/
	         (43 <= type & type <= 46)  then do;
	     string = string || "(";
	     string = string || cv_num(size);		/*   Always include size.  Most people don't know */
						/*     what the default is for decimal data.	*/
	     if mod(type,2) = 1 then			/*   fixed decimal				*/
		if scale ^= 0 then do;		/*     include scale when nonzero.		*/
		     string = string || ",";
		     string = string || cv_num (scale);
		     end;
	     string = string || ")";
	     end;

	else if 19 <= type & type <= 22 then do;
	     string = string || "(";			/* bit or	character	string.			*/
	     if size = 16777215 then			/*   star	extent.				*/
		string = string || "*";
	     else	string = string || cv_num(size);
	     string = string || ")";
	     if mod(type,2)	= 0 then			/*   varying bit or char string.		*/
		string = string || " var";
	     end;

	else if type = 18 then do;			/* area					*/
	     string = string || "(";
	     if size = 16777215 then			/*   star	extent.				*/
		string = string || "*";
	     else	string = string || cv_num(size);
	     string = string || ")";
	     end;

						/* Handle storage alignment.			*/
	if type = 17 then do;			/*   structures or substructures.		*/
	     if Spacked then;			/*     If structure packed, all its elements will	*/
						/*       be marked unaligned.			*/
	     else if all_structure_elements_packed() then /*     If structure unpacked, only mark it aligned*/
		string = string || " aligned";	/*       if all its elements are packed.	*/
	     end;
	
	else do;					/*   scalars, array or structure elements.	*/
	     if level = 1 then do;			/*   scalars:  assume user know default alignment.*/
		if  type = 19 | type = 21  then	/*     Only give alignment if it differs from the */
		     if Spacked then;		/*     default.				*/
		     else string = string || " aligned";
		else if Spacked then
		     string = string || " unal";
		end;
	     else do;				/*     structure elements.			*/
		if ASpacked then			/*       containing structure is packed.	*/
		     string = string || " unal";	/*         its elements are packed by definition. */
		else				/*       containing structure not packed.  	*/
		     if Spacked then		/*   Explicitly state alignment of structure els. */
			string = string || " unal";
		     else string = string || " aligned";
		end;
	     end;

	if type = 17 then do;			/* process the structure elements.		*/
	     do j = 1 to size;			/* structure contains size elements.		*/
		string = string || ", ";
		Pelement_desc = addrel(addr(desc(Aoffset-1)), 1);
						/* Aoffset is offset of next structure element	*/
						/*  descriptor from structure descriptor.	*/
		offset = 0;			/* Number of descriptors used up by structure	*/
						/*   element will be stored in offset by the call.*/
		call recurse (Pelement_desc, level+1, Ndim, (j=size&Slast), Spacked, offset, string, Acode);
		if Acode ^= 0 then return;
		Aoffset = Aoffset + offset;		/* Skip over descriptors for this structure el.	*/
		end;
	     end;
RETURN:	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


cv_num:	proc (n) returns (char(16) varying);

     dcl	n			fixed bin(17),
	n_			fixed bin(35),
	p			pic "---------------9";
	
	p = n;
	go to COMMON;

cv_desc_num_:
	entry (n_) returns (char (16) varying);

	if n_ = star_pl1_size | n_ = star_fort_size	/*   star extent */
	then return ("*");
	else p = n_;
	go to COMMON;


cv_num_:	entry (n_) returns (char(16) varying);

	p = n_;

COMMON:	return (ltrim(p));
	
	end cv_num;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


all_structure_elements_packed:			/* Internal procedure finds out if all elements of*/
	proc returns(bit(1));			/*   a structure are packed.			*/

     dcl	Spacked			bit(1) aligned,
	elem_offset		fixed bin,
	temp_offset		fixed bin;

	elem_offset = Aoffset;			/* Save current offset.			*/
	Spacked = "1"b;				/* Start by assuming all are packed.  Search ends */
	do j = 1 to size while (Spacked);		/*   when first unpacked element is found.	*/
						/* Algorithm in this do loop same as that used	*/
						/*   above for actually emitting elem. dcls.	*/
	     Pelement_desc = addrel(addr(desc(elem_offset-1)),1);
	     temp_offset = 0;
	     call recurse_structure_elements_packed (Pelement_desc, level+1, Ndim, (j=size&Slast),
		Spacked, temp_offset, Acode);
	     if Acode ^= 0 then go to RETURN;
	     elem_offset = elem_offset + temp_offset;
	     end;
	return (Spacked);

	end all_structure_elements_packed;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


recurse_structure_elements_packed:
	entry (Pdesc, level, Nignored_dim, Slast, ASpacked, Aoffset, Acode);

	Acode = 0;				/* decode descriptor for structure element, just	*/
	Aoffset = 1;				/*  as for the $recurse entry point.		*/
	call decode_descriptor_ (Pdesc, 0, type, Spacked, Ndim, size, scale);
	if  (1 <= type & type <= 23) | 
	    (33 <= type & type <= 34) | 
	    (43 <= type & type <= 46) then;
	else do;
	     Acode = error_table_$bad_segment;
	     return;
	     end;

	if ^Spacked then do;			/* If structure element unpacked, we can stop now.*/
	     ASpacked = "0"b;
	     return;
	     end;

	if type = 17 then				/* If structure el is another structure, return	*/
						/*   result of testing its elements.		*/
	     ASpacked = all_structure_elements_packed ();

	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	end get_pl1_parm_desc_string_;




		    interpret_ptr_.pl1              11/05/86  1346.8r w 11/04/86  1041.7      129582



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

interpret_ptr_:
     procedure (a_ptr, a_framep, strp);

/* INTERPRET_PTR_ - find out as much as possible about a pointer.

   This program returns printable information about an input pointer.
   If a stack frame pointer or machine conditions pointer is also supplied,
   the program finds out information about the owner of the given stack frame,
   and remarks that the fault may not have occurred in the frame owner.
*/

/* modified 24 July 1975 by M. Weaver for separate static */
/* Modified 7/76 to prevent a fault while interpreting a bad pointer */
/* Modified March 1980 by C. Hornig to find source line */
/* Changed to use interpret_link_info.incl.pl1 05/12/83 S. Herbst */

dcl a_ptr ptr,					/* ptr to be interpreted (input) */
    a_framep ptr,					/* ptr to associated stack frame, or null (input) */
    strp ptr;					/* ptr to return structure (input) */

dcl bcs char (54) based (in_ptr);
dcl bit_72 bit (72) based;				/* Used to avoid pointer check while copying the argument */

dcl 1 ptrb based aligned,				/* breakdown of a pointer */
      2 xx1 bit (3) unal,
      2 sn bit (15) unal,
      2 rn bit (3) unal,
      2 xxx bit (9) unal,
      2 its bit (6) unal,
      2 yyy bit (36) unal;

dcl 1 condinfo aligned like condition_info;		/* structure returned by find_condition_info_ */
dcl 1 oi aligned like object_info;

dcl 1 situation aligned,
      2 bad_frame bit (1) unal,
      2 exists_ppr bit (1) unal,
      2 ppr_is_owner bit (1) unal,
      2 ppr_is_ops bit (1) unal,
      2 caller_is_owner bit (1) unal,
      2 entry_ptr_invalid bit (1) unal,
      2 ret_ptr_is_ops bit (1) unal,
      2 pad bit (29) unal;

dcl 1 auto_interpret_link_info aligned like interpret_link_info;

dcl xp ptr,					/* ptr to segment name */
    frame_owner_sw bit (1) aligned init ("1"b),
    coptr ptr init (null),
    coflg bit (1) init ("0"b),
    in_ptr ptr,					/* copied arg */
    framep ptr,					/* ptr to stack frame */
    hcsct fixed bin,				/* highest hardcore segment */
    highct fixed bin,				/* highest segment number */
    txtp ptr,					/* ptr into text */
    rings (3) fixed bin (6),				/* used when checking accessibility */
    lev fixed bin,					/* ... validation level */
    mode fixed bin (5),				/* rewa mode of segment */
    type fixed bin (2),				/* dir, seg, link */
    (bc, bc1) fixed bin (24),				/* bitcount */
    bmp ptr,					/* bindmap ptr */
    sblkp ptr,
    namp ptr,					/* component name */
    naml fixed bin,
    based_name char (naml) based (namp),		/* component name (in defs of bound seg) */
    (i, j) fixed bin,				/* temps */
    dirn char (168) aligned,				/* dirname where segment reside */
    ename char (32) aligned,				/* temp entry name */
    pl1_op_name char (32) aligned,			/* operator name */
    segn char (32) aligned,				/* file-system name for seg */
    segno fixed bin (18),
    adjusted_offset fixed bin (18),
    section char (8) aligned,
    lang char (8) aligned,
    op_seg_name char (32) aligned,
    ec fixed bin (35),				/* file-system error code */
    ctmp char (65);

dcl condition_ entry (char (*), entry),
    get_entry_name_ entry (ptr, char (*) aligned, fixed bin (18), char (8) aligned, fixed bin (35)),
    is_condition_frame_ entry (ptr) returns (bit (1)),
    find_condition_info_ entry (ptr, ptr, fixed bin (35)),
    find_nonobject_info_
         entry (ptr, char (*), fixed bin (18) aligned, char (8) aligned, fixed bin (18) aligned, fixed bin (35)),
    stack_frame_exit_ entry (ptr, ptr, ptr, bit (1), ptr, char (32) aligned, ptr),
    find_operator_name_ entry (char (*) aligned, ptr, char (32) aligned),
    cu_$level_get entry (fixed bin),
    hcs_$fs_get_brackets entry (ptr, fixed bin (5), (*) fixed bin (6), fixed bin (35)),
    hcs_$high_low_seg_count entry (fixed bin, fixed bin),
    ring0_get_$name entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35)),
    hcs_$fs_get_path_name entry (ptr, char (*) aligned, fixed bin, char (*) aligned, fixed bin (35)),
    hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)),
    object_info_$display entry (ptr, fixed bin (24), ptr, fixed bin (35)),
    get_bound_seg_info_ entry (ptr, fixed bin (24), ptr, ptr, ptr, fixed bin (35)),
    component_info_$offset entry (ptr, fixed bin (18), ptr, fixed bin (35)),
    interpret_link_ entry (ptr, ptr, fixed bin (35)),
    ioa_$rsnnl entry options (variable);

dcl LEGAL char (96) int static init			/* Printables except PAD, but with BS */
         (" !""#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~");

dcl (addr, baseno, baseptr, ptr, fixed, null, addrel, rel, substr, binary, bit, verify) builtin;

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

	frame_owner_sw = "0"b;
	go to start;

frame_owner:
     entry (a_ptr, a_framep, strp);

start:
	if strp = null then return;			/* initialization. check args */
	addr (in_ptr) -> bit_72 = addr (a_ptr) -> bit_72; /* copy arg without pointer check */
	call condition_ ("any_other", oop);
	framep = a_framep;				/* .. and copy args */
	mcp, scup = null;				/* assume no machine cond */
	if framep ^= null
	then					/* see if condition frame */
	     if frame_owner_sw
	     then					/* un-necessary (& may be harmful) in some cases */
		if is_condition_frame_ (framep) then do;
		     call find_condition_info_ (framep, addr (condinfo), ec);
		     if ec = 0 then do;
			mcp = condinfo.mc_ptr;
			in_ptr = condinfo.user_loc_ptr;
			coptr = condinfo.wc_ptr;
			coflg = condinfo.flags.crawlout;
			scup = addr (mc.scu);	/* Fix ptr to suit Clancy */
			end;
		     end;
	struc.comment, struc.segment, struc.entryn, struc.offset, struc.opname, struc.modifier = "";
	struc.instruction_counter = fixed (rel (in_ptr)); /* initialize return values */
	struc.compiler = "";
	struc.ring = "";
	struc.std_flag = "0"b;
	struc.xpad = "0"b;
	struc.symbolp = null;
	struc.text_ptr = in_ptr;
	struc.stack_ptr = framep;
	struc.sourcemap = 0;
	call hcs_$high_low_seg_count (highct, hcsct);	/* find range of good segnos */
	ename = "";
	call ioa_$rsnnl ("^o", struc.offset, i, struc.instruction_counter);
	j = fixed (baseno (in_ptr), 17);		/* if can't get segname. what is segno? */
	call ioa_$rsnnl ("#^o", segn, i, j);		/* unknown segment. put number */
	struc.segment = segn;

/* Try to take care of some special cases first. */

	xp = addr (in_ptr);				/* null ptr is special cased */
	if xp -> ptrb.sn = (15)"1"b then do;
	     struc.segment = "null pointer";
	     return;
	     end;

	if xp -> ptrb.its = "100110"b then do;		/* unsnapped link */

	     auto_interpret_link_info.version = INTERPRET_LINK_INFO_VERSION_1;

	     call interpret_link_ (addr (auto_interpret_link_info), in_ptr, ec);
						/* if ft2, ask spier */
	     if ec = 0 then do;			/* good. we can say */
		struc.entryn = auto_interpret_link_info.entry_point_name;
		struc.segment = auto_interpret_link_info.segment_name;
		struc.offset = auto_interpret_link_info.expression;
		struc.modifier = auto_interpret_link_info.modifier;
		end;
	     else struc.segment = "unsnapped link";	/* happens if not in linkage section */
glop:
	     struc.text_ptr = null;			/* save everybody else a lot of trouble */
glop1:
	     return;
	     end;
	if xp -> ptrb.its ^= "100011"b then go to glop;	/* not fool with non-ptr */

	struc.ring = substr ("01234567", fixed (xp -> ptrb.rn, 3), 1);
	if binary (baseno (in_ptr)) <= hcsct then do;	/* Hardcore segment? */
	     call ring0_get_$name (dirn, segn, in_ptr, ec);
						/* yes. obtain name */
	     if ec = 0 then do;
		struc.segment = segn;		/* oho. */
		struc.ring = "0";
		call check_access (in_ptr, bc, ec);
		if ec = 5 then go to nonobj;
		if ec ^= 0 then go to glop;
		end;
	     end;

/* Special cases are taken care of. In normal case, we examine stack frame to get procedure name. */

	txtp = in_ptr;				/* Assume return ptr is good, for the moment */
	call hcs_$fs_get_path_name (txtp, dirn, j, segn, ec);
						/* who is he */
	if ec = 0 then struc.segment = segn;
	if frame_owner_sw
	then if framep ^= null then do;		/* Check stack frame. */
		call stack_frame_exit_ (framep, mcp, coptr, coflg, txtp, op_seg_name, addr (situation));
		if situation.bad_frame then return;
		end;
	call check_access (txtp, bc, ec);
	if ec = 1 then go to glop;
	if ec ^= 0 then go to nonobj;

	if mcp ^= null then do;			/* if no machine cond, stymied */
	     call find_operator_name_ (op_seg_name, txtp, pl1_op_name);
	     if pl1_op_name ^= ""
	     then					/* If we were in an operator, */
		struc.opname = "in operator " || pl1_op_name;
	     end;

	call hcs_$fs_get_path_name (txtp, dirn, j, segn, ec);
						/* who is he */
	struc.segment = segn;
	call get_entry_name_ (txtp, ename, segno, lang, ec);
	if ec ^= 0
	then if framep ^= null then call get_entry_name_ (framep -> stack_frame.entry_ptr, ename, segno, lang, ec);
	if ec = 0 then struc.entryn = "$" || ename;
	struc.instruction_counter = fixed (rel (txtp));
	struc.text_ptr = txtp;
	call ioa_$rsnnl ("^o", struc.offset, j, struc.instruction_counter);
	oi.version_number = object_info_version_2;
	call object_info_$display (ptr (txtp, 0), bc, addr (oi), ec);
	if ec ^= 0 then go to nonobj;			/* if not object seg, jump down */
	struc.compiler = oi.compiler;			/* was object seg. get info on it */
	struc.std_flag = ^oi.format.old_format;
	struc.symbolp = oi.symbp;			/* save ptr to beg of symbol section */
	struc.sourcemap = oi.source_map;		/* save source map if given */
	if oi.format.bound then do;			/* is this a bound segment? */
	     call component_info_$offset (ptr (txtp, 0), binary (rel (txtp)), addr (ci), ec);
	     if ec = 0 then do;			/* bound segment. */
		struc.compiler = ci.compiler;		/* we have better info now. */
		struc.std_flag = ci.standard;
		struc.symbolp = ci.symb_start;
		struc.sourcemap = ci.source_map;
		call ioa_$rsnnl ("(^a|^a)", struc.comment, ec, segn, struc.offset);
		struc.segment = ci.name;
		struc.instruction_counter = binary (rel (txtp)) - binary (rel (ci.text_start));
		call ioa_$rsnnl ("^o", struc.offset, j, struc.instruction_counter);
		end;
	     end;
	goto xtarget;

/* If ptr is to combined linkage segment, see if we can get any info from the LOT. Or  be v1 entry */

nonobj:						/* see if location is described by def */
	call find_nonobject_info_ (in_ptr, ctmp, segno, section, adjusted_offset, ec);
	if section = "text" then do;			/* text assumed if not in combined linkage segment */
	     if ctmp = "" then go to xtarget;		/* have no further name info */
	     if segn = ""
	     then struc.entryn = ctmp;
	     else struc.entryn = "$" || ctmp;
	     struc.comment = "(external symbol in separate nonstandard text section)";
	     go to done;
	     end;

/* in_ptr points to static or linkage */
	call hcs_$fs_get_path_name (baseptr (segno), dirn, i, segn, ec);
	if ec ^= 0 then go to xtarget;
	call ioa_$rsnnl ("(^a|^o for ^a)", struc.comment, i, section, adjusted_offset, segn);
	call hcs_$status_mins (baseptr (segno), type, bc1, ec);
	if ec = 0 then do;
	     call get_bound_seg_info_ (baseptr (segno), bc1, addr (oi), bmp, sblkp, ec);
	     if ec = 0 then do;
		do j = 1 to n_components
		     while (adjusted_offset > fixed (component (j).stat_start) + fixed (component (j).stat_lng));
		end;
		if j <= n_components then do;
		     namp = addrel (sblkp, component (j).name_ptr);
		     naml = fixed (component (j).name_lng);
		     call ioa_$rsnnl ("(internal static|^o for ^a)", struc.comment, i,
			adjusted_offset - fixed (component (j).stat_start), based_name);
		     end;
		end;
	     end;
	if ctmp ^= "" then do;
	     struc.entryn = "$" || ctmp;
	     if section = "linkage" then struc.comment = "(entry sequence)";
	     end;

/* If we cannot say anything else, tell what the pointer points at, if it's ascii. */

xtarget:
	if struc.comment = "" then do;
	     i = verify (bcs, LEGAL);			/* Scan to see how much is ascii. */
	     if i = 0 then i = 54;			/* If all legal. */
	     if i > 4 then struc.comment = "( -> """ || substr (bcs, 1, i - 1) || """)";
	     end;
done:
	return;

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

check_access:
     proc (txtp, bc, code);

dcl txtp ptr,
    bc fixed bin (24),
    code fixed bin (35);

dcl ec fixed bin (35);

	code = 0;
	if binary (baseno (txtp)) > hcsct + highct then do;
						/* dump out if segment invalid */
	     code = 1;
	     return;
	     end;
	call hcs_$status_mins (txtp, type, bc, ec);	/* check for directory, get length in bits */
	if ec ^= 0 then go to ng;			/* how can this happen? */
	if type ^= 1 then do;			/* ignore directories */
ng:
	     code = 4;
	     return;
	     end;
	call cu_$level_get (lev);			/* check ring brackets */
	call hcs_$fs_get_brackets (txtp, mode, rings, ec);
	if ec ^= 0 then go to ng;			/* if cannot status segment */
	if rings (2) < lev then do;			/* outside read bracket? */
	     code = 2;
	     return;
	     end;
	if (bit (mode, 5) & "01000"b) ^= "01000"b then do;/* check for read access */
	     struc.text_ptr = null;
	     code = 3;
	     return;
	     end;
	if bc = 0 then code = 5;			/* if bit count zero, is not object seg. */

     end check_access;

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

oop:
     proc (mcp, cname, cop, infop, cont);

dcl (mcp, cop, infop) ptr,
    cname char (*),
    cont bit (1);

	if cname = "cput" then go to xx;
	if cname = "alrm" then go to xx;
	if cname = "quit" then go to xx;
	if cname = "finish" then go to xx;
	if cname = "stack" then go to xx;
	if cname = "mme2" then go to xx;
	if cname = "program_interrupt" then do;
xx:
	     cont = "1"b;
	     return;
	     end;

	if cname ^= "cleanup" then go to glop1;

     end oop;

/* * * * * * * * * * * * * * * * * * * */

%include condition_info;
%include interpret_link_info;
%include interpret_ptr_struc;
%include component_info;
%include bind_map;
%include object_info;
%include stack_frame;
%include mc;

     end interpret_ptr_;




		    list_frame_args_.pl1            10/24/88  1649.2r w 10/24/88  1400.1      117441



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





/****^  HISTORY COMMENTS:
  1) change(86-09-08,DGHowe), approve(86-09-08,MCR7524),
     audit(86-09-16,Ginter), install(86-09-24,MR12.0-1158):
     check for command_name_arglist mbz and pad1 = "0"b and print out the
     command name if it is available.
                                                   END HISTORY COMMENTS */


/* format: style3,^indnoniterdo */
list_frame_args_:
     proc (framep, ss);

/* This program is an adaptation of Steve Webber's list_arg_ routine from db,
   for use by trace_stack_. */
/* rewritten 8/10/81 by Melanie Weaver to use arithmetic_to_ascii_ */
/* Changed to print "(no type information)" if Pascal & if no descriptors 10/18/83 S. Herbst */
/* Modified Aug 7, 1986 by Doug Zwick to fix bug introduced by the command
   processor argument changes installed for C (MCR 7375).  Add functionality
   to display the command name field if supplied in the arg list, and to
   display the value of the argument list pointer.  Also changed to use
   arg_list.incl.pl1 so that peruse_crossref will show this module as using
   the argument list.  */

dcl	framep		ptr,
	ss		char (32) aligned;

dcl	(addr, addrel, hbound, lbound, min, null, substr, fixed, bin, max, verify, unspec)
			builtin;

dcl	argp		ptr;
dcl	ss_ptr		ptr;
dcl	ap		ptr;			/* ptr to arglist. */
dcl	strp		ptr;
dcl	tp		ptr;
dcl	xdesc		(64) ptr;

dcl	(i, j, k)		fixed bin;
dcl	(min_arg, max_arg, type, xtype)
			fixed bin;
dcl	(no_args, no_desc, strl, ndims, scale)
			fixed bin;
dcl	(xstrl, xndims, xscale, xnargs)
			fixed bin;
dcl	ec		fixed bin (35);

dcl	c75		char (75) aligned;
dcl	(ttype, xttype)	char (24);
dcl	ascii_representation
			char (132) varying;

dcl	(packed, xpacked)	bit (1) aligned;
dcl	begin_block_entries (2) bit (36) aligned internal static options (constant)
			init ("000614272100"b3 /* tsp2 pr0|614 */, "001376272100"b3 /* tsp2 pr0|1376 */);

dcl	1 its_ptr		aligned like its;

dcl	condition_	entry (char (*), entry);
dcl	get_entry_arg_descs_
			entry (ptr, fixed bin, (*) ptr, fixed bin (35));
dcl	decode_descriptor_	entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin);
dcl	interpret_ptr_	entry (ptr, ptr, ptr);
dcl	ioa_$ioa_stream	entry options (variable);
dcl	ioa_$ioa_stream_nnl entry options (variable);
dcl	ioa_$rsnnl	entry options (variable);
dcl	arithmetic_to_ascii_
			entry (ptr, fixed bin, bit (1) aligned, fixed bin, fixed bin, char (132) varying);
dcl	iox_$look_iocb	entry (char (*), ptr, fixed bin (35));
dcl	display_file_value_ entry (ptr, file, fixed bin (35));

dcl	itsptr		ptr based aligned;
dcl	packptr		ptr based unaligned;
dcl	fword		(4) fixed bin (35) based (argp);
dcl	bcs		char (100) based (argp);
dcl	char_string	char (strl) based (argp);
dcl	based_bit		bit (36) aligned based;
dcl	bit_string	bit (strl) based (argp);
dcl	based_file	file based;


dcl	1 label_variable	based (argp) aligned,
	  2 ptr		ptr,
	  2 stack		ptr;

dcl	1 arglist		aligned like command_name_arglist based (ap);


dcl	LEGAL		char (96) int static
			init
			/* Printables except PAD, but with BS */ (
			" !""#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~"
			);

/* ====================================================================== */

	sp = framep;				/* Copy argument. */
	unspec (ap), unspec (its_ptr) = unspec (stack_frame.arg_ptr);
						/* Extract argument ptr. */
	if its_ptr.its_mod ^= ITS_MODIFIER		/* use valid pl1 code */
	then go to badap;
	if ap = null
	then do;
badap:
	     if addr (sp -> stack_frame.entry_ptr) -> its.its_mod = ITS_MODIFIER
	     then if sp -> stack_frame.entry_ptr ^= null
		then do j = 1 to hbound (begin_block_entries, 1);
			if addrel (sp -> stack_frame.entry_ptr, 1) -> based_bit = begin_block_entries (j)
			then do;
			     call ioa_$ioa_stream (ss, "^-Begin block; no arguments.");
			     return;
			end;
		     end;
	     call ioa_$ioa_stream (ss, "^-Bad argument pointer.");
	     return;
	end;
	strp = addr (strbuf);
	no_args = fixed (arglist.arg_count);		/* get the number of arguments */
	no_desc = fixed (arglist.desc_count);		/* and the number of descriptors */
	if arglist.mbz ^= "0"b
	then go to badah;
	if arglist.call_type ^= 4
	then if arglist.call_type ^= 8
	     then go to badah;
	if no_desc ^= 0
	then if no_desc ^= no_args
	     then do;
badah:
		call ioa_$ioa_stream (ss, "^-Argument list header invalid.");
		return;
	     end;

	call ioa_$ioa_stream (ss, "  Argument list pointer: ^p", ap);


/*	The command processor will fill in the command name field with
	the name by which the command was invoked.  Its there so we
	might as well display it.  */

	if arglist.has_command_name then
	     call ioa_$ioa_stream (ss, "^-Command name: ^a",
		substr (arglist.command_name_ptr -> char_string, 1,
			arglist.command_name_length));


	call get_entry_arg_descs_ (stack_frame.entry_ptr, xnargs, xdesc, ec);

	if xnargs > 0
	then /* Many programs like commands fetch args thru cu_ */
	     if xnargs ^= no_args
	     then /* .. and so we special-case that. */
		call ioa_$ioa_stream (ss, "^-Warning: ^d arguments expected, ^d supplied.", xnargs, no_args);
	if no_args = 0
	then do;					/* check for no arguments */
	     call ioa_$ioa_stream (ss, "^-No arguments.");
	     return;
	end;
	if no_args > 64
	then do;
	     call ioa_$ioa_stream (ss, "^-Only first 64 args of ^d will be listed.", no_args);
	     no_args = 64;
	     if xnargs > 64
	     then xnargs = 64;
	     if no_desc ^= 0
	     then no_desc = 64;
	end;
	min_arg = 1;				/* print out all arguments */
	max_arg = no_args;

	call condition_ ("any_other", intproc);

	do j = min_arg to max_arg;			/* loop through the desired number of args */
	     argp = arglist.arg_ptrs (j);		/* get pointer to the argument */
	     if no_desc ^= 0
	     then do;				/* if we have descriptors, look at them */
		call decode_descriptor_ (ap, j, type, packed, ndims, strl, scale);
		if xnargs >= j
		then /* Does procedure expect arguments? */
		     if xdesc (j) ^= null
		     then do;			/* Yes. Do we know what this arg shd be? */
			call decode_descriptor_ (xdesc (j), 0, xtype, xpacked, xndims, xstrl, xscale);
			if xtype ^= type
			then do;
			     if type >= lbound (data_type_info_$info, 1) & type <= hbound (data_type_info_$info, 1)
			     then ttype = substr(type_name (type),1,24);
			     else call ioa_$rsnnl ("type ^d", ttype, k, type);
			     if xtype >= lbound (data_type_info_$info, 1)
				& xtype <= hbound (data_type_info_$info, 1)
			     then xttype = substr(type_name (xtype),1,24);
			     else call ioa_$rsnnl ("type ^d", xttype, k, xtype);
			     call ioa_$ioa_stream (ss, "^-Warning: arg ^d type mismatch: ^a supplied, ^a expected.",
				j, ttype, xttype);
			end;
			if xpacked ^= packed	/* Check that packed attributes match */
			then call ioa_$ioa_stream (ss,
				"^-Warning: arg ^d packed mismatch: ^d supplied, ^d expected.", j,
				bin (packed, 35), bin (xpacked, 35));
			if xndims ^= ndims
			then call ioa_$ioa_stream (ss,
				"^-Warning: arg ^d ndims mismatch: ^d supplied, ^d expected.", j, ndims, xndims);
			if xstrl ^= strl
			then if xtype < pointer_dtype
			     then call ioa_$ioa_stream (ss,
				     "^-Warning: arg ^d precision mismatch: ^d supplied, ^d expected.", j, strl,
				     xstrl);
			     else if xstrl ^= 16777215
			     then /* No fuss abt char (*) */
				call ioa_$ioa_stream (ss,
				     "^-Warning: arg ^d length mismatch: ^d supplied, ^d expected.", j, strl,
				     xstrl);
			if xscale ^= scale
			then call ioa_$ioa_stream (ss,
				"^-Warning: arg ^d scale mismatch: ^d supplied, ^d expected.", j, scale, xscale);
		     end;
	     end;
	     else if xnargs >= j
	     then do;				/* Callee might have descriptors for args. */
		if xdesc (j) = null
		then go to guess;			/* .. and then again he might not. */
		call decode_descriptor_ (xdesc (j), 0, type, packed, ndims, strl, scale);
	     end;
	     else if stack_frame.translator_id = "000010"b3 then type = -1;   /* Pascal frame */
	     else do;				/* try to find out what type by heuristics */
guess:
		packed = "0"b;
		scale = 0;
		ndims = 0;
		if argp -> its.its_mod = ITS_MODIFIER
		then type = pointer_dtype;		/* assume pointer */
		else do;
		     strl = verify (bcs, LEGAL) - 1;	/* Scan for last legal char in string. */
		     if strl < 0
		     then strl = 100;		/* If all legal, print first 100. */
		     if strl >= 2
		     then type = char_dtype;
		     else type = -1;		/* full word octal */
		end;
	     end;

	     if type = -1
	     then do;
		call ioa_$ioa_stream (ss, "^-ARG ^2d: ^w (no type information)", j, fword (1));
						/* no descriptor; print full word octal */
		go to skiparg;
	     end;

	     else if type < lbound (data_type_info_$info, 1) | type > hbound (data_type_info_$info, 1)
	     then call ioa_$ioa_stream (ss, "^-ARG ^2d: (bad type ^d at ^p) ^w", j, type, argp, fword (1));

	     else if data_type_info_$info (type).arithmetic
	     then do;
		call arithmetic_to_ascii_ (argp, type, packed, strl, scale, ascii_representation);
		call ioa_$ioa_stream (ss, "^-ARG ^2d: ^a", j, ascii_representation);
	     end;

	     else if type = pointer_dtype
	     then do;				/* Pointer */
		if packed
		then do;				/* packed ptr */
		     tp = argp -> packptr;
		     go to pptr;
		end;
		if argp -> its.its_mod = ITS_MODIFIER
		then do;
		     tp = argp -> itsptr;
pptr:
		     call interpret_ptr_ (tp, null, strp);
		     call ioa_$ioa_stream (ss, "^-ARG ^2d: ^p ^a^a|^a ^a", j, tp, struc.segment, struc.entryn,
			struc.offset, struc.comment);
		end;
		else call ioa_$ioa_stream (ss, "^-ARG ^2d: ^w  ^w", j, fword (1), fword (2));
	     end;

	     else if type = offset_dtype		/* Offset */
	     then call ioa_$ioa_stream (ss, "^-ARG ^2d: ^w", j, fword (1));

	     else if type = label_dtype | type = entry_dtype
						/* Label, Entry */
	     then do;
		call interpret_ptr_ (argp -> label_variable.ptr, argp -> label_variable.stack, strp);
		call ioa_$ioa_stream (ss, "^-ARG ^2d: ^p, ^p ^a^a|^a ^a", j, label_variable.ptr, label_variable.stack,
		     struc.segment, struc.entryn, struc.offset, struc.comment);
	     end;

	     else if type = bit_dtype | type = varying_bit_dtype
						/* Bit string */
	     then do;
		if type = varying_bit_dtype
		then strl = addrel (argp, -1) -> fword (1);
		c75 = """";			/* initial quote */
		k = 0;				/* count 1-bits */
		do i = 1 to min (strl, 72);
		     if substr (bit_string, i, 1)
		     then do;
			k = k + 1;
			substr (c75, i + 1, 1) = "1";
		     end;
		     else substr (c75, i + 1, 1) = "0";
		end;
		substr (c75, i + 1, 2) = """b";
		if (strl <= 72 & strl > 1)
		then /* Maybe compress representation */
		     if k = 0
		     then call ioa_$rsnnl ("(^d)""0""b", c75, k, strl);
		     else if k = strl
		     then call ioa_$rsnnl ("(^d)""1""b", c75, k, strl);
		call ioa_$ioa_stream (ss, "^-ARG ^2d: ^a", j, c75);
	     end;

	     else if type = char_dtype | type = varying_char_dtype
						/* Character string */
	     then do;
		if type = varying_char_dtype
		then strl = min (80, max (addrel (argp, -1) -> fword (1), 0));
		call ioa_$ioa_stream (ss, "^-ARG ^2d: ""^va""", j, strl, char_string);
	     end;

	     else if type = file_dtype		/* File */
	     then do;
		call ioa_$ioa_stream_nnl (ss, "^-ARG ^2d: ", j);
		call iox_$look_iocb ((ss), ss_ptr, ec);
		if ec = 0
		then call display_file_value_ (ss_ptr, argp -> based_file, ec);
		if ec ^= 0
		then call ioa_$ioa_stream (ss, "(file at ^p)", argp);
	     end;

	     else call ioa_$ioa_stream (ss, "^-ARG ^2d: (^a at ^p) ^w", j, type_name (type), argp, fword (1));

	     if ndims > 0
	     then call ioa_$ioa_stream (ss, "^-^-(^d-dim array)", ndims);

skiparg:
	end;

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

intproc:
     proc (mcp, cname, cop, infop, cont);
dcl	(mcp, cop, infop)	ptr,
	cname		char (*),
	cont		bit (1);

/* format: ^delnl */
	if cname = "program_interrupt"
	     | cname = "finish"
	     | cname = "quit"
	then do;
	     cont = "1"b;
	     return;
	end;
						/* format: revert */
	if cname = "cleanup"
	then return;

	if infop ^= null
	then if infop -> condition_info_header.action_flags.quiet_restart
	     then return;

	call ioa_$ioa_stream (ss, "^-ARG ^2d not accessible. - ^a", j, cname);
	go to skiparg;
     end;

%include stack_frame;

%include arg_list;

%include interpret_ptr_struc;

%include its;

%include data_type_info_;

%include condition_info_header;

%include std_descriptor_types;

%include probe_data_type_names;


     end list_frame_args_;




		    list_onunits_.pl1               11/05/86  1346.8r w 11/04/86  1041.7       28170



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


list_onunits_: proc (a_sp, stream);

/* LIST_ONUNITS_ - list enabled condition handlers in a frame.

   This program is called by trace_stack_

   */

dcl  a_sp ptr,					/* stack frame pointer */
     stream char (32) aligned;			/* output stream */

dcl  tp ptr,					/* working ptr */
     strp ptr,
     bchr char (32) unal based (tp),
     condid char (66) aligned,
     junk fixed bin,
     snapw char (4) aligned,
     on_unit_ptr ptr,
     on_unit_rel bit (18) aligned;

dcl 1 filevar based aligned,
    2 fabp ptr,
    2 fsbp ptr;

dcl 1 fab based aligned,				/* File attributes block. */
    2 switch bit (36),
    2 filename char (32);

dcl  interpret_ptr_ entry (ptr, ptr, ptr),
     ioa_$rsnnl entry options (variable),
     ioa_$ioa_stream entry options (variable);

dcl  n_io_conds fixed bin int static init (7);		/* Number of conditions which have file name. */
dcl  io_cond (7) char (16) aligned int static init
    ("endfile",
     "endpage",
     "name",
     "record",
     "transmit",
     "undefinedfile",
     "key");

%include on_unit;
%include stack_frame;

%include interpret_ptr_struc;

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

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

	sp = a_sp;				/* copy arg */
	if ^stack_frame_flags.condition then return;	/* check bit 29 of last-sp */
	strp = addr (strbuf);
	on_unit_rel = stack_frame.on_unit_relp1;	/* got on-units, so follow chain */
onloop:	if on_unit_rel = "0"b then return;		/* "0"b means end of chain */
	on_unit_ptr = addrel (sp, on_unit_rel);		/* these things are relative to sp */
	if on_unit_ptr -> on_unit.flags.pl1_snap then snapw = "snap"; else snapw = "";
	if on_unit_ptr -> on_unit.size ^= 0 then do;
	     tp = on_unit_ptr -> on_unit.name;		/* get ptr to name */
	     condid = substr (bchr, 1, on_unit_ptr -> on_unit.size);
	     do junk = 1 to n_io_conds while (condid ^= io_cond (junk)); end;
	     if junk <= n_io_conds then		/* This unit has associated filename. */
		call ioa_$rsnnl ("^a(^a)", condid, junk, substr (bchr, 1, on_unit_ptr -> on_unit.size),
		on_unit_ptr -> on_unit.file -> filevar.fabp -> fab.filename);
	     if on_unit_ptr -> on_unit.flags.pl1_system then do;
		call ioa_$ioa_stream (stream, "^-on ""^a"" ^a system;", condid, snapw);
	     end;
	     else do;
		call interpret_ptr_ (on_unit_ptr -> on_unit.body, null, strp);
		call ioa_$ioa_stream (stream, "^-on ""^a"" ^a call ^a^a|^a ^a", condid,
		     snapw, struc.segment, struc.entryn, struc.offset, struc.comment);
	     end;
	end;
	on_unit_rel = on_unit_ptr -> on_unit.next;	/* following chain */
	go to onloop;

     end list_onunits_;




		    print_source_line_.pl1          10/03/83  1732.6rew 10/03/83  1009.5       75114



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

print_source_line_:
     proc (strp, stream);

/* PRINT_SOURCE_LINE_ - attempt to print out the source line for a given location.

   This is a subroutine of trace_stack_.
   Its input data has been set up by interpret_ptr_.

   THVV */
/* Modified 7/76 by S.E. Barr to delete printing of version I operator names and to recognize "PL/I" compiler name */
/* Changed to use interpret_link_info.incl.pl1 05/12/83 S. Herbst */

dcl strp ptr,
    stream char (32) aligned;

dcl sp ptr,					/* ptr to stack frame */
    fptr ptr,					/* ptr to faulting instruction */
    btc fixed bin (24),
    cip ptr,
    callp ptr,
    entry_ptr ptr,
    link_ptr ptr,
    lang char (8) aligned,
    op_seg_name char (32) aligned,
    segno fixed bin (18),
    component char (32) aligned,
    sn char (32) aligned,
    i fixed bin,
    insx fixed bin init (1),
    working_dir_name char (168) aligned,		/* name of current wdir, for look for source */
    pl1_operator_name char (32) aligned,		/* if faulting instr was pl1 op, what? */
    line_no char (16),				/* line number of source (from symbol table) */
    dirname char (168),
    ename char (32),
    ec fixed bin (35),				/* system errcode */
    disassembled_instr char (72) var;			/* faulting instruction */

dcl source_ptr ptr;
dcl source_seg char (1000000) aligned based (source_ptr);
dcl (line_offset, line_length) fixed bin (21);

dcl component_info_$offset entry (ptr, fixed bin, ptr, fixed bin (35)),
    is_condition_frame_ entry (ptr) returns (bit (1)),
    find_condition_info_ entry (ptr, ptr, fixed bin (35)),
    stack_frame_exit_ entry (ptr, ptr, ptr, bit (1), ptr, char (32) aligned, ptr),
    find_operator_name_ entry (char (*) aligned, ptr, char (32) aligned),
    get_link_ptr_ entry (ptr, ptr, ptr),
    get_entry_name_ entry (ptr, char (*) aligned, fixed bin (18), char (8) aligned, fixed bin (35)),
    interpret_link_ entry (ptr, ptr, fixed bin (35)),
    disassemble entry (ptr, char (*) var, fixed bin),
    find_source_line_ entry (ptr, char (*), char (*), char (*), fixed bin (21), fixed bin (21), fixed bin (35)),
    hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
    hcs_$terminate_noname entry (ptr, fixed bin (35)),
    hcs_$fs_get_brackets entry (ptr, fixed bin (5), (3) fixed bin (6), fixed bin (35)),
    hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)),
    hcs_$high_low_seg_count entry (fixed bin, fixed bin),
    hcs_$fs_get_path_name entry (ptr, char (*) aligned, fixed bin, char (*) aligned, fixed bin (35)),
    ioa_$ioa_stream entry options (variable);

dcl (addr, ptr, fixed, null, substr, binary, baseno, baseptr, bit, rel) builtin;

dcl 1 situation aligned,
      2 bad_frame bit (1) unal,
      2 exists_ppr bit (1) unal,
      2 ppr_is_owner bit (1) unal,
      2 ppr_is_ops bit (1) unal,
      2 caller_is_owner bit (1) unal,
      2 entry_ptr_invalid bit (1) unal,
      2 ret_ptr_is_ops bit (1) unal,
      2 pad bit (29) unal;

dcl 1 condinfo aligned,				/* return struc from find_condition_info_ */
      2 mcptr ptr init (null),
      2 version fixed bin,
      2 condition_name char (32) var,
      2 infoptr ptr init (null),
      2 wcptr ptr init (null),
      2 loc_ptr ptr init (null),
      2 flags,
        3 crawlout bit (1) unal init ("0"b),
        3 pad1 bit (35) unal,
      2 user_loc_ptr ptr init (null),
      2 pad (4) bit (36);

%include interpret_ptr_struc;
%include interpret_link_info;

dcl 1 auto_interpret_link_info aligned like interpret_link_info;

%include component_info;

/* ======================================================= */

	sp = struc.stack_ptr;			/* Copy stack ptr from structure */
	fptr = struc.text_ptr;			/* ... instruction ptr too. */
	if is_condition_frame_ (sp) then do;		/* may need machine cond. */
	     cip = addr (condinfo);
	     call find_condition_info_ (sp, cip, ec);
	     end;
	call stack_frame_exit_ (sp, condinfo.mcptr, condinfo.wcptr, condinfo.crawlout, callp, op_seg_name,
	     addr (situation));
	if situation.bad_frame then return;

	call find_source_line_ (strp, line_no, dirname, ename, line_offset, line_length, ec);
	if line_no = "" then do;
	     call ioa_$ioa_stream (stream, "  Cannot get line number in ^a", struc.segment);
	     end;
	else do;
	     call hcs_$initiate (dirname, ename, "", 0, 1, source_ptr, ec);
	     if source_ptr = null ()
	     then call ioa_$ioa_stream (stream, "  ^a ^a: source not found", ename, line_no);
	     else call ioa_$ioa_stream (stream, "  ^a ^a: ^a", ename, line_no,
		     substr (source_seg, 1 + line_offset, line_length));
	     call hcs_$terminate_noname (source_ptr, ec);
	     end;

	if fptr = null then return;			/* can't print anything if you won't tell me where */
	pl1_operator_name = "";
	if op_seg_name = ""
	then if struc.compiler = "v2pl1" | struc.compiler = "PL/I" | struc.compiler = "alm"
	     then op_seg_name = "pl1_operators_";
	     else if struc.compiler = "pl1" | struc.compiler = "" then op_seg_name = "pl1_operators";

	if ^get_access (callp, btc)
	then pl1_operator_name = "not accessible";
	else call find_operator_name_ (op_seg_name, callp, pl1_operator_name);

	if pl1_operator_name = "alm_call" | substr (pl1_operator_name, 1, 4) = "call" then do;
	     call get_link_ptr_ (callp, link_ptr, entry_ptr);
						/* Who was he trying to call? */
	     if link_ptr ^= null then do;

		auto_interpret_link_info.version = INTERPRET_LINK_INFO_VERSION_1;
		call interpret_link_ (addr (auto_interpret_link_info), link_ptr, ec);
						/* Take link ptr if available. */
		if ec = 0 then do;
		     call ioa_$ioa_stream (stream, "  ^a to ^a^a", pl1_operator_name,
			auto_interpret_link_info.segment_name, auto_interpret_link_info.entry_point_name);
		     return;
		     end;
		end;
	     if entry_ptr ^= null then do;

/* Have found a snapped link. */

		call get_entry_name_ (entry_ptr, sn, segno, lang, ec);
						/* This shd point to entry sequence. */
		if ec = 0 then do;
		     call hcs_$fs_get_path_name (baseptr (segno), working_dir_name, i, component, ec);
		     if ec = 0 then do;
			if segno = fixed (baseno (fptr)) then do;
			     call component_info_$offset (ptr (entry_ptr, 0), binary (rel (entry_ptr)), addr (ci),
				ec);
			     if ec = 0 then component = ci.name;
			     end;
			call ioa_$ioa_stream (stream, "  ^a to ^a$^a", pl1_operator_name, component, sn);
			return;
			end;
		     end;
		end;
	     end;

/* Print instruction if no other information is available */

	call disassemble (fptr, disassembled_instr, insx);
	call ioa_$ioa_stream (stream, "^a ^a", disassembled_instr, pl1_operator_name);
	if insx > 1
	then do i = 2 to insx;
		call disassemble (fptr, disassembled_instr, i);
		call ioa_$ioa_stream (stream, "^a", disassembled_instr);
	     end;

/* This function tests the user's access to the object segment to prevent taking a fault while
   attempting to provide information.  It checks for read access, correct ring brackets, a positive
   bit count and a plausible segment number.
*/

get_access:
     proc (txtp, bc) returns (bit (1) unal);

dcl txtp ptr,
    bc fixed bin (24),
    code fixed bin (35);

dcl rings (3) fixed bin (6);
dcl type fixed bin (2);
dcl mode fixed bin (5);
dcl lev fixed bin (6);
dcl (hcsct, highct) fixed bin;

dcl cu_$level_get entry (fixed bin (6));

	call hcs_$high_low_seg_count (highct, hcsct);
	if binary (baseno (txtp)) <= hcsct + highct then do;
	     call hcs_$status_mins (txtp, type, bc, code);
	     if code = 0 & type = 1 then do;		/* 1 = segment  (ignore directories) */
		call cu_$level_get (lev);
		call hcs_$fs_get_brackets (txtp, mode, rings, code);
		if code = 0 & rings (2) >= lev then do;
		     if (bit (mode, 5) & "01000"b) = "01000"b
		     then if bc > 0 then return ("1"b);
		     end;
		end;
	     end;

	return ("0"b);

     end get_access;

     end print_source_line_;




		    prtscu_.pl1                     10/03/83  1732.6rew 10/03/83  1009.6      114282



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


prtscu_: proc;
	return;					/* should never enter here */

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

dcl  a_iocbp ptr;					/* output switch (iox_$user_output is default) */
dcl  scup ptr;					/* pointer to SCU Data */
dcl  a_offset fixed bin;				/*  relative offset of SCU data */
dcl  lg_sw bit (1);					/* long format switch "1"b => long */
dcl  odsp ptr;					/* ptr to ol_dump structure (defined in ol_dump_struc.incl.pl1) */
% include interpret_ptr_struc;
dcl (strp, byptr, refptr) ptr;
dcl (lnpos, flt_lng, inst6, i, j, reoffset) fixed bin;
dcl  code fixed bin (35);
dcl  w (0 : 7) fixed bin based;
dcl  flt_ln char (100);
dcl  flt_bf char (24) varying;
dcl  iocbp ptr;
dcl (length, fixed, addr, addrel, baseptr, substr, null, hbound, lbound) builtin;
dcl (tsrpr, on_line) bit (1);
dcl  cvbinbuf char (12);
dcl  fltdtab (0:35) bit (1) based (byptr) unaligned;
dcl  cpul (0 : 7) char (1) int static options (constant) init ("a", "b", "c", "d", "e", "f", "g", "h");
dcl  at_by_wd char (2);
dcl (ioa_$ioa_switch, ioa_$rsnnl) entry options (variable);
dcl  db_print entry (ptr, char (*) aligned, ptr, char (*), fixed bin, fixed bin, ptr, fixed bin, fixed bin);
dcl  ol_dump_$namef_ entry (ptr, ptr) returns (char (*));
dcl  interpret_ptr_ entry (ptr, ptr, ptr);
dcl  cv_bin_$oct entry (fixed bin, char (12));
dcl  get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin);
dcl  iox_$user_output ptr ext;

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

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

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

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

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

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

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

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

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

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


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

/*  */

/* on_line - entry to display scu data from a live on line system */

on_line:	entry (a_iocbp, scup, lg_sw);

	on_line = "1"b;				/* set switch for this entry */
	reoffset = fixed (rel (scup));		/* form relitive offset */
	go to common;				/* join common code */

/* dump - entry to display scu data within a dump segment */

dump:	entry (a_iocbp, scup, a_offset, lg_sw, odsp);

	on_line = "0"b;
	reoffset = a_offset;			/* copy relative offset */

common:

	if a_iocbp = null then			/* if null iocb ptr supplied */
	     iocbp = iox_$user_output;		/* default to user output */
	else iocbp = a_iocbp;			/* else use supplied switch name */
	if scud.wd0.psr = "0"b then
	     if scud.wd2.tsr = "0"b then do;
		call ioa_$ioa_switch (iocbp, "No SCU data stored");
		return;
	     end;
	inst6 = reoffset + 6;
	if lg_sw then				/* user wants octal dump too */
	     call ioa_$ioa_switch (iocbp, "^6o^-^4(^w ^)^/^-^4(^w ^)^/", reoffset, scup -> w (0),
	     scup -> w (1), scup -> w (2), scup -> w (3), scup -> w (4),
	     scup -> w (5), scup -> w (6), scup -> w (7));
	flt_ln, flt_bf = "";
	tsrpr = "0"b;
	flt_bf = flt_int_typ (fixed (scud.wd1.fi, 6));
	if substr (flt_bf, 1, 3) = "..." then
	     call ioa_$ioa_switch (iocbp, "Fault/Interrupt (^o), Undefined", fixed (scud.wd1.fi, 6));
	else do;
	     flt_lng = length (flt_int_typ (fixed (scud.wd1.fi, 6)));
	     substr (flt_ln, 1, flt_lng) = substr (flt_bf, 1, flt_lng);
	     byptr = addrel (scup, 1);
	     if fltdtab (35) = "1"b then do;
		substr (flt_ln, flt_lng + 2, 5) = "Fault";
		lnpos = flt_lng + 8;
		do i = 1 to hbound (g1and7flts, 1);	/*  If grp 1 or 7 faults, don't print out tsr|ca */
		     if scud.wd1.fi = g1and7flts (i) then
			tsrpr = "1"b;
		end;
	     end;
	     else do;
		substr (flt_ln, flt_lng + 2, 9) = "Interrupt";
		lnpos = flt_lng + 12;
		tsrpr = "1"b;			/* don't print out tsr|ca for interrupts */
	     end;
	     flt_lng = fixed (scud.wd1.fi, 6);
	     call cv_bin_$oct (flt_lng, cvbinbuf);
	     substr (flt_ln, lnpos, 4) = "(" || substr (cvbinbuf, 11, 2) || ")";
	     lnpos = lnpos + 4;
	     j = lnpos;
	     do i = 0 to hbound (grp1flt, 1);
		if fltdtab (i) then do;
		     if substr (flt_ln, 1, 5) = "Store"|substr (flt_ln, 1, 12) = "Illegal Proc" then
			if i <= 6 then
			     call ioa_$rsnnl ("^a, ^a", flt_ln, j, flt_ln, grp2flt (i));
			else;
		     else call ioa_$rsnnl ("^a, ^a", flt_ln, j, flt_ln, grp1flt (i));
		end;
	     end;
	     call ioa_$ioa_switch (iocbp, "^a", flt_ln);
	end;
	if ill_act_lns ^= "0"b then do;		/* display illegal action lines if present */
	     call ioa_$ioa_switch (iocbp, "Illegal Action Code (^o) - ^a", fixed (scud.wd1.ill_act_lns, 4),
		ill_act (fixed (scud.wd1.ill_act_lns, 4)));
	end;
	if tsrpr then at_by_wd = "At";		/* if not printing tsr */
	else at_by_wd = "By";
	byptr = addrel (baseptr (fixed (scud.wd0.psr, 18)), fixed (scud.wd4.ict, 18));
	if ^tsrpr then
	     refptr = addrel (baseptr (fixed (scud.wd2.tsr, 18)), fixed (scud.wd5.ca, 18));
	if ^on_line then do;			/* if  we are looking at a dump */
	     call ioa_$ioa_switch (iocbp, "^a: ^p  ^a", at_by_wd, byptr,
		ol_dump_$namef_ (byptr, odsp));
	     if ^tsrpr then				/* if we want to print out tsr|ca */
		call ioa_$ioa_switch (iocbp, "Referencing: ^p  ^a", refptr,
		ol_dump_$namef_ (refptr, odsp));
	end;
	else do;					/* if printing on line info */
	     strp = addr (strbuf);
	     call interpret_ptr_ (byptr, null, strp);	/* get on line name */
	     call ioa_$ioa_switch (iocbp, "^a: ^p ^a^a|^a ^a ^a", at_by_wd, byptr,
		struc.segment, struc.entryn, struc.offset, struc.modifier, struc.comment);
	     if ^tsrpr then do;			/* if we want to print out tsr|ca */
		call interpret_ptr_ (refptr, null, strp);
		call ioa_$ioa_switch (iocbp, "Referencing: ^p ^a^a|^a ^a ^a", refptr,
		     struc.segment, struc.entryn, struc.offset, struc.modifier, struc.comment);
	     end;
	end;
	call ioa_$ioa_switch (iocbp, "On: cpu ^a (#^o)", cpul (fixed (scud.wd2.cpu, 3)),
	     fixed (scud.wd2.cpu, 3));
	flt_ln = "";
	byptr = addr (scud.wd4);			/* display Indicator register if any bits present */
	do i = lbound (indrs, 1) to hbound (indrs, 1);
	     if fltdtab (i) then
		call ioa_$rsnnl ("^a ^a,", flt_ln, j, flt_ln, indrs (i));
	end;
	if flt_ln ^= "" then do;
	     substr (flt_ln, j, 1) = " ";
	     call ioa_$ioa_switch (iocbp, "Indicators: ^a", flt_ln);
	     flt_ln = "";
	end;
	byptr = addr (scud.wd0);			/* display interpreted APU status if any bits present */
	do i = lbound (APU, 1) to hbound (APU, 1);
	     if fltdtab (i) then
		call ioa_$rsnnl ("^a ^a,", flt_ln, j, flt_ln, APU (i));
	end;
	if flt_ln ^= "" then do;
	     substr (flt_ln, j, 1) = " ";
	     call ioa_$ioa_switch (iocbp, "APU Status: ^a", flt_ln);
	     flt_ln = "";
	end;
	byptr = addr (scud.wd5);			/* display interprted CU status if any bits present */
	do i = lbound (CU, 1) to hbound (CU, 1);
	     if fltdtab (i) then
		call ioa_$rsnnl ("^a ^a,", flt_ln, j, flt_ln, CU (i));
	end;

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

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

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


	call ioa_$ioa_switch (iocbp, "Instructions: ");	/* display Instructions (words 6 & 7) */
	call db_print (iocbp, iocbp -> iocb.name, addr (scud.wd6), "i", inst6, 1, null, 0, 0);
	call db_print (iocbp, iocbp -> iocb.name, addr (scud.wd7), "i", inst6 + 1, 1, null, 0, 0);

/*  */
% include iocb;

     end prtscu_;




		    trace_stack.pl1                 10/03/83  1732.6rew 10/03/83  1009.6       33822



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


/* format: style4,delnl,insnl,tree,ifthenstmt,indnoniterend */
trace_stack:
ts:
     procedure options (variable);

/* TRACE_STACK - Produce output on the console for debugging.
   Arguments are:
   .	-bf, -brief	short output
   .	-long, -lg	print octal dump
   .	-depth N, -dh N	go back N frames only
   .	-stack_ptr P, -sp P	start with stack frame at P

   This program is just a small command driver for the guts subroutine "trace_stack_".
   THVV 7/70 */

/* Modified March 1981 by C. Hornig to fix argument parsing bugs. */

dcl  ME char (32) static options (constant) init ("trace_stack");

dcl  argl fixed bin (21),				/* length of arg */
     bchr char (argl) based (tp),			/* for looking at argument */
     nargs fixed bin,				/* number of arguments */
     argno fixed bin,				/* steps thru argument list to command */
     mode fixed bin init (1),				/* output verbosity */
     depth fixed bin init (-1),			/* number of frames to trace back */
     stackp ptr,					/* pointer to ts's stack frame */
     tp ptr,					/* work pointer */
     ec fixed bin (35);				/* file-system error code */

dcl  error_table_$badopt fixed bin (35) ext;
dcl  error_table_$bad_conversion fixed bin (35) ext static;

dcl  com_err_ entry options (variable),
     find_condition_frame_ entry (ptr) returns (ptr),
     trace_stack_ entry (ptr, fixed bin, fixed bin, char (32) aligned),
     cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin),
     cv_ptr_ entry (char (*), fixed bin (35)) returns (ptr),
     cu_$arg_count entry (fixed bin, fixed bin (35)),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
     ioa_ entry options (variable);

dcl  null builtin;
%page;
	call cu_$arg_count (nargs, ec);		/* get argument count */
	if ec ^= 0 then do;
	     call com_err_ (ec, ME, "Usage: ts {-bf|-lg} {-dh N} {-sp PTR}");
	     return;
	     end;
	stackp = find_condition_frame_ (null ());	/* default to this stack frame */
	do argno = 1 to nargs;
	     call cu_$arg_ptr (argno, tp, argl, ec);	/* look at all arguments */
	     if ec ^= 0 then go to endarg;

	     if /* case */ (bchr = "-long") | (bchr = "-lg") then mode = 2;
	     else if (bchr = "-brief") | (bchr = "-bf") then mode = 0;
	     else if (bchr = "-depth") | (bchr = "-dh") then do;
		argno = argno + 1;
		call cu_$arg_ptr (argno, tp, argl, ec);
		if ec ^= 0 then do;
		     call com_err_ (ec, ME, "A number must follow -depth.");
		     return;
		     end;
		depth = cv_dec_check_ (bchr, ec);
		if ec ^= 0 then do;
		     call com_err_ (error_table_$bad_conversion, ME, """^a""", bchr);
		     return;
		     end;
		end;
	     else if (bchr = "-sp") | (bchr = "-stack_ptr") then do;
		argno = argno + 1;
		call cu_$arg_ptr (argno, tp, argl, ec);
		if ec ^= 0 then do;
		     call com_err_ (ec, ME, "A virtual pointer must follow -stack_ptr.");
		     return;
		     end;
		stackp = cv_ptr_ (bchr, ec);
		if ec ^= 0 then do;
		     call com_err_ (ec, ME, """^a""", bchr);
		     return;
		     end;
		end;
	     else do;
		call com_err_ (error_table_$badopt, ME, """^a""", bchr);
		return;
		end;
	end;

endarg:
	call trace_stack_ (stackp, mode, depth, "user_output");

	if mode > 0 then call ioa_ ("End of trace.^/");

	return;

     end trace_stack;




		    trace_stack_.pl1                11/05/86  1346.8r w 11/04/86  1041.7       77067



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


/* format: style4,delnl,insnl,tree,ifthenstmt,indnoniterend */
trace_stack_:
     procedure (stackp, mode, depth, stream);

/* TRACE_STACK_ - Subroutine to produce debugging output on console.
   1. explanation of fault
   2. source line which caused fault (if determinable, otherwise faulting instruction)
   3. machine registers at time of fault
   4. listing of stack frames, in reverse order from faulting frame.
   4.a. segment name and entry point name
   4.b. source line or instruction
   4.c. arguments to stack frame
   4.d. enabled on-units
   4.e. octal dump of frame

   The original idea for this program came from a remark of Bob Daley's.
   This program owes a great deal to Steve Webber, Melanie Weaver, and Barry Wolman.
   THVV 7/70 */
/**** Modified 1985-01-15, BIM: pass signal_io_, max number of errors permitted. */
/**** Modified 1985-03-06, BIM: added subroutine that does history regs. */

dcl  stackp ptr,					/* ptr to highest frame to trace from */
     mode fixed bin,				/* output mode */
     depth fixed bin,				/* number of frames to trace */
     stream char (32) aligned;			/* output stream */

dcl  ilc uns fixed bin (18),				/* offset from top of segment where instruction is */
     (max_depth, cur_depth) fixed bin (17),
     target_sp ptr,
     argl fixed bin,
     gptr ptr,					/* pointer for octal dump */
     ec fixed bin (35),
     line_no char (16),
     strp ptr;					/* pointer to stuff for interpret_ptr_ */
dcl  fault_count fixed bin;
dcl  abort_label label variable;
dcl  ssptr pointer;
dcl  a_hr_switch fixed bin;
dcl  hr_switch fixed bin;
dcl  iocb ptr;

dcl  (
     NO_HREGS init (0),
     HREGS init (1),
     HREGS_LONG init (2)
     ) fixed bin int static options (constant);

dcl  MAX_FAULT_COUNT fixed bin init (4000) int static options (constant);

dcl  (addr, addrel, binary, fixed, hbound, lbound, null, ptr, rel, stackframeptr) builtin;

dcl  (any_other, cleanup) condition;

dcl  dumary (8) fixed bin based (gptr);

dcl  1 condinfo aligned like condition_info;

dcl  print_source_line_ entry (ptr, char (32) aligned),
     find_source_line_ entry (ptr, char (*), char (*), char (*), fixed bin (21), fixed bin (21), fixed bin (35)),
     is_condition_frame_ entry (ptr) returns (bit (1) aligned),
     find_condition_info_ entry (ptr, ptr, fixed bin (35)),
     dump_machine_cond_ entry (ptr, ptr, char (32) aligned, fixed bin),
     interpret_ptr_$frame_owner entry (ptr, ptr, ptr),
     list_frame_args_ entry (ptr, char (32) aligned),
     list_onunits_ entry (ptr, char (32) aligned),
     ioa_$ioa_stream entry options (variable);
dcl  condition_interpreter_ entry (ptr, ptr, fixed bin (21), fixed bin, ptr, char (*), ptr, ptr);
dcl  continue_to_signal_ entry (fixed bin (35));
dcl  get_system_free_area_ entry () returns (ptr);
dcl  hran_$hranl entry (pointer, pointer, bit (1));
dcl  iox_$find_iocb entry (char (*), ptr, fixed bin (35));
%page;

	hr_switch = NO_HREGS;
	go to COMMON;

hregs:
     entry (stackp, mode, depth, stream, a_hr_switch);

	hr_switch = a_hr_switch;
COMMON:
	iocb = null ();
	call iox_$find_iocb ((stream), iocb, (0));
	condinfo.version = 1;
	sp, target_sp = stackp;			/* copy argument - initial stack level */
	if sp = null () then sp, target_sp = stackframeptr ();
	max_depth = depth;
	if max_depth < 0 then max_depth = 100000;
	strp = addr (strbuf);

	abort_label = abort_trace;
	on any_other call fault_handler;
	fault_count = 0;

/* This section is the actual back-trace loop on the stack.
   For each frame, we call "interpret_ptr_$frame_owner" to find the owner of the frame,
   and then "print_source_line_" to attempt to print the source line, or the faulting instruction.
   Then we call "list_frame_args_" to list the arguments to the frame. */

	do cur_depth = 0 to max_depth while (sp ^= null ());
	     condinfo.mc_ptr, condinfo.user_loc_ptr = null ();
	     condinfo.condition_name = "";
	     struc.segment, struc.entryn = "?";
	     struc.offset, struc.comment, struc.opname = "";
	     line_no = "";

	     abort_label = no_mc;
	     if is_condition_frame_ (sp) then do;
		call find_condition_info_ (sp, addr (condinfo), ec);
		call dump_machine_cond_ (addr (condinfo), sp, stream, mode);
		if condinfo.mc_ptr ^= null & hr_switch >= HREGS then do;
		     ssptr = addwordno (condinfo.mc_ptr, -8);
						/* see signaller_stack.incl.pl1 */
		     if hr_switch = HREGS
		     then call hran_$hranl (addr (ssptr -> signaller_stack.history_registers), iocb, "0"b);
		     if hr_switch = HREGS_LONG
		     then call hran_$hranl (addr (ssptr -> signaller_stack.history_registers), iocb, "1"b);
		     end;
		end;
no_mc:
	     if cur_depth < max_depth then do;
		abort_label = no_ilc;
		if condinfo.mc_ptr = null () then do;
		     ilc = binary (rel (stack_frame.return_ptr), 18);
		     if ilc > 0 then ilc = ilc - 1;	/* Get call-out location. */
		     condinfo.user_loc_ptr = ptr (stack_frame.return_ptr, ilc);
						/* STCD info is not a pointer */
		     end;

no_ilc:
		abort_label = no_owner;
		call interpret_ptr_$frame_owner (condinfo.user_loc_ptr, sp, strp);
		call find_source_line_ (strp, line_no, (""), (""), (0), (0), ec);
no_owner:
		abort_label = no_brief;
		call ioa_$ioa_stream (stream, "^p^13t^a^a|^a ^a ^a ^a", target_sp, struc.segment, struc.entryn,
		     struc.offset, struc.comment, line_no, struc.opname);

no_brief:
		if mode > 0 then do;
		     abort_label = no_source;
		     if struc.text_ptr ^= null ()	/* skip source if looks bad. */
		     then call print_source_line_ (strp, stream);
no_source:
		     abort_label = no_args;
		     call list_frame_args_ (sp, stream);/* what are the arguments */
no_args:
		     abort_label = no_units;
		     call list_onunits_ (sp, stream);	/* what handlers */

/* This next section of code dumps the stack frame in octal.
   Useful only under an "fo", I think. */

no_units:
		     if mode > 1 then do;
			abort_label = no_long;
			gptr = sp;		/* yes. */
			argl = 0;
			do while (rel (gptr) < rel (stack_frame.next_sp));
						/* loop through 8 words at a time */
			     call ioa_$ioa_stream (stream, "^6o ^5o ^w ^w ^w ^w ^w ^w ^w ^w",
				fixed (rel (gptr), 18), argl, dumary);
			     argl = argl + 8;
			     gptr = addrel (gptr, 8);
			end;
			end;
no_long:
		     abort_label = next_frame;
		     call ioa_$ioa_stream (stream, "");
		     end;
		end;
next_frame:
	     abort_label = abort_trace;
	     sp, target_sp = sp -> stack_frame.prev_sp;
	end;
	return;


abort_trace:
	revert any_other;				/* If we gave up, we gave up */
	call ioa_$ioa_stream (stream, "Trace aborted.");
	return;
%page;
fault_handler:
     procedure;

dcl  m_ptr ptr;
dcl  m_len fixed bin (21);
dcl  msg char (m_len) based (m_ptr);

dcl  i fixed bin;
dcl  code fixed bin (35);
dcl  1 ci aligned like condition_info;

dcl  continue_conditions (14) char (32) static options (constant)
	init ("endpage", "stringsize", "underflow", "command_error", "finish", "command_question", "trm_", "sus_",
	"cput", "alrm", "wkp_", "mme2", "quit", "signal_io_");

	m_ptr = null ();
	on cleanup
	     begin;
	     if m_ptr ^= null () then do;
		free msg;
		m_ptr = null ();
		end;
	end;
	on any_other goto abort_trace;
	fault_count = fault_count + 1;
	if fault_count > MAX_FAULT_COUNT then goto abort_trace;

	call find_condition_info_ (null (), addr (ci), code);
	if code ^= 0 then do;
continue:
	     call continue_to_signal_ ((0));
	     return;
	     end;

	if ci.condition_name = "cleanup" then return;
	do i = lbound (continue_conditions, 1) to hbound (continue_conditions, 1);
	     if ci.condition_name = continue_conditions (i) then goto continue;
	end;

	call ioa_$ioa_stream (stream, "^a condition during trace...", ci.condition_name);
	call condition_interpreter_ (get_system_free_area_ (), m_ptr, m_len, 1, ci.mc_ptr, (ci.condition_name),
	     ci.wc_ptr, ci.info_ptr);
	call ioa_$ioa_stream (stream, "^a", msg);
	free msg;
	goto abort_label;

     end fault_handler;
%page;
%include stack_frame;
%include interpret_ptr_struc;
%include condition_info;
%include signaller_stack;

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