



		    cv_error_.pl1                   11/11/89  1139.1rew 11/11/89  0838.7       23535



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */
/*
   Function to return an error code from an error name.  This entry can be called by programs written in languages
   which can not directly reference names of the form "reference$entry".
*/
/* Originally written 22 March 1982 by Chris Jones */
/* format: style4,delnl,insnl,indattr,ifthen,declareind10,dclind10 */
cv_error_:
     proc;
	signal bad_call_;				/* not a valid entry */
	return;

name:
     entry (error_name, converted_code, code);

dcl	code		   fixed bin (35) parameter;	/* the result of this operation */
dcl	converted_code	   fixed bin (35) parameter;	/* the answer to the question */
dcl	error_name	   char (*) parameter;	/* the error name (e.g. "error_table_$bad_arg" */

dcl	et_ptr		   ptr;			/* pointer to the error code */

dcl	based_code	   fixed bin (35) based (et_ptr);
dcl	1 cc		   aligned based,		/* this structure is laid over converted_code */
	  2 segno		   bit (18) unal,
	  2 pad		   bit (18) unal;

dcl	cv_ptr_		   entry (char (*), fixed bin (35)) returns (ptr);
dcl	cv_ptr_$terminate	   entry (ptr);
dcl	hcs_$make_ptr	   entry (ptr, char (*), char (*), ptr, fixed bin (35));

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

dcl	any_other		   condition;
dcl	bad_call_		   condition;
dcl	cleanup		   condition;

dcl	(addr, after, baseno, before, null)
			   builtin;

	call hcs_$make_ptr (null (), before (error_name, "$"), after (error_name, "$"), et_ptr, code);
	if code ^= 0 then
	     return;

	et_ptr = null ();
	on cleanup call CLEAN_UP;

	et_ptr = cv_ptr_ (error_name, code);
	if code ^= 0 then do;
ERROR_RETURN:
	     call CLEAN_UP;
	     return;
	end;

	on any_other
	     begin;
		code = error_table_$bad_arg;
		goto ERROR_RETURN;
	     end;

	converted_code = based_code;
	if baseno (et_ptr) ^= baseno (addr (error_table_$)) then
	     addr (converted_code) -> cc.segno = baseno (et_ptr);
						/* put in segment number for non error_table_ codes */
	call CLEAN_UP;
	code = 0;
	return;

CLEAN_UP:
     proc;

	if et_ptr ^= null () then
	     call cv_ptr_$terminate (et_ptr);
	et_ptr = null ();

     end CLEAN_UP;

     end cv_error_;




		    default_error_handler_.pl1      11/11/89  1139.1rew 11/11/89  0830.0      281286



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



/****^  HISTORY COMMENTS:
  1) change(87-06-05,Lippard), approve(87-06-22,MCR7718),
     audit(87-07-01,Fawcett), install(87-07-15,MR12.1-1041):
     Modified to verify that entries returned by call to hcs_$make_ptr are
     actually in the segment message_table_.
  2) change(88-05-19,Hergert), approve(88-05-19,MCR7903),
     audit(88-05-19,Dupuis), install(88-08-01,MR12.2-1073):
     John Hergert (FMC) Added code to handle mrds_se_error_
     condition for MRDS.
  3) change(89-05-26,Farley), approve(89-06-22,MCR8114),
     audit(89-06-22,Fawcett), install(89-06-26,MR12.3-1064):
     Added initialization of the currently uninitailized no_restart flag to
     allow restarts as the default.
                                                   END HISTORY COMMENTS */


/*format: style2 */
/* default_error_handler_.pl1 */

dummy:
     procedure;

/* This is the default error handling routine used by Multics. There are several entries
   as follows:

   default_error_handler_ 	no condition wall	handles program_interrupt
   ignore_pi		no condition wall	ignores program_interrupt
   wall			yes condition wall	handles program_interrupt
   wall_ignore_pi		yes condition wall	ignores program_interrupt

   interpret_condition_	returns to caller without calling cu_$cl
   condition_interpreter_
   change_error_mode_
   reprint_error_message_
   reinterpret_condition_
   add_finish_handler

   /* initially coded by M. Weaver 12 February 1970 */
/* modified by M. Weaver 27 September 1971 */
/* recoded by M. Weaver 12 October 1973 to handle software conditions better */
/* modified by M. Weaver 6/13/74  for finish and storage conditions and to use iox_ */
/* modified 11/76 by  M. Weaver to move illegal_procedure handling to better place */

/*
   Last modified (Date and Reason):
   Aug 12, 1977 by Steve Webber to add wall entries and merge with standard_default_handler_.
   Aug 17, 1977 by Steve Webber to use new message_table_ format
   Nov 18, 1977 by Melanie Weaver to fix bugs in reprint_error and quit handling
   Dec 19, 1977 by Melanie Weaver to fix bug in illegal_procedure handling
   Nov. 22, 1978 by Melanie Weaver to print long messages in their entirety
   March 1979 by T. Casey to add call to sus_signal_handler_.
   July 1979 by Steve Webber to pass "finish" through the wall entries.
   April 1981 by Benson I. Margulies for null_pointer_ instead of simfault.
	     remove special cases for conditions already caught by
	     static handlers, use find_condition_info_,
	     respect the quiet_restart bit, and houseclean some.
  July 1981 by BIM for the new program interrupt (kludge) special case.
  December 1981 by E. N. Kittlitz for quit_info.
  June 1983 by M. Weaver for fortran_pause.
  September 1983 by M. Weaver to put newline before fortran_pause message.
  1984-10-18 BIM to special case signal_io_ in the normal case (
  terminate the process if user_i/o) and in the blowup_handler_ 
  (pass it through if on error_output).
   */


/* Parameters */
/* Used only by the interpreting entrypoints, not the actual handlers */

	dcl     a_mcptr		 ptr;
	dcl     a_conname		 char (*);
	dcl     a_wcptr		 ptr;
	dcl     a_infoptr		 ptr;
	dcl     a_flag		 bit (1) aligned;

/* Automatic */

	dcl     eof		 bit (1) aligned;
	dcl     establish_wall	 bit (1) aligned;
	dcl     found		 bit (1) aligned;
	dcl     1 dd		 aligned like decode_definition_str;
	dcl     iocb_ptr		 ptr;
	dcl     cond_id		 char (46) var;	/* for condition name */
	dcl     ring_mes		 char (10);	/* ring n or lower ring */
	dcl     retsw		 bit (1) aligned;
	dcl     realsw		 bit (1) aligned init ("1"b);
						/* indicates whether this is a "rerun" */
	dcl     defaultsw		 bit (1) aligned;	/* indicates to use conname as such in message */
	dcl     no_restart		 bit (1) aligned;
	dcl     ignore_pi_sw	 bit (1) aligned;
	dcl     pass_finish_sw	 bit (1) aligned;

	dcl     optr		 ptr;
	dcl     longsw_ptr		 ptr;
	dcl     lsp		 ptr;		/* ptr to stack frame at time of condition */
	dcl     new_con		 char (32) varying;
	dcl     temp_longsw		 fixed bin init (-1);
	dcl     (flong, i)
				 fixed bin;
	dcl     long		 fixed bin;
	dcl     code		 fixed bin (35);
	dcl     resetwrite		 bit (1) aligned;
	dcl     1 cl_arg		 aligned,
		2 reset_sw	 bit (1) unaligned,
		2 pad		 bit (35) unaligned;

/* External */

	dcl     message_table_$privileged_info
				 ext;
	dcl     message_table_$soft_default_info
				 ext;
	dcl     message_table_$hard_default_info
				 ext;
	dcl     message_table_$formats (26) char (104) var ext;

%include iox_entries;

/* Static */

	dcl     real_longsw		 fixed bin int static init (1);
	dcl     rptsw		 fixed bin (17) int static init (0);
						/* indicates level of recursion in blowup handler */

/* Based */

	dcl     based_var		 char (256) var based;
	dcl     longsw		 fixed bin based (longsw_ptr);
	dcl     ostring		 char (1000) aligned based (optr);
						/* based string for output */

	dcl     any_other		 condition;

/* Big String Department */

	dcl     (pname1, pname2, pname3, tname1, tname2)
				 char (500) aligned;
	dcl     linfo		 char (500) var;
	dcl     my_string		 char (1000);	/* actual space normally used for output */

/* Entries */

	declare condition_		 entry (char (*), entry);
	declare reversion_		 entry (char (*));
	dcl     cu_$cl		 entry (1 aligned, 2 bit (1) unaligned, 2 bit (35) unaligned);
	dcl     decode_definition_	 entry (ptr, ptr, bit (1) aligned);
	dcl     hcs_$make_ptr	 entry (ptr, char (*), char (*), ptr, fixed bin (35));
	dcl     (
	        ioa_$ioa_switch,
	        ioa_$rs,
	        ioa_$rsnnl
	        )			 entry options (variable);
	dcl     signal_		 ext entry options (variable);
	dcl     linkage_error_	 entry (ptr, fixed bin, ptr, ptr, char (500) aligned, char (500) aligned, ptr,
				 fixed bin);
	dcl     get_ppr_		 entry (fixed bin, ptr, ptr, char (500) aligned, char (500) aligned,
				 char (500) aligned);
	dcl     get_tpr_		 entry (ptr, ptr, ptr, char (500) aligned, char (500) aligned);
	dcl     special_messages_	 entry (ptr, ptr, char (500) var, bit (1), bit (1) aligned);

	dcl     interpret_info_struc_	 ext
				 entry (char (32), ptr, char (500) var, bit (1) aligned, bit (1) aligned,
				 bit (1) aligned, fixed bin);
	dcl     interpret_info_struc_$no_message
				 entry (char (32), ptr);
	dcl     find_condition_frame_	 entry (ptr) returns (ptr);
	dcl     find_condition_info_	 entry (ptr, ptr, fixed bin (35));
	dcl     continue_to_signal_	 entry (fixed bin (35));

	dcl     (addr, baseno, baseptr, bin, byte, codeptr, length, null, ptr, size, string, unspec)
				 builtin;

wall_ignore_pi:
     entry;

	pass_finish_sw = "1"b;
	ignore_pi_sw = "1"b;
	establish_wall = "1"b;
	go to COMMON;

standard_default_handler_:
wall:
     entry;


	pass_finish_sw = "0"b;
	ignore_pi_sw = "0"b;
	establish_wall = "1"b;
	goto COMMON;

ignore_pi:
     entry;

	pass_finish_sw = "1"b;
	ignore_pi_sw = "1"b;
	establish_wall = "0"b;
	go to COMMON;

default_error_handler_:
     entry;

	pass_finish_sw = "0"b;
	establish_wall = "0"b;
	ignore_pi_sw = "0"b;

COMMON:
	mtep = null ();
	iocb_ptr = iox_$error_output;
	lsp = null ();
	realsw = "1"b;				/* we are an error handler, not an interpreter */
	retsw = "0"b;				/* this entry usually does not just return */
	no_restart = "0"b;				/* allow restarts by default */

	call condition_ ("any_other", blowup_handler_);
	call get_condition_info;			/* pickup condition info */


/* Now check for common conditions */
/* finish passes walls */

	if (cond_info.condition_name = "finish")
	then do;
		if pass_finish_sw			/* can only be on if realsw is on */
		then call continue_to_signal_ (0);
		go to exit;
	     end;

/* we may need to do more for pi someday, so it is in its own statement */

/* ignore_pi_sw only on if realsw on */
	if ignore_pi_sw & (cond_info.condition_name = "program_interrupt")
	then do;
		call continue_to_signal_ (0);
		go to exit;
	     end;

/**** The following special case improves the system's behavior when
      then signal_io_ I/O module is in use on a critical switch */

	if realsw & (cond_info.condition_name = "signal_io_")
	then do;
		if cond_info.info_ptr -> signal_io_info.iocb_ptr = iox_$user_io
		     | cond_info.info_ptr -> signal_io_info.iocb_ptr = iox_$user_output
		     | cond_info.info_ptr -> signal_io_info.iocb_ptr = iox_$user_input
		     | cond_info.info_ptr -> signal_io_info.iocb_ptr = iox_$error_output
		then call terminate_process;		/* no one is dealing with critical I/O */
	     end;

	if realsw & cond_info.condition_name = "quit"
	then do;
		call reversion_ ("any_other");

/* check for condition_info which directs reset operations.  This is currently only
present if a call to signal_ was made.  sus_signal_handler_ does this very thing. */
		if cond_info.info_ptr ^= null
		then if cond_info.info_ptr -> quit_info.version = 1
			& cond_info.info_ptr -> quit_info.length = size (quit_info)
		     then resetwrite = cond_info.info_ptr -> quit_info.switches.reset_write;
		     else resetwrite = "1"b;		/* do the reset if not told otherwise */
		if resetwrite
		then call iox_$control (iox_$user_io, "resetwrite", null, (0));
		call iox_$control (iox_$user_io, "printer_on", null, (0));
		call ioa_$ioa_switch (iox_$user_io, "QUIT");
		if establish_wall
		then on any_other call wall_ignore_pi;
		cl_arg.reset_sw = "0"b;
		cl_arg.pad = "0"b;
		call cu_$cl (cl_arg);
		go to exit;
	     end;

	/*** format: off */     
	if (cond_info.condition_name = "command_error"
            | cond_info.condition_name = "command_question")
						/* preserve special case for private versions */
	then go to exit;
	/*** format: ^off */

/* reprinters and interpreters enter here */

begin:
	optr = addr (my_string);

begin_com:
	cl_arg.reset_sw = "1"b;			/* set resetread switch for all other conditions */
	cl_arg.pad = "0"b;

/* initialize variables to be args */

	if cond_info.mc_ptr ^= null ()
	then scup = addr (cond_info.mc_ptr -> mc.scu);
	else scup = null ();

/* the following must be initialized here as longsw can be referenced if cond_info.mc_ptr is null */
	if temp_longsw ^= -1
	then longsw_ptr = addr (temp_longsw);		/* have temporary message mode */
	else longsw_ptr = addr (real_longsw);


	defaultsw = "0"b;

/* Now get a pointer to the appropriate message_table entry */

	found = "0"b;

	call hcs_$make_ptr (codeptr (wall), "message_table_", (cond_info.condition_name), mtep, code);

	if mtep ^= null ()
	then do;
	     call decode_definition_ (baseptr (baseno (mtep)), addr (dd), eof);
	     do while (^eof & ^found);
		if dd.section = "segn" then if dd.symbol = "message_table_" then found = "1"b;
		call decode_definition_ (dd.next_def, addr (dd), eof);
	     end;

	     found = "0"b;
	     do while (^eof & ^found);
		if dd.section ^= "text" then eof = "1"b;
		else if dd.entrypoint = 0 then if dd.symbol = cond_info.condition_name then found = "1"b;
		else call decode_definition_ (dd.next_def, addr (dd), eof);
	     end;
	end;

	if ^found
	then do;
		if cond_info.mc_ptr = null
		then mtep = addr (message_table_$soft_default_info);
		else mtep = addr (message_table_$hard_default_info);
		defaultsw = "1"b;
	     end;

/* if the condition is mrds_se_error and we made it into default_error_handler_
   then we can assume the user did not handle the condition. We set the value 
   in mrds_se_error_info.header.info_string equal to the string 
   "default_error_handler_" to tell the signaller to handle the error.
*/
          if cond_info.condition_name = "mrds_se_error_" then do;
	     cond_info.info_ptr -> mrds_se_error_info.header.info_string =
		"default_error_handler_";
	     goto exit;
	end;

	if cond_info.condition_name = "error"
	then if cond_info.info_ptr = null ()
	     then do;				/* signalled by another handler */
		     linfo = "system handler for error returns to command level
";
		     long = length (linfo);
		     if cond_info.crawlout
		     then do;			/* must still tell user about crawlout */
			     ostring = "Error while processing in lower ring:" || byte (10) /* NL */ || linfo;
			     long = long + 38;
			end;
		     else ostring = linfo;
		     go to out;
		end;

	if mte.endpage
	then if ^cond_info.crawlout
	     then if cond_info.info_ptr ^= null ()
		then if realsw
		     then do;			/* indicate end of page in file */
			     call interpret_info_struc_$no_message ((cond_info.condition_name), cond_info.info_ptr);
			     go to exit;
			end;

	if cond_info.condition_name = "underflow"
	then if ^cond_info.crawlout			/* be sure test performed for all modes */
	     then retsw = "1"b;			/* default is to return, but can't on cond_info.crawlout */

	if longsw = 0
	then if cond_info.condition_name ^= "fortran_pause"
	     then do;				/* just print condition name */
		     if cond_info.crawlout
		     then if cond_info.mc_ptr ^= null
			then call ioa_$rs ("^/Error: ^a while in ring ^d", ostring, long, cond_info.condition_name,
				bin (scup -> scu.ppr.prr, 3));
			else call ioa_$rs ("^/Error: ^a while in lower ring", ostring, long,
				cond_info.condition_name);
		     else call ioa_$rs ("^/Error: ^a", ostring, long, cond_info.condition_name);
						/* just print name */
		     go to out;
		end;
	     else ;				/* handle fortran_pause later */
	else do;					/* (longsw > 0) print part common to all messages */
		if cond_info.crawlout
		then /* try to print ring no. */
		     if cond_info.mc_ptr ^= null
		     then call ioa_$rsnnl ("ring ^d", ring_mes, long, bin (scup -> scu.ppr.prr, 3));
		     else ring_mes = "lower ring";
	     end;

	if mte.undefined
	then do;					/* we have a division of illegal_procedure which the fim
						   didn't isolate for us */
		if scup -> scux.fd.isp
		then mtep = addr (message_table_$privileged_info);
						/* this is a special case */
		else do;				/* some other random type */
			mtep = addr (message_table_$hard_default_info);
			defaultsw = "1"b;		/* so cond_info.condition_name will get printed */
		     end;
	     end;

	if defaultsw
	then new_con = cond_info.condition_name;
	else new_con = "";				/*  rest of stuff contains  enough  information */

	if cond_info.info_ptr ^= null
	then do;
		if realsw & cond_info.info_ptr -> condition_info_header.action_flags.quiet_restart
		then go to exit;
		call interpret_info_struc_ ((cond_info.condition_name), cond_info.info_ptr, linfo, retsw, no_restart,
		     realsw, longsw);

/* Program interrupt has a special case here, because it is not
   strictly "quiet restart". See the source of program_interrupt.pl1
   for an explanation of the protocol, and interpret_info_struc_
   for the real work of this side of the protocol.
*/

		if cond_info.condition_name = "program_interrupt"
		then go to exit;

		if mte.active_func
		then do;
			ostring = linfo;
			long = length (linfo);
			go to out;		/* don't print pathname */
		     end;
	     end;					/* the following two conditions get special treatment */
	if mte.linkerr
	then if ^cond_info.crawlout
	     then do;				/* ordinary linkage _error */
		     call linkage_error_ (cond_info.mc_ptr, longsw, lsp, addr (cond_info), pname1, pname2, optr, long)
			;			/* linkage_error_ calls get_ppr_ itself */
		     go to out;
		end;

	if mte.sub_err
	then new_con = cond_info.info_ptr -> sub_error_info.name;
						/* use more descriptive name */

	if longsw = 0 & (cond_info.condition_name = "fortran_pause")
	then do;
		call ioa_$rs ("^/^a", ostring, long, linfo);
		go to out;
	     end;

/* get the name of the procedure that took the fault */
	call get_ppr_ (longsw, lsp, addr (cond_info), pname1, pname2, pname3);


/* find out what was being referenced */
	call get_tpr_ (lsp, addr (cond_info), mtep, tname1, tname2);


	cond_id = "";				/* set default value */
	if longsw = 2
	then cond_id = ptr (mtep, mte.cond_id_relp) -> based_var;
	if mte.no_special = "0"b
	then call special_messages_ (cond_info.mc_ptr, mtep, linfo, cond_info.crawlout, no_restart);
						/* format messages */

/* obtain  format string and assemble message */

	if cond_info.condition_name = "fortran_pause"
	then do;					/* this doesn't fit the message_table_ scheme */
		call ioa_$rs ("^/^a at ^a^a^[^/^;^]^a", ostring, long, linfo, pname1, pname2, longsw = 2, cond_id);
		go to out;			/* should not have a crawlout with this condition */
	     end;

	if cond_info.crawlout
	then do;
		call ioa_$rs (message_table_$formats (mte.format_x + 1), ostring, long, ring_mes, new_con,
		     ptr (mtep, mte.string_relp (1)) -> based_var, pname3,
		     ptr (mtep, mte.string_relp (2)) -> based_var, tname1, linfo,
		     ptr (mtep, mte.string_relp (3)) -> based_var, ptr (mtep, mte.string_relp (4)) -> based_var,
		     pname1, pname2, tname2, cond_id);
	     end;
	else do;					/* Not cond_info.crawlout */
		call ioa_$rs (message_table_$formats (mte.format_x), ostring, long, new_con,
		     ptr (mtep, mte.string_relp (1)) -> based_var, pname1, pname2,
		     ptr (mtep, mte.string_relp (2)) -> based_var, tname1, linfo,
		     ptr (mtep, mte.string_relp (3)) -> based_var, ptr (mtep, mte.string_relp (4)) -> based_var,
		     cond_id);
	     end;

/* warn user if any IPS interrupts have been recently disabled */

/*
   out:	if cond_info.mc_ptr ^= null then if substr(cond_info.mc_ptr -> mc.ips_temp,36,1) = "1"b then do;
   call hcs_$get_ips_mask (ips_mask);
   ips_string = "";
   do i = 1 to sys_info$ips_mask_data.count;
   if (cond_info.mc_ptr -> mc.ips_temp & sys_info$ips_mask_data.masks(i).mask)
   > (ips_mask & sys_info$ips_mask_data.masks(i).mask) then do;
   if ips_string = "" then ips_string =
   substr(masks(i).name, 1, index(masks(i).name, "")-1);
   else ips_string = ips_string || ", " ||
   substr(masks(i).name, 1, index(masks(i).name, "") -1 );
   end;
   end;
   if ips_string ^= "" then call ioa_$rs("^a^a disabled", ostring, long, ostring, ips_string);
   end;
*/

/* print it out at last! */
out:
	if (iocb_ptr ^= null)
	then if (long > 0) & (optr ^= null)
	     then do;
		     call iox_$put_chars (iocb_ptr, optr, (long), code);
		     call iox_$control (iocb_ptr, "start", null (), (0));
						/* just in case a timer that did not expect to print took a fault */
		end;
	     else ;
	else mlong = long;				/* called from return string entry */

last:						/* clean up and leave */
	if retsw
	then go to exit;
	else do;
		call reversion_ ("any_other");	/* but don't want blowup handler to get invoked */
		rptsw = 0;			/* can't enter blowup handler again */
		if mtep ^= null
		then if mte.sig_error		/* CHECK THIS SOMETIME */
		     then call signal_ ("error");	/* these are really pl1 conditions */
		     else go to go_to_cl;		/* pl1 clumsiness */
		else
go_to_cl:
		     do;
			if establish_wall
			then on any_other call wall_ignore_pi;
			call cu_$cl (cl_arg);
			if establish_wall
			then revert any_other;
		     end;

		if no_restart
		then do;				/* don't allow restart */
			call ioa_$ioa_switch (iox_$error_output, "computation cannot be restarted");
			go to go_to_cl;
		     end;
	     end;

exit:						/* we are here if we want to return and not abort */
	rptsw = 0;				/* can't enter blowup handler again */
	return;

interpret_condition_:
     entry (a_mcptr, a_conname, a_wcptr, a_infoptr, a_flag);/* this entry point prints out a message and returns */
						/* it can be used by procedures who want to call the default handler */

/* ASSERT: there is a fault frame on the stack, these arguments are
   not just constructed */

	call get_condition_info;

	realsw = "0"b;				/* do not suppress quiet conditions */
	retsw = "1"b;				/* definitely return */
	go to begin;

/*  */
blowup_handler_:
     procedure (mc_ptr, condition_name, wc_ptr, info_ptr, continue_flag);

	declare (
	        continue_flag	 bit (1) aligned,
	        (mc_ptr, wc_ptr, info_ptr)
				 pointer,
	        condition_name	 character (*)
	        )			 parameter;

	dcl     mess0		 char (40) aligned;
	dcl     short_mess		 char (8) aligned;	/* for convert_status_code_ */
	dcl     long_mess		 char (100) aligned;


	dcl     convert_status_code_	 entry (fixed bin (35), char (8) aligned, char (100) aligned);

/* this is the default handler for default_error_handler_ */


	/*** format: off */
	if condition_name = "quit"
           | condition_name = "alrm"
           | condition_name = "cput"
           | condition_name = "program_interrupt"
           | condition_name = "storage"
           | condition_name = "finish"
	 | condition_name = "signal_io_" /* might be needed to do the work */
	then do;
		call continue_to_signal_ ((0)); /* works fine */
		return;
	     end;
	/*** format: ^off */

	rptsw = rptsw + 1;				/* increase recursion indicator */
	if rptsw = 3
	then do;					/* can't even write on user_i/o; terminate proc */
		call terminate_process;
		go to last;			/* if not... */
	     end;

	if ^cond_info.crawlout
	then mess0 = byte (10) /* NL */ || "Error:";
	else mess0 = byte (10) /* NL */ || "Error while processing in lower ring:
";

/* the next section is for dire emergencies, when we don't trust anything */
	if rptsw = 2
	then do;					/* don't take chances with rqo--use user_i/o */
		call ioa_$ioa_switch (iox_$user_io, "^/^a^a  (Unable to obtain proper message.)", mess0,
		     condition_name);
		go to last;			/* rptsw will be reset there */
	     end;

/* at this point, try at least to get decent names to print */
	if mc_ptr ^= null
	then do;					/* have machine conditions */
		if (wc_ptr ^= null ())		/* crawlout */
		then pname1 = pname3;		/* print name from mc */
		if pname1 = ""
		then call format_name (ptr (baseptr (bin (bin (scup -> scu.ppr.psr, 15), 18)), scup -> scu.ilc),
			pname1);
		if tname1 = ""
		then call format_name (ptr (baseptr (bin (bin (scup -> scu.tpr.tsr, 15), 18)), scup -> scu.ca),
			tname1);
		if mc_ptr -> mc.errcode = 0
		then long_mess = "";
		else do;
			call convert_status_code_ ((mc_ptr -> mc.errcode), short_mess, long_mess);
			if short_mess = "xxxxxxxx"
			then long_mess = "";	/* don't print code not found */
		     end;

/* print basic message for original fault */
		call ioa_$rs ("^/^a  ^a condition by ^a^/referencing ^a^/^a", ostring, long, mess0,
		     cond_info.condition_name, pname1, tname1, long_mess);
	     end;
	else do;					/* no mc -> no pathnames */
		if linfo ^= ""
		then go to print;			/* have as much as we can get */
		if info_ptr ^= null
		then do;				/* see what we can find in info structure */

			call interpret_info_struc_ ((condition_name), info_ptr, linfo, retsw, no_restart, realsw,
			     longsw);
		     end;
print:
		call ioa_$rs ("^/^a  ^a condition^/^a", ostring, long, mess0, condition_name, linfo);
	     end;
	go to out;				/* print it out */


format_name:
     proc (p, name);

	dcl     p			 ptr;
	dcl     code		 fixed bin (35);
	dcl     find_pathname_	 entry (ptr, ptr, fixed bin (35));
	dcl     name		 char (500) aligned;
	dcl     1 name_info		 aligned like find_pathname_info automatic;


	call find_pathname_ (p, addr (name_info), code);

	if name_info.component_ename ^= ""
	then /* use name from bindmap */
	     call ioa_$rsnnl ("^a^a (^a^a^a^a^a)^a", name, long, name_info.component_ename, name_info.adjusted_offset,
		name_info.dirname, name_info.gt_char, name_info.real_ename, name_info.real_offset,
		name_info.pdir_string, name_info.offset_msg);

	else call ioa_$rsnnl ("^a^a^a^a^a^a", name, long, name_info.dirname, name_info.gt_char, name_info.real_ename,
		name_info.real_offset, name_info.pdir_string, name_info.offset_msg);

	return;
     end format_name;
     end blowup_handler_;


change_error_message_mode_:
     entry (longsw_val);

/* this entry allows the user to specify the length of the message that he wants */
/* the possibilities are:  0 for brief, 1 for normal, and 2 for long  */
/* (long means that both sets of machine conditions will be printed on crawl_outs */

	dcl     longsw_val		 fixed bin;

	if longsw_val < 0 | longsw_val > 2
	then real_longsw = 1;			/* set to default */
	else real_longsw = longsw_val;
	return;

reprint_error_message_:
     entry (areap, mptr, mlong, mode, depth, ecode);

/* this entry is called from a command and looks back in the stack for the arguments of a previous
   invocation of default_error_handler_.    These are used to call default_error_handler_ recursively
   nad print out the message again.  this feature would normally be used when the first message was
   of the short form and a longer message is desired.
*/

	dcl     (depth, ecode)	 fixed bin;	/* depth specifies how many stack frames to go back */

	i = 0;
	do lsp = find_condition_frame_ (null) repeat find_condition_frame_ (lsp);
						/* do not use language for test */
	     if lsp = null
	     then go to return_no_such_level;
	     i = i + 1;				/* count number of levels we have found */

/* we do not want a while loop, we want an until loop.
   so we hand to the test-and-go-to, to avoid an extra
   pass through the repeat code */

	     if i = depth
	     then go to found_level;
	end;

found_level:					/* get arguments from earlier frame so we can call ourself */
	call get_condition_info_code (code);
	if code ^= 0
	then do;
		call ioa_$ioa_switch (iox_$error_output, "condition information not available for level ^d", depth);
		ecode = -1;
		return;
	     end;

	call reinterpret_condition_ (areap, mptr, mlong, mode, cond_info.mc_ptr, (cond_info.condition_name),
	     cond_info.wc_ptr, cond_info.info_ptr, lsp);

return_no_such_level:
	ecode = i;				/* tell them how far we went */
	return;


reinterpret_condition_:
     entry (areap, mptr, mlong, mode, c_mcptr, c_conname, c_wcptr, c_infoptr, r_sp);

/* this entry is identical to condition_interpreter_ except that the real switch is turned off, and a stack ptr can be supplied */

	declare r_sp		 ptr;

	realsw = "0"b;
	retsw = "1"b;
	lsp = r_sp;
	go to ci_start;

condition_interpreter_:
     entry (areap, mptr, mlong, mode, c_mcptr, c_conname, c_wcptr, c_infoptr);

/* this entry is just like interpret_condition_ except that the string can be returned */
/* an area is provided for that purpose */

	dcl     (areap, mptr)	 ptr;
	dcl     (mlong, mode)	 fixed bin;
	dcl     (c_mcptr, c_wcptr, c_infoptr)
				 ptr;
	dcl     c_conname		 char (*);
	dcl     based_area		 area based (areap);
	dcl     re_map_mode		 (1:3) fixed bin init (1, 0, 2);

/* These next two bits are really very important. realsw causes this entrypoint
   to actually perform condition semantics, like setting the bit in the
   active_function_error structure to indicate that the message has been printed.
   It will also return null messages for conditions with quiet_restart.
   How it's caller is supposed to know whether restarting is appropriate
   is beyond me.

   retsw, on the other hand, prevents this entry from getting to command
   level. This entrypoint is not very useful, therefore, but its all
   we document. --bim 

  What we really want is an entrypoint with a return string AND realsw off
  and retsw on, which we lack. That might be more useful that this,
  but changing this to do that would be incompatable. */

	realsw = "1"b;
	retsw = "1"b;
	lsp = null ();
ci_start:
	call condition_ ("any_other", blowup_handler_);
	iocb_ptr = null ();				/* until proven otherwise */

	optr = addr (my_string);

/* if there is something on the stack it supercedes args */
/* so we call find_condition_info_ */

	call get_condition_info_code (code);
	if code ^= 0
	then do;					/* strictly caller should not call unless there is an error on the stack, but we try anyway */
		cond_info.version = condition_info_version_1;
		cond_info.mc_ptr = c_mcptr;
		cond_info.wc_ptr = c_wcptr;
		cond_info.info_ptr = c_infoptr;
		string (cond_info.flags) = ""b;
		if cond_info.wc_ptr ^= null ()
		then cond_info.crawlout = "1"b;	/* good guess */
		cond_info.pad2 = ""b;
		cond_info.user_loc_ptr = null ();
		cond_info.pad3 (*) = ""b;
	     end;

	if areap = null
	then iocb_ptr = iox_$error_output;		/* print error message rather than returning it */

	else do;					/* return message in area provided */
		iocb_ptr = null;			/* won't be using switch */
		allocate ostring in (based_area) set (optr);
		mptr = optr;			/* let caller know where message is */
		mlong = 0;			/* initialize in case there is no message to be returned */
	     end;

	if mode < 1 | mode > 3
	then temp_longsw = real_longsw;		/* if not specified, set to current mode */
	else temp_longsw = re_map_mode (mode);		/* be sure mode has correct value for us */
	retsw = "1"b;				/* definitely return */
	flong = 8;				/* indicates which arg is infoptr */

	go to begin_com;

/*  */
add_finish_handler:
     entry (fhandler, xcode);

/* this entry adds the specified entry to a list to be called for the finish condition */

	dcl     xcode		 fixed bin (35);
	dcl     fhandler		 entry ();
	dcl     add_epilogue_handler_	 entry (entry) returns (fixed bin (35));

	xcode = add_epilogue_handler_ (fhandler);
	return;

get_condition_info:
     procedure;
	declare code		 fixed bin (35);
	declare code_flag		 bit (1);
	code_flag = "0"b;
	goto common;

get_condition_info_code:
     entry (a_code);
	declare a_code		 fixed bin (35);
	code_flag = "1"b;
	a_code = 0;

common:
	unspec (cond_info) = ""b;
	cond_info.version = condition_info_version_1;
	cond_info.mc_ptr = null ();
	cond_info.wc_ptr = null ();
	cond_info.info_ptr = null ();
	cond_info.user_loc_ptr = null ();
	pname1, pname2, pname3, tname1, tname2, linfo = "";

	if lsp = null ()
	then lsp = find_condition_frame_ (null ());	/* find the offending frame */
	call find_condition_info_ (lsp, addr (cond_info), code);
	if code ^= 0
	then do;
		if code_flag
		then do;
			a_code = code;
			return;
		     end;
		else go to exit;			/* nothing on stack, we cannot do anything */
	     end;

	condition_info_header_ptr = cond_info.info_ptr;	/* find the bits */
     end get_condition_info;

terminate_process:
     procedure;

	declare terminate_process_	 entry (char (*), ptr);
	declare error_table_$unable_to_do_io
				 fixed bin (35) ext static;

	declare 1 terminate_info	 aligned,
		2 version		 init (0),
		2 status_code	 fixed bin (35);


	terminate_info.status_code = error_table_$unable_to_do_io;
	call terminate_process_ ("fatal_error", addr (terminate_info));
						/* should not return */
     end terminate_process;

%include condition_info;
	dcl     1 cond_info		 aligned like condition_info;
%include condition_info_header;
%page;
%include decode_definition_str;
%page;
%include quit_info;
%page;
%include mrds_se_error_info;
%page;
%include signal_io_info;
%include sub_error_info;
%page;
%include stack_header;
%include stack_frame;
%page;
%include mc;
%page;
%include message_table_entry;
%page;
%include find_pathname_info;
     end dummy;





		    find_pathname_.pl1              11/11/89  1139.1rew 11/11/89  0839.0       43326



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


find_pathname_: proc (locp, strucp, code);

/* This procedure returns pathname information about a given pointer. */
/* coded by M. Weaver  July 1973 */
/* last modified by M. Weaver 27 November 1973 */
/* Modified to use include file and clean up April 81 Benson i Margulies */

	declare (locp, segp, strucp)	 ptr;

	declare (code, ecode)	 fixed bin (35);
	declare error_table_$oldobj	 ext fixed bin (35);
	declare (lng, highct, hcsct, cur_lab) fixed bin;

	declare map		 bit (1) aligned;

	declare temp		 char (6) aligned;
	declare aligned_component_ename character (32) aligned;

	declare (bin, baseno, byte, rel, null, ptr) builtin;

	declare convert_binary_integer_$octal_string entry (fixed bin (35)) returns (char (13) var);
	declare ring0_get_$name	 entry (char (*), char (*), ptr, fixed bin (35));
	declare find_condition_info_	 entry (ptr, ptr, fixed bin (35));
	declare continue_to_signal_	 entry (fixed bin (35));
	declare hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
	declare hcs_$high_low_seg_count entry (fixed bin, fixed bin);
	declare interpret_bind_map_	 entry (ptr, char (32) aligned, fixed bin (18), fixed bin (35));
	declare get_pdir_		 entry () returns (char (168));
	declare any_other		 condition;

%include find_pathname_info;

/* initialize structure so it will always be printable */

	find_pathname_info_ptr = strucp;
	component_ename = "";
	adjusted_offset = "";
	dirname = "";
	gt_char = "";
	real_ename = "";
	pdir_string = "";
	offset_msg = "";
	bin_adjusted_off = 0;
	bin_real_off = bin (rel (locp), 18);
	real_offset = "|" || convert_binary_integer_$octal_string (bin (bin_real_off, 35));

/* see if segment is in ring 0; if so, we can't get name from KST */

	segp = ptr (locp, 0);
	call hcs_$high_low_seg_count (highct, hcsct);	/* find out which segs are in r0 */
	if bin (baseno (segp), 18) <= hcsct then do;
		cur_lab = 1;			/* indicates return loc to handler */
		on any_other call catch;
		call ring0_get_$name (dirname, real_ename, segp, code);
		revert any_other;
		if code ^= 0 then go to ret_segno;	/* return something for name */
		if (dirname ^= "") & (dirname ^= ">") then gt_char = ">";
		return;
	     end;

/* pick up pathname */

	call hcs_$fs_get_path_name (segp, dirname, lng, real_ename, code);
	if code ^= 0 then do;			/* return something for name */
finish (1):
ret_segno:	real_ename = convert_binary_integer_$octal_string (bin (bin (baseno (segp), 18), 35));
		return;
	     end;

/* get component name from bindmap it it exists; be prepared for access fault */

	map = "0"b;				/* indicates have not looked at bind map */
	cur_lab = 2;				/* indicates return loc for handler */
	on any_other call catch;
	call interpret_bind_map_ (locp, aligned_component_ename, bin_adjusted_off, ecode);
	if ecode = 0
	then component_ename = aligned_component_ename;
	map = "1"b;				/* id not fault */
	revert any_other;

/* fill in rest of items */
finish (2):
	if dirname = get_pdir_ () then do;		/* don't print messy string */
		pdir_string = " (in process dir)";
		dirname = "";
	     end;

	if (dirname ^= "") & (dirname ^= ">") then gt_char = ">";

	if (ecode = error_table_$oldobj) | ^map then
	     offset_msg = byte (10 /* NL */) || "(offset is relative to base of segment)";

	if (ecode = 0) & map then do;			/* get compiler error when put all on 1 line */
		temp = convert_binary_integer_$octal_string (bin (bin_adjusted_off, 35));
		adjusted_offset = "|" || temp;
	     end;

	return;

catch: procedure;
%include condition_info;
	declare 1 CI		 aligned like condition_info;

	CI.version = condition_info_version_1;
	on any_other go to finish (cur_lab);
	call find_condition_info_ (null (), addr (CI), (0));
	revert any_other;
	if /* tree */ CI.condition_name ^= "quit"
	then if CI.condition_name ^= "alrm"
	     then if CI.condition_name ^= "cput"
		then if CI.condition_name ^= "storage"
		     then if CI.condition_name ^= "finish"
			then if CI.condition_name ^= "program_interrupt"
			     then go to finish (cur_lab); /* probably access fault */

	call continue_to_signal_ (0);
	return;
     end catch;



     end find_pathname_;




		    get_ppr_.pl1                    11/11/89  1139.1r w 11/11/89  0839.0      137061



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

/* format: style1 */

get_ppr_:
     proc (length_sw, asp, sptr, pname1, pname2, pname3);

/* This procedure returns the name(s) and location(s)  of the procedure(s)
   active when a condition occurred. If the condition occurred in a support 3
   procedure, the name of the most recent non-support procedure will also be returned. */

/* last modified by M. Weaver 23 October 1973 */
/* Modified by B. Margulies for include files and cleanup */
/* Further modified to check the ring brackets of the ppr segment before
   calling object_info on it */
/* Changed to use interpret_link_info.incl.pl1 05/12/83 S. Herbst */

	declare (pname1, pname2, pname3, ptemp)
				 char (500) aligned;
	declare (link_segname, op_seg_name)
				 char (32) aligned;

/* enttypoint is either the file system entryname or the 
   entrypoint name. The first comes from get_entry_name_, the second
   from interpret_link_. Note that interpret_link_ truncates to 32 */

	declare (entryname, entrypoint)
				 char (256) aligned;
	declare lang		 char (8) aligned;

	declare spno		 bit (18) aligned;
	declare find_op		 bit (1) aligned;

	declare length_sw		 fixed bin;
	declare lng		 fixed bin;
	declare segno		 fixed bin (18);
	declare code		 fixed bin (35);

	declare (asp, nsp, use_ptr, last_ptr, sptr)
				 ptr;

	declare (addr, after, baseno, baseptr, before, byte, bin, null, ptr, rel, rtrim, substr)
				 builtin;

	declare ioa_$rsnnl		 entry options (variable);
	declare stack_frame_exit_	 entry (ptr, ptr, ptr, bit (1) unaligned, ptr, char (32) aligned, ptr);

	declare get_entry_name_	 entry (ptr, char (*) aligned, fixed bin (18), char (8) aligned, fixed bin (35));
	declare is_cls_		 entry (ptr) returns (bit (1) aligned);

%include condition_info;
	declare 1 cond_info		 aligned like condition_info based (sptr);

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

%include interpret_link_info;

%include mc;

%include stack_frame;

	pname1, pname2, pname3, ptemp = "";
	sp = asp;
	if cond_info.loc_ptr = null
	then return;

	if cond_info.user_loc_ptr ^= cond_info.loc_ptr
	then do;					/* get info from first non-support frame */
		spno = baseno (sp);			/* get segno of sp */
		nsp = sp;
		do while (baseno (nsp -> stack_frame.prev_sp) = spno);
		     nsp = nsp -> stack_frame.prev_sp;
		     if ^nsp -> stack_frame_flags.support
		     then do;			/* found non-support frame */
			     entryname, link_segname, entrypoint, op_seg_name = "";
			     find_op = "0"b;	/* no operator involved */
			     use_ptr = cond_info.user_loc_ptr;
			     call get_entry_name_ (nsp -> stack_frame.entry_ptr, entryname, segno, lang, code);
			     call check_call_link_ (nsp);
						/* see how frame's proc was called */
			     call put_together_ (pname1);
						/* format full name and offset */
			     if length_sw = 2
			     then go to find_real;	/* print support proc as well */
			     else go to test_crawlout;
			end;
		end;
	     end;

find_real:					/* obtain loc where condition occurred */
	entryname, link_segname, entrypoint = "";
	use_ptr = cond_info.loc_ptr;
	call stack_frame_exit_ (sp, cond_info.mc_ptr, cond_info.wc_ptr, cond_info.crawlout, last_ptr, op_seg_name,
	     addr (situation));

	if (ppr_is_owner | caller_is_owner | ^exists_ppr)
	then do;					/* use owner of stack frame */
		if ^entry_ptr_invalid
		then call get_entry_name_ (sp -> stack_frame.entry_ptr, entryname, segno, lang, code);
		call check_call_link_ (sp);		/* find out how owner was called */
	     end;
	else do;					/* know ppr is not owner */
		if is_cls_ (use_ptr)
		then do;				/* print frame owner anyway--don't want cls */
			use_ptr = last_ptr;
			call get_entry_name_ (sp -> stack_frame.entry_ptr, entryname, segno, lang, code);
		     end;				/* what frame owner last called seems to mislead as much as it helps */
						/*
						   else call check_call_link_(sp -> stack_frame.next_sp);
						   */
	     end;

	if ppr_is_ops
	then find_op = "1"b;			/* print operator name as well */
	else find_op = "0"b;

	call put_together_ (ptemp);			/* format name with offset */
	if (length_sw = 1) | (pname1 = " ")
	then pname1 = ptemp;
	else call ioa_$rsnnl ("^/  (actually by support procedure ^a)", pname2, lng, ptemp);

test_crawlout:
	if cond_info.crawlout
	then do;					/* if possible, get name of real faulting proc */
		if cond_info.mc_ptr ^= null
		then do;				/* have some info from lower ring */
			entryname, link_segname, entrypoint, op_seg_name = "";
			find_op = "0"b;
			scup = addr (cond_info.mc_ptr -> mc.scu (0));
			use_ptr = ptr (baseptr (bin (bin (scup -> scu.ppr.psr, 15), 18)), scup -> scu.ilc);
			call put_together_ (pname3);
		     end;
	     end;
	return;

check_call_link_:
     proc (asp);

/* This internal procedure tries to find out how the owner of the specified
   stack frame was called by looking at the last reference from the preceding
   stack frame */

	declare (asp, csp, callp, entry_ptr, link_ptr)
				 ptr;

	declare frame_flag		 bit (1) aligned;

	declare op_seg		 char (32) aligned;

	declare get_link_ptr_	 entry (ptr, ptr, ptr);
	declare interpret_link_	 entry (ptr, ptr, fixed bin (35));
	declare interpret_op_ptr_	 entry (ptr, ptr, ptr, char (32) aligned, bit (1) aligned);

	declare 1 auto_interpret_link_info aligned like interpret_link_info;


	csp = asp -> stack_frame.prev_sp;		/* get ptr to previous frame */
	if csp = null
	then return;				/* no previous frame */

/* get last location in owner of previous frame */

	call interpret_op_ptr_ (null, csp, callp, op_seg, frame_flag);
	if callp = null
	then callp = ptr (csp -> stack_frame.return_ptr, rel (csp -> stack_frame.return_ptr));
						/* return_ptr may have indicators in modifier */

	call get_link_ptr_ (callp, link_ptr, entry_ptr);

	if link_ptr ^= null
	then do;					/* link name probably more accurate */
		auto_interpret_link_info.version = INTERPRET_LINK_INFO_VERSION_1;

		call interpret_link_ (addr (auto_interpret_link_info), link_ptr, code);
		if code = 0
		then do;				/* use link name */
			link_segname = auto_interpret_link_info.segment_name;
			auto_interpret_link_info.entry_point_name =
			     substr (auto_interpret_link_info.entry_point_name, 2);
		     end;
		return;
	     end;

	if entry_ptr ^= null
	then /* see if we have reference to an entry */
	     call get_entry_name_ (entry_ptr, auto_interpret_link_info.entry_point_name, segno, lang, code);
	return;
     end;

put_together_:
     procedure (pname);

/* This internal procedure finds the rest of the pathname, figures out which of
   of the entry name pieces are appropriate, tries to avoid duplications and
   extra dollar signs, and formats the complete name */

/* If the segname is foo, and the entrypoint is foo$SOMETHING,
   then improve the message removing the second foo.
   foo. Admittedly, ALM or hand construction could make an object
   segment with both foo and foo$foo for entrypoints, but there
   is no reason users should see foo$foo$foo just in case that happens.
   This is a temporary measure until pl1 does multiple segnames right,
   and we can display the segment-entrypoint instead of the 
   entryname-pl1_entry_name_from_symbol_table. 
*/

	declare pname		 char (500) aligned;
	declare r_entrypoint	 char (256) var;
	declare r_entryname		 char (32);	/* fs entryname or segname */
	declare op_name		 char (32) aligned;
	declare op_msg		 char (57) aligned;
	declare line_msg		 char (13);	/* from get_line_no_ */

	declare formatx		 fixed bin;
	declare (add_offset, use_offset)
				 char (7);


	declare ioa_$rsnnl		 entry options (variable);
	declare find_operator_name_	 entry (char (*) aligned, ptr, char (32) aligned);
	declare find_pathname_	 entry (ptr, ptr, fixed bin (35));

	declare 1 name_info		 aligned like find_pathname_info;


	call find_pathname_ (use_ptr, addr (name_info), code);
						/* get pathname and offset pieces */

	if name_info.adjusted_offset ^= ""		/* if bound segment */
	then do;
		add_offset = name_info.real_offset;	/* for msg in () */
		use_offset = name_info.adjusted_offset; /* in component */
	     end;
	else do;
		use_offset = name_info.real_offset;
		add_offset = "";
	     end;

	op_msg = "";				/* assume no operator involved */

	if op_seg_name ^= ""			/* operator */
	then if find_op				/* global from main block -- operator is interesting */
	     then do;				/* condition happened in operator */
		     call find_operator_name_ (op_seg_name, use_ptr, op_name);
		     if op_name ^= ""		/* was an operator we could find */
		     then if substr (op_name, 1, 4) ^= "call"
			then op_msg =
				byte (10 /* NL */) || /* NL */ "(while in operator " || rtrim (op_name)
				|| ")";
		end;

	call get_line_no_ ();			/* try to find source line */

/* figure out which names and format to use */

	formatx = 0;				/* assume no dirname but full seg$entry|offset */

	if entryname ^= ""				/* main block found full description, probably from stack_frame.entry_ptr */
	then r_entrypoint = entryname;		/*  we like that */
	else if entrypoint ^= ""			/* link target entryname in file system */
	then r_entrypoint = entrypoint;		/* that will do */
	else do;					/* no obvious entrypoint description */
		r_entrypoint = "";
		formatx = 1;			/* so skip to format 1, use refname */
	     end;

/* Now, what goes in for a segname?? */
/* put the result in entryname as the putative fs entryname */

	if link_segname ^= ""			/* If a link was involved, use that */
	then r_entryname = link_segname;

/* resort to find_pathname_ */

	else if name_info.component_ename ^= ""		/* bound seg, show both component name and entryname */
	then r_entryname = name_info.component_ename;
	else do;
		r_entryname = "";
		/*** skip to one-entryname formats */
		formatx = formatx + 2;		/* 0, 1 go to 2, 3 */
	     end;

	if formatx = 3				/* we know all we are gonna know */
	then go to format (3);


	if formatx ^= 0
	then if (r_entryname = r_entrypoint)
	     then formatx = formatx + 1;

	if formatx < 2				/* r_entryname is in use */
	then if name_info.real_ename = r_entryname	/* but its the same as the find_pathname_ entryname, so punt it */
	     then formatx = formatx + 2;
	if formatx = 2
	then if (name_info.real_ename = r_entrypoint) /* redundant  */ | (r_entrypoint = "")
						/* unknown */
	     then formatx = 3;

	go to format (formatx);

format (0):

/* r_entryname$r_entrypoint_name|offset (line #)
   dirname>bound_seg_entryname|offset in pdir
   in operator operator name */

	if r_entryname = before (r_entrypoint, "$")
	then r_entrypoint = after (r_entrypoint, "$");

	if length_sw ^= 2				/* Dont want super-verbose */
	then add_offset = "";
	call ioa_$rsnnl ("^a$^a^a ^a^/(^a^a^a^a^a)^a^a", pname, lng, r_entryname, r_entrypoint, use_offset, line_msg,
	     name_info.dirname, name_info.gt_char, name_info.real_ename, add_offset, name_info.pdir_string, op_msg,
	     offset_msg);
	return;

format (1):

/* entryname|adj_offset (dname>real_entryname|real_off) */


	if length_sw ^= 2
	then add_offset = "";
	call ioa_$rsnnl ("^a^a ^a^/(^a^a^a^a^a) ^a^a", pname, lng, r_entryname, use_offset, line_msg, name_info.dirname,
	     name_info.gt_char, name_info.real_ename, add_offset, name_info.pdir_string, op_msg, offset_msg);
	return;

format (2):

/* dname>real_entryname$entrypoint_name|adj_offset */

	if name_info.real_ename = before (r_entrypoint, "$")
	then r_entrypoint = after (r_entrypoint, "$");

	call ioa_$rsnnl ("^a^a^a$^a^a^a ^a^a^a", pname, lng, name_info.dirname, name_info.gt_char, name_info.real_ename,
	     r_entrypoint, use_offset, name_info.pdir_string, line_msg, op_msg, offset_msg);
	return;

format (3):

/* dname>real_entryname|offset */

	call ioa_$rsnnl ("^a^a^a^a^a ^a^a^a", pname, lng, name_info.dirname, name_info.gt_char,
	     name_info.real_ename, use_offset, name_info.pdir_string, line_msg, op_msg, offset_msg);
	return;

get_line_no_:
     procedure;

/* This procedure finds the source line number corresponding to a given location */

	dcl     (segp, symbp)	 ptr;

	dcl     (start, num, line_no, offset)
				 fixed bin (18);
	dcl     bitcnt		 fixed bin (24);
	declare mode		 fixed bin (5);
	dcl     code		 fixed bin (35);

	dcl     std		 bit (1) aligned;

	dcl     (addr, addrel, baseptr, bin, bit, ptr, rel)
				 builtin;

	dcl     component_info_$offset entry (ptr, fixed bin (18), ptr, fixed bin (35));
	dcl     object_info_$brief	 entry (ptr, fixed bin (24), ptr, fixed bin (35));
	dcl     (
	        stu_$get_line_no,
	        stu_$get_runtime_line_no
	        )			 entry (ptr, fixed bin (18), fixed bin (18), fixed bin (18), fixed bin (18));



	dcl     ioa_$rsnnl		 entry options (variable);
	declare hcs_$status_mins	 entry (pointer, fixed bin (2), fixed bin (24), fixed bin (35));
	declare hcs_$fs_get_mode	 entry (pointer, fixed bin (5), fixed bin (35));

%include access_mode_values;
/* Include file symbol_header follows */
%include symbol_header;
%include component_info;

	dcl     1 oi		 aligned like object_info;

%include object_info;


	line_msg = "";
	segp = baseptr (baseno (use_ptr));		/* get ptr to beginning of seg */
	offset = bin (rel (use_ptr), 18);		/* extract offset of location */

/* First see if we have access to touch the segment AT ALL */

	call hcs_$fs_get_mode (segp, mode, code);
	if code ^= 0 /* Should not happen, but .. */
	     | ((bit (mode, 5) & bit (R_ACCESS_BIN, 5)) = "00000"b) /* no R */
	then return;

/* first see if seg is bound; if so use only component info */

	call component_info_$offset (segp, offset, addr (ci), code);
	if code = 0
	then do;					/* use info for component */
		symbp = ci.symb_start;
		std = ci.standard;
		go to call_stu;
	     end;

/* segment is not bound; see if seg itself has statement map */

	call hcs_$status_mins (segp, (0), bitcnt, code);
	if code ^= 0
	then return;

	oi.version_number = object_info_version_2;
	call object_info_$brief (segp, bitcnt, addr (oi), code);
	if code ^= 0
	then return;				/* no symbol section so no map */

	symbp = oi.symbp;
	std = oi.format.standard;

call_stu:
	start = -1;
	if std
	then call stu_$get_runtime_line_no (symbp, offset, start, num, line_no);
	else if symbp -> symbol_header.root
	then call stu_$get_line_no (addrel (symbp, symbp -> symbol_header.root), offset, start, num, line_no);

	if start > -1
	then call ioa_$rsnnl ("(line ^d)", line_msg, num, line_no);

	return;

     end get_line_no_;

     end put_together_;

%include find_pathname_info;
     end get_ppr_;




		    get_tpr_.pl1                    11/11/89  1139.1rew 11/11/89  0839.0       74943



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

/* Modified April 1981 by B. Margulies for quiet_restart, null_pointer,
   include file for find_pathname_info */
/* Further modified in August to fix the segfault-garbage bug */
/* Changed to use interpret_link_info.incl.pl1 05/12/83 S. Herbst */
/* format: style4,insnl,delnl */

get_tpr_:
     proc (asp, sptr, a_mtep, tname1, tname2);

dcl  a_mtep ptr;
dcl  (tname1, tname2) char (500) aligned;
dcl  ptemp character (500) aligned;
dcl  ename char (256) aligned;
dcl  op_seg_name char (32) aligned;
dcl  lang char (8) aligned;

dcl  (asp, tpr, sptr, sp, last_ptr, linkp, entryp) ptr;

dcl  lng fixed bin;
dcl  segno fixed bin (18);
dcl  code fixed bin (35);

/* Entries */

dcl  find_pathname_ entry (ptr, ptr, fixed bin (35));
dcl  (
     ioa_$rsnnl
     ) entry options (variable);
dcl  stack_frame_exit_ entry (ptr, ptr, ptr, bit (1), ptr, char (32) aligned, ptr);
dcl  get_link_ptr_ entry (ptr, ptr, ptr);
dcl  get_entry_name_ entry (ptr, char (*) aligned, fixed bin (18), char (8) aligned, fixed bin (35));
dcl  interpret_link_ entry (ptr, ptr, fixed bin (35));

dcl  (addr, baseno, baseptr, bin, hbound, lbound, null, ptr, substr) builtin;

%include condition_info;
declare  1 cond_info aligned like condition_info based (sptr);

%include find_pathname_info;
declare  1 name_info aligned like find_pathname_info;

%include interpret_link_info;

dcl 1 auto_interpret_link_info aligned like interpret_link_info;

dcl  1 situation aligned,				/* structure from stack_frame_exit_ */
       (
       2 bad_frame,
       2 exists_ppr,
       2 ppr_is_owner,
       2 ppr_is_ops,
       2 caller_is_owner,
       2 entry_ptr_invalid,
       2 ret_ptr_is_ops
       ) bit (1) unal,
       2 pad bit (29) unal;

	tname1, tname2, ptemp = "";
	sp = asp;
	mtep = a_mtep;

/* get referenced proc name if relevant and if it exists */

	if mte.with_tpr
	then if cond_info.mc_ptr ^= null then do;
		scup = addr (cond_info.mc_ptr -> mc.scu (0));
		tpr = ptr (baseptr (bin (bin (scup -> scu.tpr.tsr, 15), 18)), scup -> scu.ca);
		if cond_info.crawlout then do;	/* can't do anything fancy */
		     call find_pathname_ (tpr, addr (name_info), code);
		     ename = "";			/* not used here */
		     call format_name (tname1);
		end;
		else call try (cond_info.mc_ptr, tname1);
						/* see if we can get a better name from a link */
	     end;

	if cond_info.crawlout then do;		/* get last proc referenced in current ring */
	     if cond_info.wc_ptr ^= null
	     then call try (cond_info.wc_ptr, ptemp);
	     else do;				/* see if proc was called through link */
		call stack_frame_exit_ (sp, null, null, cond_info.crawlout, last_ptr, op_seg_name, addr (situation));
		if last_ptr = null
		then return;			/* don't know where frame was left */
		ename = "";
		call get_link_ptr_ (last_ptr, linkp, entryp);
		if linkp ^= null then do;		/* found a link */

		     auto_interpret_link_info.version = INTERPRET_LINK_INFO_VERSION_1;

		     call interpret_link_ (addr (auto_interpret_link_info), linkp, code);
						/* get name of link target */
		     if code = 0
		     then call ioa_$rsnnl ("^a^a^a^a^a", ename, lng, auto_interpret_link_info.segment_name,
			auto_interpret_link_info.entry_point_name, auto_interpret_link_info.expression,
			auto_interpret_link_info.modifier, auto_interpret_link_info.trap);
		end;
		else if entryp ^= null		/* text-text transfer; highly unlikely */
		then call get_entry_name_ (entryp, ename, segno, lang, code);

		ptemp = ename;
	     end;

	     if ptemp ^= ""
	     then tname2 = "
referencing " || ptemp;
	end;

	return;

format_name:
     proc (tname);

dcl  tname char (500) aligned;

	if name_info.component_ename ^= "" then do;	/* use name from bindmap */
	     call ioa_$rsnnl ("^a^a^a (^a^a^a^a^a)^a", tname, lng, name_info.component_ename, ename,
		name_info.adjusted_offset, name_info.dirname, name_info.gt_char, name_info.real_ename,
		name_info.real_offset, name_info.pdir_string, name_info.offset_msg);
	end;

	else do;
	     call ioa_$rsnnl ("^a^a^a^a^a^a^a", tname, lng, name_info.dirname, name_info.gt_char, name_info.real_ename,
		ename, name_info.real_offset, name_info.pdir_string, name_info.offset_msg);
	end;

	return;
     end;

try:
     proc (mp, tname);

dcl  no_name bit (1) aligned;

dcl  mp ptr;

dcl  error_table_$invalidsegno ext fixed bin (35);
dcl  i fixed bin;
dcl  op_code bit (10) aligned;
dcl  tname char (500) aligned;

dcl  tr_insts (35) bit (10) aligned
	init ("1110010110"b, "1100011000"b, "1100011010"b, "1100001000"b, "1100000100"b, "1100000010"b, "1100011110"b,
	"1100001010"b, "1100000110"b, "1110010000"b, "1100000000"b, "0101110000"b, "0101110010"b, "0101110100"b,
	"0101110110"b, "1101110000"b, "1101110010"b, "1101110100"b, "1101110110"b, "1110011010"b, "1110000000"b,
	"1110000010"b, "1110000100"b, "1110000110"b, "1110001000"b, "1110001010"b, "1110001100"b, "1110001110"b,
	"1100001110"b, "1100001100"b, "1100000011"b, "1100001001"b, "1100001011"b, "1100001101"b, "1100000001"b)
	internal static options (constant);

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


%include db_inst;

/**/
	ename = "";
	no_name = "0"b;
	scup = addr (mp -> mc.scu (0));
	tpr = ptr (baseptr (bin (bin (scup -> scu.tpr.tsr, 15), 18)), scup -> scu.ca);

	if mte.segferr & (mp -> mc.errcode = error_table_$invalidsegno) then do;
						/* symbolic name no longer available */
print_ptr:
	     call ioa_$rsnnl ("^p", tname, lng, tpr);
	     no_name = "1"b;
	end;

	else do;					/* get basic name info */
	     call find_pathname_ (tpr, addr (name_info), code);
	     if code ^= 0
	     then go to print_ptr;
	end;

/* see if an inter-segment transfer was involved to see if it's worth looking for a link */

	if scup -> scu.ppr.psr = scup -> scu.tpr.tsr
	then go to simple;				/* same segment */

	op_code = addr (scup -> scux.instr (bin (substr (scup -> scu.ilc, 18, 1), 1))) -> instr.opcode;
	do i = lbound (tr_insts, 1) to hbound (tr_insts, 1);
						/* see if a transfer instruction was being executed */
	     if op_code = tr_insts (i)
	     then if ^is_cls_ (cond_info.loc_ptr) then do;/* cond_info.loc_ptr might be near link ref */
		     call get_link_ptr_ (cond_info.loc_ptr, linkp, entryp);
		     if entryp = null
		     then go to simple;		/* no snapped link */
		     call get_entry_name_ (entryp, ename, segno, lang, code);
						/* this name should be good enough */
		     if code ^= 0
		     then go to simple;		/* don't bother looking for unsnapped link */
		     if segno ^= bin (baseno (tpr), 18)
		     then ename = "";		/* not same seg */
		     else if no_name
		     then go to add;		/* can't do normal formatting */
		     else do;			/* print name if not redundant */
			if name_info.component_ename ^= "" & ename = name_info.component_ename
			then ename = "";
			else if name_info.real_ename ^= "" & ename = name_info.real_ename
			then ename = "";
			else ename = "$" || ename;
		     end;
		end;
	end;

simple:
	if no_name
	then return;				/* have nothing to add */
	call format_name (tname);

	return;

add:						/* could not find real symbolic name  but found a name heuristically */
	if linkp ^= null then do;			/* if possible, replace ename with names from link */

	     auto_interpret_link_info.version = INTERPRET_LINK_INFO_VERSION_1;

	     call interpret_link_ (addr (auto_interpret_link_info), linkp, code);
	     if code ^= 0
	     then call ioa_$rsnnl ("^a^a", ename, lng, auto_interpret_link_info.segment_name,
		auto_interpret_link_info.entry_point_name);
	end;
	call ioa_$rsnnl ("^a^/(probably referencing ^a)", tname, lng, tname, ename);

	return;
     end;

%include mc;
%include message_table_entry;
     end get_tpr_;




		    interpret_info_struc_.pl1       11/11/89  1139.1rew 11/11/89  0839.0       80244



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


/* format: style2 */
interpret_info_struc_:
     procedure (conname, infoptr, linfo, retsw, no_restart, realsw, lngsw);


/* This procedure is used by default_error_handler_ to interpret the info
   structures passed with software signalled conditions */
/* Last modified by M. Weaver 2 December 1973 */
/* Changed 25 January 1979 B. Margulies to set print_sw on af errors */
/* Modified: 8 August 1980 by G. Palter to special case the code error_table_$active_function for the
	     active_function_error condition */
/* Modified: 10 September 1980 by G. Palter to rtrim command name in error_table_$active_function message */
/* Modified April 1981 by B. Margulies for quiet_restart and new includes */
/* Modified for program_interrupt BIM July 1981 */
/* Modified for quit_info E. N. Kittlitz December 1981 */
/* Modified to notice pl1-signal-statement info structures on non-pl1 */
/*          conditions 4/82 BIM */
/* Modified for malformed_list_template_entry_ November 29, 1984 by M. Weaver */

	dcl     conname		 char (32);	/* condition name */
	dcl     linfo		 char (500) var;	/* resulting info string */
	dcl     temp		 char (100) aligned;
	dcl     shortinfo		 char (8) aligned;
	dcl     temp2		 char (150) var;
	dcl     name		 char (afe_info.name_lth) based (afe_info.name_ptr);
						/* for active_function_error caller */
	dcl     errmsg		 char (afe_info.errmess_lth) based (afe_info.errmess_ptr);
						/* for new afe message */
          dcl     pl1_signalled_this     bit (1);
	dcl     tempchar		 char (1) aligned;
	dcl     (infoptr, lp)	 ptr;
	dcl     (lng, lngsw)	 fixed bin;
	dcl     toncode		 fixed bin (35);
	dcl     lv		 (4) fixed bin (35) based (lp);

	dcl     (retsw, realsw, no_restart)
				 bit (1) aligned;

	dcl     error_table_$active_function
				 fixed binary (35) external;

	dcl     (addr, rtrim, substr)	 builtin;
	dcl     (
	        ioa_$rs,
	        ioa_$ioa_stream
	        )			 ext entry options (variable);
	dcl     convert_status_code_	 ext entry (fixed bin (35), char (8) aligned, char (100) aligned);
	dcl     interpret_oncode_	 entry (fixed bin (35), char (150) var);

%include condition_info_header;

	dcl     1 cond_header	 aligned like condition_info_header based (infoptr);

	dcl     1 unwind_err	 aligned based (infoptr),
		2 header		 aligned like condition_info_header,
		2 target_label	 label;


%include com_af_error_info;
	dcl     1 afe_info		 like com_af_error_info based (infoptr);

%include io_error_info;
	dcl     1 io_err_info	 aligned like io_error_info based (infoptr);
%include sub_error_info;
	dcl     1 sub_error_struc	 aligned like sub_error_info based (infoptr);

%include pl1_info;
	dcl     1 pl1_info_struc	 aligned like pl1_info based (infoptr);

%include program_interrupt_info;
	dcl     1 pi_info		 aligned like program_interrupt_info based (infoptr);

%include quit_info;
	dcl     1 quit_info_struc	 aligned like quit_info based (infoptr);

%include malformed_list_template;

	dcl     1 template_info_struc	 aligned like template_info based (infoptr);



	pl1_signalled_this = pl1_info_struc.id = "pliocond";

	if cond_header.quiet_restart
	then do;
		retsw = "1"b;			/* restart the condition */
		return;				/* and that is all we do */
	     end;

	if ^retsw
	then retsw = cond_header.action_flags.default_restart;
	no_restart = cond_header.action_flags.cant_restart;

	if ^pl1_signalled_this
	then do;

		if conname = "sub_error_"
		then sub_error_struc.retval = 0;

		if conname = program_interrupt_condition_name
		then do;
			retsw = "1"b;
			pi_info.default_handler_restarted_this_signal = "1"b;
			return;			/* protocol is satisfied */
		     end;


		if conname = "active_function_error"
		then do;
			if realsw
			then call ioa_$ioa_stream ("error_output", errmsg);
			afe_info.print_sw = "0"b;	/* error message causing error must
						   be printed first, but only once */

			if afe_info.status_code = error_table_$active_function
			then linfo = "Error:  Attempt to invoke command " || rtrim (name)
				|| " as an active function." || byte (10) /* NL */;
			else linfo = "Error:  Bad call to active function " || rtrim (name) || byte (10) /* NL */;
						/* now fill in info string itself */
		     end;

		else if conname = "io_error"
		then do;
			call convert_status_code_ (io_err_info.status.code, shortinfo, temp);

			if shortinfo = (8)"x"
			then call ioa_$rs (" Cannot do I/O on switch ^a.^/Hardware status = ^w ^w", linfo, lng,
				io_err_info.switch_name, io_err_info.status.code,
				io_err_info.status.IOS_status_bits);

			else call ioa_$rs (" Cannot do I/O on stream ^a.^/^a", linfo, lng, io_err_info.switch_name,
				temp);

		     end;

		else if conname = "unwinder_error"
		then do;
			if lngsw = 1
			then linfo = unwind_err.info_string;
			else do;
				lp = addr (unwind_err.target_label);
						/* want to print label in octal */
				call ioa_$rs ("^a^/Label is:  ^w ^w  ^w ^w", linfo, lng, unwind_err.info_string,
				     lp -> lv (1), lp -> lv (2), lp -> lv (3), lp -> lv (4));
			     end;
		     end;

		else if conname = "quit"
		then do;				/* everything is done by default_error_handler_ */
		     end;

		else if conname = "malformed_list_template_entry_"
		then call ioa_$rs ("A compiler has generated incorrect list template initialization^/for an array or external variable.^/The template is at ^p.   The malformed entry is at ^p.",
		     linfo, lng, template_info_struc.template_p, 
		     template_info_struc.template_error_p);

		else do;				/* get what we can from structure header */
			if cond_header.status_code = 0
			then linfo = cond_header.info_string;
			else do;
				call convert_status_code_ (cond_header.status_code, shortinfo, temp);
				call ioa_$rs ("^a ^a", linfo, lng, temp, cond_header.info_string);
			     end;
		     end;
	     end;
	else do;					/* have a pl1 condition */
		if pl1_info_struc.content_flags.onfile_sw
		then call ioa_$rs ("occurred while doing I/O on file ^a", linfo, lng, pl1_info_struc.onfile);

		if pl1_info_struc.content_flags.onkey_sw
		then /* have a key to print */
		     if conname = "endfile" | conname = "transmit" | conname = "record" | conname = "key"
		     then call ioa_$rs ("^aonkey = ^a", linfo, lng, linfo, pl1_info_struc.onkey_onfield);

		if conname = "conversion"
		then if pl1_info_struc.content_flags.onsource_sw
		     then do;
			     if pl1_info_struc.content_flags.onchar_sw
			     then do;		/* print both onsource and onchar */
				     tempchar = substr (pl1_info_struc.onsource, pl1_info_struc.oncharindex, 1);
						/* must copy to get correct descriptor */
				     call ioa_$rs ("^aonsource = ""^a"", onchar = ""^1a""", linfo, lng, linfo,
					pl1_info_struc.onsource, tempchar);
				end;
			     else call ioa_$rs ("^aonsource = ""^a""", linfo, lng, linfo, pl1_info_struc.onsource);
			end;

		if conname = "name"
		then if pl1_info_struc.content_flags.onfield_sw
		     then call ioa_$rs ("^aonfield = ^a", linfo, lng, linfo, pl1_info_struc.onkey_onfield);

		if pl1_info_struc.content_flags.oncode_sw
		then do;
			toncode = pl1_info_struc.oncode;
			if toncode ^= 0 & toncode ^= 700
			then do;			/* determine source */
				if conname = "error" | conname = "conversion" | conname = "size"
				     | conname = "record" | conname = "key" | conname = "undefinedfile"
				then do;		/* want to print oncode */
					call interpret_oncode_ (toncode, temp2);
					linfo = linfo || temp2;
				     end;
			     end;
		     end;
		if linfo ^= ""
		then if substr (linfo, 1, 1) ^= byte (10)
						/* NL */
		     then linfo = byte (10) /* NL */ || linfo;
						/* don't add double newline */
	     end;

	return;

/*  */
no_message:
     entry (conname, infoptr);

/* this entry makes use of info struc but does not format message */

	dcl     based_ptrs		 (100) ptr based;
	dcl     based_bins		 (100) fixed bin (15) aligned based;
	dcl     based_file		 file variable based;

	if conname = "endpage"
	then if pl1_info_struc.id = "pliocond"
	     then if pl1_info_struc.content_flags.file_ptr_sw
		then do;
			if pl1_info_struc.content_flags.v1_sw
			then pl1_info_struc.file_ptr -> based_ptrs (2) -> based_bins (13) = 1;
			else put page file (pl1_info_struc.file_ptr -> based_file);
		     end;

	return;
     end interpret_info_struc_;




		    interpret_oncode_.pl1           11/11/89  1139.1rew 11/11/89  0839.0       24876



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


interpret_oncode_:	proc(on_code, string);

/* This procedure returns the message corresponding to a given pl1 oncode value */
/* it references a list made up from P. Belmont's 3 lists */
/* coded  by M.B. Weaver 73/5/3 */
/* modified 77/03/08 by M. Weaver to increase size of oncode_messages_ */

declare	(lng, i, j, k) fixed bin;
declare	on_code fixed bin(35);
declare	(index, substr) builtin;
declare	nl char(1) int static init("
");
declare	nlnl char(2) aligned int static init("

");
declare	string char(150) var;
declare	oncode_messages_$ char(65536) ext aligned;
declare	oncode_message_string char (om_length) based (addr (oncode_messages_$));
declare	om_length fixed bin static init (65536);
declare	first bit (1) aligned static init ("1"b);
declare	ioa_$rs entry options(variable);
declare	convert_binary_integer_$decimal_string entry(fixed bin(35)) returns(char(12) var);

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

/* a typical message in oncode_messages_ follows:

205 [CTN]Character other than sign or digit follows
"e" of exponent field.

Messages are located by the oncode value and delimited by a double new-line.
The name in [] indicates the module signalling the error.
*/

	if first then do;				/* find real length of oncode_messages_$ */
	     om_length = index (oncode_messages_$, nl || "[END]");
	     first = "0"b;
	end;

	/*  find beginning of message */

	i = index(oncode_message_string, nl || convert_binary_integer_$decimal_string(on_code));

	if i = 0 then go to error_return;

	/* find length of message */

	j = index(substr(oncode_message_string, i, 300), nlnl);
	if j = 0 then go to error_return;

	/* find beginning of relevant part of message */

	k = index(substr(oncode_message_string, i, j), "]");
	if k = 0 then k = 1;			/* print whole message anyway */

	/* fill in string argument */

	string = substr(oncode_message_string, i+k, j - k - 1);

	return;

error_return:				/* let users know so it will be reported */
	call ioa_$rs("There is no message for oncode = ^d. Contact pl1 maintainence.",
	string, lng, on_code);

	return;

	end;




		    linkage_error_.pl1              11/11/89  1139.1rew 11/11/89  0839.1       93942



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * 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-06-24,DGHowe), approve(86-06-24,MCR7420), audit(86-11-12,Zwick),
     install(86-11-20,MR12.0-1222):
     special cased error code invalid_ptr_target to get a usefull message.
                                                   END HISTORY COMMENTS */


linkage_error_: proc (mcptr, lngsw, lsp, sptr, pname1, pname2, optr, lng);

/* last modified by M. Weaver 21 August 1970 */
/* last modified by M. Weaver 17 October 1973 */
/* modified 10/76 by M. Weaver  to improve messages for types 1 and 5 */
/* modified 11/77 by M. Weaver to improve messages for ext variables and ec = bigger_ext_variable in particular */
/* modified 21 Feb 80 JRDavis MCR 4347 remove red-shift */
/* Modified 831006 BIM to change call from hcs_$set_ext_variable to just set_ext_variable_ */

/* parameters */

	dcl     mcptr		 ptr parameter;	/* ptr to machine conditions */
	dcl     lngsw		 fixed bin parameter;
	dcl     lsp		 ptr parameter;	/* ptr to condition frame */
	dcl     sptr		 ptr parameter;	/* ptr to condition info structure */
	dcl     (pname1,
	        pname2)		 char (500) aligned parameter;
	dcl     optr		 ptr parameter;	/* ptr to output string */
	dcl     lng		 fixed bin (17) parameter;


/* automatic */

	dcl     (buf1, buf4)	 char (100) aligned automatic;
	dcl     (buf2, buf3)	 char (200) varying automatic;
	dcl     code		 fixed bin (35) automatic;
	dcl     def_section_ptr	 ptr automatic;	/* ptr to defs */
	dcl     dirname		 char (168) automatic;
	dcl     ec		 fixed bin (35) automatic; /* errcode from linker */
	dcl     exp		 char (12) var automatic; /* value of expression */
	dcl     entname		 char (32) automatic;
	dcl     ext_var_name	 char (65) automatic;
	dcl     ext_ptr		 ptr automatic;	/* ptr to symbol */
	dcl     found_sw		 bit (1) aligned automatic;
	dcl     header_ptr		 ptr automatic;	/* ptr to linkage block header */
	dcl     (i, tlng)		 fixed bin (17) automatic;
	dcl     linfo		 char (100) aligned
				 automatic;	/* for convert_status_code_ */
	dcl     link_ptr		 ptr automatic;	/* pointer to link */
	dcl     (n2, o2)		 varying char (32)
				 aligned automatic; /* printable names */
	dcl     nchars		 fixed bin (17) automatic; /* number of chars in name */
	dcl     nl		 char (1) aligned automatic;
	dcl     node_ptr		 ptr automatic;
	dcl     p			 ptr automatic;
	dcl     pname3		 char (500) aligned automatic;
	dcl     segptr		 ptr automatic;	/* ptr to seg name */
	dcl     sinfo		 char (8) aligned automatic;
	dcl     type		 fixed bin (17) automatic; /* type of link */
	dcl     texp		 char (12) aligned automatic;

/* constants */

	dcl     New_line		 char (1) static options (constant) init ("
");


/* external variables */

	dcl     (error_table_$bad_link_type,
	        error_table_$no_ext_sym,
	        error_table_$bad_entry_point_name,
	        error_table_$bigger_ext_variable,
	        error_table_$bad_self_ref,
	        error_table_$invalid_ptr_target)  ext fixed bin (35) aligned;

/* external entries */

	dcl     get_ppr_		 entry (fixed bin, ptr, ptr,
				 char (500) aligned, char (500) aligned,
				 char (500) aligned);
	dcl     (ioa_$rs, ioa_$rsnnl)	 ext entry options (variable);
	dcl     set_ext_variable_	 entry (char (*), ptr, ptr,
				 bit (1) aligned, ptr, fixed bin (35));
	dcl     hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*),
				 fixed bin (35));
	dcl     convert_status_code_	 ext entry (fixed bin (35),
				 char (8) aligned, char (100) aligned);

/* builtins */

	dcl     (addr, addrel, baseptr, bin, fixed, index,
	        length, null, ptr, substr) builtin;

/* based */

	dcl     ostring		 char (1000) aligned based (optr);

	dcl     1 word		 based (p),	/* access structure for pickup */
		2 (one, two)	 fixed bin (35);

	dcl     1 init_info		 aligned based,
		2 length		 fixed bin,
		2 type		 fixed bin;



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

	linfo, nl, buf1, buf4 = " ";			/* initialize */
	n2, o2, buf2, buf3 = "";
	code = 0;

	scup = addr (mcptr -> mc.scu (0));		/* get ptr to scu; use real conditions */

	ec = mcptr -> mc.errcode;			/* extract linker code */

/* obtain ptr to link */

	link_ptr = ptr (baseptr (fixed (scup -> scu.tsr, 15)), scup -> scu.ca);
	if ec = error_table_$bad_entry_point_name then do;
ugh:		call ioa_$rsnnl ("^/Link is ^w  ^w at ^p.", buf1,
		     tlng, link_ptr -> word.one,
		     link_ptr -> word.two, link_ptr);
		go to exit;
	     end;

	if link_ptr -> object_link.tag ^= FAULT_TAG_2 then
	     go to ugh;

/* get pointers to the information concerning the link. ie.
   expression word, type_pair and link type
*/

	header_ptr = addrel (link_ptr, link_ptr -> object_link.header_relp);
	def_section_ptr = header_ptr -> linkage_header.def_ptr;
	exp_ptr = addrel (def_section_ptr, link_ptr -> object_link.expression_relp);
	type_ptr = addrel (def_section_ptr, exp_ptr -> exp_word.type_relp);
	type = type_ptr -> type_pair.type;

	if ec = error_table_$bad_link_type then do;
		call ioa_$rsnnl ("^/Illegal type number in type pair block.  Type = ^o.", buf1, tlng, type);
		go to last_exit;
	     end;


/* check the trap information it is either a pointer to a trap or
   it specifies the class information
*/

	if type_ptr -> type_pair.trap_relp ^= 0 then
	     if type = LINK_CREATE_IF_NOT_FOUND then
		call ioa_$rsnnl ("^/(with a create-if-not-found link)", buf1, tlng);

	if exp_ptr -> exp_word.expression ^= 0 then do;
		call ioa_$rsnnl ("^o", texp, tlng, exp_ptr -> exp_word.expression);
		exp = substr (texp, 1, lng);
	     end;
	else exp = "";

/* get the symbolic name of the link */

	if (type = LINK_SELF_BASE) | (type = LINK_SELF_OFFSETNAME) then do;
		if ec ^= error_table_$bad_self_ref
		then n2 = SYMBOLIC_SECTION_NAMES (type_ptr -> type_pair.segname_relp);
		else n2 = "*";
		if (type = LINK_SELF_OFFSETNAME) then
		     goto noent;
		else goto noext;
	     end;

	if (type = LINK_OBSOLETE_2) then do;		/* ITB link? */
		if ec = error_table_$no_ext_sym then do;
			call ioa_$rsnnl ("base ^o", n2, lng,
			     type_ptr -> type_pair.segname_relp);
			go to noent;
		     end;
		go to exit;
	     end;

/* get the link name information eg. either x$y or y or y|x */

	segptr = addrel (def_section_ptr, type_ptr -> type_pair.segname_relp);
	nchars = bin (segptr -> acc_string.count, 9);
	n2 = substr (segptr -> acc_string.string, 1, nchars);
	if (type = LINK_REFNAME_BASE) then do;		/* <seg>|exp,m ? */
noext:		if exp = "" then o2 = "0";
		else o2 = exp;
	     end;
	else do;
noent:		ext_ptr = addrel (def_section_ptr, type_ptr -> type_pair.offsetname_relp);
		nchars = fixed (ext_ptr -> acc_string.count, 9);
		if nchars = 0 then do;
			if (type = LINK_CREATE_IF_NOT_FOUND) then
			     o2 = "";
			else o2 = "0";
		     end;
		else o2 = substr (ext_ptr -> acc_string.string, 1, nchars);
		if exp ^= "" then o2 = o2 || "+" || exp;
	     end;

	call ioa_$rsnnl ("^/referencing ^a|^a", buf2, tlng, n2, o2);

/* get information concerning the initialization information 
   of *system *heap or create if not found links
 */

	if (type = LINK_SELF_OFFSETNAME) |
	     (type = LINK_CREATE_IF_NOT_FOUND) then do;
		ext_var_name = " ";
		if (type = LINK_SELF_OFFSETNAME) then do;
			if (type_ptr -> type_pair.segname_relp = CLASS_SYSTEM) |
			     (type_ptr -> type_pair.segname_relp = CLASS_HEAP)
			then ext_var_name = o2;
		     end;
		else do;				/* create if not found */
			if n2 = "stat_" then ext_var_name = o2;
			else if o2 = "" then do;	/* see if we have fortran common block */
				i = index (n2, ".com");
				if i = (length (n2) - 3) then do;
					ext_var_name = substr (n2, 1, i - 1);
					if ext_var_name = "b_" then ext_var_name = "blnk*com";
				     end;
			     end;
			else if n2 = "cobol_fsb_" then ext_var_name = n2 || o2;

			if ext_var_name ^= " " then buf1 = " "; /* create-if-not-found now irrelevant */
		     end;

		if ext_var_name ^= " "
		then buf2 = New_line || "referencing external variable or common block " || ext_var_name;
	     end;

	if ec = error_table_$bigger_ext_variable then do; /* print out more useful information */
		call ioa_$rsnnl ("^a (^d words)", buf2, tlng, buf2,
		     addrel (def_section_ptr, type_ptr -> type_pair.trap_relp)
		     -> init_info.length);

		buf4 = New_line || "Type ""help external_storage.gi"" for more information.";

		call set_ext_variable_ (ext_var_name, null,
		     ptr (addr (node_ptr), 0), found_sw, node_ptr, code);

		if code = 0 then if found_sw then do;
			     if node_ptr -> variable_node.init_ptr ^= null then do;
				     call hcs_$fs_get_path_name (ptr (node_ptr -> variable_node.init_ptr, 0), dirname, tlng, entname, code);
				     if code = 0 then call ioa_$rsnnl ("^/Original allocation (^d words) was by ^a>^a.",
					     buf3, tlng, node_ptr -> variable_node.init_ptr -> init_info.length, dirname, entname);
				     else call ioa_$rsnnl ("^/Original allocation was ^d words.", buf3, tlng,
					     node_ptr -> variable_node.init_ptr -> init_info.length);
				end;
			end;
	     end;
	else if ec = error_table_$invalid_ptr_target then
	     do;
		if ext_var_name ^= " "
		then buf2 = New_line || "referencing external variable " ||
			ext_var_name;
		buf3, buf4 = "";
	     end;


exit:	call convert_status_code_ (ec, sinfo, linfo);	/* get message */
	nl = "
";

last_exit:					/* format the information */
	call get_ppr_ (lngsw, lsp, sptr, pname1, pname2, pname3);
	call ioa_$rs ("Error:  Linkage error by ^a^a^a^a^a^a^a^a", ostring, lng, pname1, pname2, buf2, buf1, nl, linfo, buf3, buf4);

	return;					/* default_error_handler_ will decide what to do with the string */

%page;
/* INCLUDE FILES */

%include object_link_dcls;
%page;
%include definition_dcls;
%page;
%include its;
%page;
%include mc;
%page;
%include stack_header;
%page;
%include system_link_names;

     end;




		    message_table_.alm              11/11/89  1139.1rew 11/11/89  0840.9       92205



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * 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-07-14,BWong), approve(86-07-14,MCR7382),
"     audit(86-07-17,Ginter), install(86-07-28,MR12.0-1104):
"     Fix fortran bug 355.
"                                                      END HISTORY COMMENTS


"
"	message_table_
"
"	This is a modified version of the old message_table_.mt. The program generates a sequence
"	of message table entries (MTEs) that are defined with the mte macro.
"
"	The correct MTE is found by default_error_handler_ by searching the definitions
"	of message_table_.
"
"	Coded Aug 19, 1977 by S.Webber
"	Modified June 1978 by M. Weaver  to fix missing new line bugs and gate_err
"	Modified Nov. 22, 1978 by M. Weaver  to fix storage, add command_abort_, and fix missing line bugs
"	Modified: 7 April 1981 by G. Palter to correct bug causing the command_query_error
"		     condition to print garbage
"
"
"	Modified April 1981 by Benson I. Margulies to replace simfault with null_pointer_
"	and remove obsolete accessviolation entry.
"	Modified June 1983 by Melanie Weaver to add fortran_pause
"	Modified November 29, 1984 by Melanie Weaver to add malformed_list_template_entry_
"	Modified November 25, 1985 by Nashirali Samanani to change the stringrange error message.
"		Fixes fortran error list number 355 (TR phx13585).


	macro	format
	zero	0,&l1		"length of varying string
	aci	@&1@,104		"declare char (104) var

	&end


	macro	cond
	maclist	on,save

	ife	&1,()		"null string?
	zero	nullp,0
	ifend
	ine	&1,()
	use	data
&U:	zero	0,&l1
	aci	@&1@
	use	text
	zero	&U,0
	ifend
	maclist	restore

	&end



	macro	mte

	segdef	&1
&1:
	zero	&2,&3		"control bits
	zero	0,&4		"format index

	maclist	off,save
	cond	(&5)		"first string
	cond	(&6)		"second string
	cond	(&7)		"third string
	cond	(&8)		"fourth string
	maclist	restore

	ife	&9,()		"see if id given
	zero	nullp,0		"no, point to null string
	ifend
	ine	&9,()		"id was given
	use	data
&U:	zero	0,14+&l1
	aci	@  (&1 condition)@
	use	text
	zero	&U,0
	ifend

	&end



	use	text
	use	data
	join	/text/text,data

	include	message_table_entry


	use	data
nullp:	zero	0,0		"zero length varying string
	use	text

	segdef	formats
formats:
	format	()
	format	()

	format	(^/Error:  ^a^a by ^a^a^a^a^/^a^a^a^a)
	format	(^/Error while processing in ^a:^/^a^a ^a^a^a^/^a^a^a^/Entry into lower ring was by^/^a^a^a^a)

	format	(^/Error:  ^a ^a ^a^a^/^a ^a^/^a^a^a^a)
	format	(^/Error while processing in ^a:^/^a ^a ^a^/^a ^a^/^a^a^a^/Entry into lower ring was by^/^a^a^a^a)

	format	(^/Error:  ^a ^a by ^a^a^/^a^a^a^a^a^a)
	format	(^/Error while processing in ^a:^/^a ^a by ^a^a^a^/^a^a^a^/Entry into lower ring was by^/^a^a^a^a)

	format	(^/Error:  ^a^a ^a^a^a^a^a^a^a^a)
	format	(^/Error while processing in ^a:^/^a^a ^a^a^a^a^a^a^/Entry into lower ring was by^/^a^a^a^a)

	format	(^/Error:  ^a^a ^a^a^/^a ^a^/^a^a^a^a)
	format	(^/Error while processing in ^a:^/^a^a ^a^/^a ^a^/^a^a^a^/Entry into lower ring was by^/^a^a^a^a)

	format	(^/Error:  ^a^a by ^a^a^a^a^a^/^a^a^a)
	format	(^/Error while processing in ^a:^/^a^a by ^a^a^a^a^/^a^a^/Entry into lower ring was by^/^a^a^a^a)

	format	(^/Error:  ^a^a ^a^a^/^a ^a^a^a^a^a)
	format	(^/Error while processing in ^a:^/^a^a ^a^/^a ^a^a^a^a^/Entry into lower ring was by^/^a^a^a^a)

	format	(^/Error:  ^a^a ^a^a^a^a^/^a^a^a^a)
	format	(^/Error while processing in ^a:^/^a^a ^a^a^a^/^a^a^a^/Entry into lower ring was by^/^a^a^a^a)

	format	(^/Error:  ^a^a by ^a^a^a^a^a^a^a^a)
	format	(^/Error while processing in ^a:^/^a^a by ^a^a^a^a^a^a^/Entry into lower ring was by^/^a^a^a^a)

	format	(^/Error:  ^a error^a by ^a^a^/^a^a^a^a^a^a)
	format	(^/Error while processing in ^a:^/^a error^a by ^a^/^a^a^a^a^a^/Entry into lower ring was by^/^a^a^a^a)

	format	(^/Error:  ^a^a by ^a^a^a^a^/^a^a^/^a^a)
	format	(^/Error while processing in ^a:^/^a^a ^a^a^a^/^a^a^/^a^/Entry into lower ring was by^/^a^a^a^a)

	format	(^/Error:  ^a^a ^a^a^/^a ^a^/^a^a^/^a^a)
	format	(^/Error while processing in ^a:^/^a^a ^a^/^a ^a^/^a^a^/^a^/Entry into lower ring was by^/^a^a^a^a)


	mte	command_abort_,mte.no_tpr,mte.no_special,3,command_abort_,,
		(Program has stopped voluntarily.)

	mte	command_query_error,mte.query_error,mte.no_special,23,command_query_error,,
		(A preset answer returned by the condition handler for command_question),
		(was neither "yes" nor "no" as required by the caller of command_query_.)

	mte	active_function_error,mte.active_func,mte.no_special

	mte	sub_error_,mte.no_tpr,mte.sub_err,21

	mte	error,mte.no_tpr,mte.no_special,19,(error condition)

	mte	area,mte.no_tpr,mte.sig_error,23,(area condition),,
		(Either a variable could not be allocated in an area),
		(or an area could not be assigned to an existing area.)

	mte	storage,mte.ignore,mte.storage+mte.sig_error,3,(storage condition)

	mte	endfile,mte.no_tpr,mte.sig_error,19,(endfile condition)

	mte	undefinedfile,mte.no_tpr,mte.sig_error,19,(undefinedfile condition)

	mte	size,mte.no_tpr,mte.sig_error,13,(size condition),,
		(Precision of target insufficient for number of integral digits assigned to it.)

	mte	conversion,mte.no_tpr,mte.sig_error,19,(conversion condition)

	mte	endpage,mte.no_tpr,mte.endpage,19,(endpage condition)

	mte	key,mte.no_tpr,mte.sig_error,19,(key condition)

	mte	record,mte.no_tpr,mte.sig_error,19,(record condition)

	mte	transmit,mte.no_tpr,mte.sig_error,13,(transmit condition),,
		(Data could not be reliably transmitted between file and some values in an I/O statement.)

	mte	stringrange,mte.no_tpr,mte.sig_error,3,(stringrange condition),,
		(The given string does not completely contain the selected substring.)

	mte	subscriptrange,mte.no_tpr,mte.sig_error,3,(subscriptrange condition),,
		(A subscript value has exceeded array bounds.)

	mte	linkage_error,mte.with_tpr,mte.linkerr,11,(Linkage error by),referencing

	mte	io_error,mte.io_err,mte.no_special,3,io_error

	mte	illegal_procedure,mte.undefined

	mte	privileged_info,mte.no_tpr,mte.cur_inst,17,(Attempt to execute privileged instruction by)

	mte	unwinder_error,mte.unwind_err,mte.no_special,3,unwinder_error

	mte	hard_default_info,mte.with_tpr,mte.no_special,5,(condition by),referencing

	mte	null_pointer,mte.no_tpr,mte.no_special,17,(Attempt by),,(to reference through null pointer)

	mte	fixedoverflow,mte.no_tpr,mte.sig_error,9,(Fixed point overflow by),,,,id

	mte	overflow,mte.no_tpr,mte.sig_error,9,(Exponent overflow by),,,,id

	mte	underflow,mte.no_tpr,mte.sig_error,9,(Exponent underflow by),,,,id

	mte	zerodivide,mte.no_tpr,mte.sig_error,9,(Attempt to divide by zero at),,,,id

	mte	illegal_opcode,mte.no_tpr,mte.cur_inst,17,(Illegal machine operation by),,,,id

	mte	accessviolation,mte.with_tpr,mte.no_special,11,(Improper access by),referencing,
		(Improper access to referenced segment.),,id

	mte	gate_err,mte.with_tpr,mte.gaterr,3,(gate error condition),,(Wrong number of arguments given.)

	mte	seg_fault_error,mte.with_tpr,mte.segferr,11,(Segment-fault error by),referencing

	mte	page_fault_error,mte.with_tpr,mte.pagerr,11,(Page read error encountered by),(in referencing)

	mte	op_not_complete,mte.no_tpr,mte.no_special,17,(op_not_complete at),
		(Hardware error. Try invoking procedure again.)

	mte	store,mte.with_tpr,mte.store,11,(store fault at),referencing

	mte	command,mte.with_tpr,mte.no_special,25,(command condition by),referencing,
		(Either attempt to read clock on non-existent port),
		(or configuration error or hardware error.)

	mte	lockup,mte.with_tpr,mte.no_special,25,(Possible loop by),referencing,
		(Interrupts not sampled for too long a time.  Possibilities:),
		(tra * loop, infinite indirect chain, inhibited too long in BAR mode),id

	mte	illegal_modifier,mte.with_tpr,mte.no_special,11,(illegal modifier condition by),referencing,
		(Possible illegal modifier in indirect chain or uninitialized pointer.)

	mte	illegal_ring_order,mte.with_tpr,mte.no_special,11,(illegal_ring_order condition by),referencing,
		(Ring brackets in wrong order.  Contact system maintenance staff.)

	mte	bad_outward_call,mte.with_tpr,mte.no_special,11,(bad_outward_call condition by),referencing,
		(Incorrect access to, or ring brackets on, referenced segment.)

	mte	inward_return,mte.with_tpr,mte.no_special 15,(Attempt to return to inward ring by),referencing,,,id

	mte	cross_ring_transfer,mte.with_tpr,mte.no_special,25,(Illegal cross ring transfer by),
		(referencing),(Transfer instructions cannot be used to cross rings),
		(only call and rtcd instructions may be used.),id

	mte	out_of_bounds,mte.with_tpr,mte.outbounds,11,(out_of_bounds at),referencing

	mte	illegal_return,mte.no_tpr,mte.no_special,17,(Illegal return to),
		(Attempt to restore bad machine conditions after a fault.),,,id

	mte	fault_tag_1,mte.with_tpr,mte.no_special,11,(fault_tag_1 by),referencing,
		(Ascii data where pointer expected.)

	mte	truncation,mte.with_tpr,mte.no_special,11,(stringsize condition by),referencing,
		(Attempt to copy a longer string into a shorter one.)

	mte	soft_default_info,mte.no_tpr,mte.no_special,7,condition

	mte	not_a_gate,mte.with_tpr,mte.no_special,11,(Attempt by),(to access),
		(which is beyond the entry bound for the gate.),,id

	mte	quit,mte.no_tpr,mte.no_special,9,(quit in)

	mte	lot_fault,mte.with_tpr,mte.lotfault,11,(lot fault by),referencing

	mte	return_conversion_error,mte.no_tpr,mte.no_special,13,(return conversion error),,
		(Incompatibility between a return or end statement and the way the procedure was entered.)

	mte	fortran_pause,mte.no_tpr,mte.no_special,1,,,,,id

	mte	malformed_list_template_entry_,mte.no_tpr,mte.no_special,5,(Attempt by),
		(to initialize a variable with a malformed list template.),,,id

	end




		    special_messages_.pl1           11/11/89  1139.1r w 11/11/89  0839.1       50319



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


special_messages_: proc (a_mcp, a_mtep, linfo, crlsw, no_restart);

/* this procedure formats special messages which contain dynamic information */
/* initially coded by M. Weaver 5 June 1971 */
/* modified by M. Weaver 16 August 1971 */
/* modified by M. Weaver 18 October 1973 */
/* modified by M. Weaver 17 June 1974 for storage */
/* modified by M. Weaver 2 May 1977 for lot_fault */
/* modified by Benson I. Margulies 1/82 for improved oobstk codes */

/* Parameters */

dcl  a_mcp ptr;
dcl  a_mtep ptr;
dcl  linfo char (500) var;
dcl  no_restart bit (1) aligned;

dcl 1 pr_err aligned based (pre_infop),			/* interpretation of errcode for page read error */
    2 device_addr bit (18) unal,
    2 add_type bit (4) unal,
    2 pad bit (5) unal,
    2 pvtx fixed bin (8) unal;

dcl (lng, i) fixed bin;
dcl  segno fixed bin (18);
dcl  ecode fixed bin (35);
dcl  segptr ptr;
dcl  error_table_$noentry ext fixed bin (35);
dcl  error_table_$stack_overflow ext fixed bin (35);
dcl (objp, pre_infop) ptr;

dcl  fslinfo char (100) aligned;			/* for convert_status_code_ */
dcl  sinfo char (8) aligned;
dcl (dirname, pathname) char (168);
dcl  ename char (32);

%include disk_table;
%include add_type;

dcl  string1 char (72) var;

dcl (ioa_$rs, ioa_$rsnnl) entry options (variable);
dcl  convert_status_code_ ext entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  disassemble ext entry (ptr, char (72) var, fixed bin);
dcl  hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  mdc_$read_disk_table entry (ptr, fixed bin (35));

dcl (addr, addrel, baseptr, bin, divide, fixed, null, ptr, substr) builtin;

dcl  crlsw bit (1) unal;

/*  */
	mcp = a_mcp;
	mtep = a_mtep;
	scup = addr (mc.scu);			/* get ptr to saved control unit */
	no_restart = "0"b;

	if mte.cur_inst then do;
	     if ^crlsw then objp = ptr (baseptr (bin (scup -> scu.ppr.psr, 15)),
		scup -> scu.ilc);			/* get inst from text */
	     else do;				/* must get instruction from scu itself */
		if substr (scup -> scu.ilc, 18, 1) = "1"b then i = 1;
		else i = 0;
		objp = addr (scup -> scux.instr (i));
	     end;
	     call disassemble (objp, string1, 0);	/* get inst in inst format */
	     call ioa_$rsnnl ("Current instruction is:^/^a", linfo, lng, string1);
	end;

	else if mte.segferr then do;
	     ecode = mc.errcode;
	     if ecode = error_table_$noentry then fslinfo = "Segment no longer exists.";
	     else call convert_status_code_ (ecode, sinfo, fslinfo);
	     linfo = fslinfo;
	end;

	else if mte.pagerr then do;			/* page fault error */
	     pre_infop = addr (mcp -> mc.errcode);	/* errcode is interpreted differently here */
	     if mcp -> mc.errcode = -1 then return;	/* no device */
	     if (pr_err.add_type & add_type.non_null) = "0000"b then return; /* null */
	     if pr_err.add_type & add_type.pd then do;
		call ioa_$rs ("from paging device address ^o.", linfo, lng, pr_err.device_addr);
		return;
	     end;
	     call hcs_$make_seg ("", "disk_table.copy", "", 1010b, dtp, ecode);
	     if dtp = null then return;
	     call mdc_$read_disk_table (dtp, ecode);
	     if ecode ^= 0 then return;
	     if pr_err.pvtx > dt.n_entries | pr_err.pvtx <= 0 then return;
	     dtep = addr (dt.array (pr_err.pvtx));
	     if dte.lvx > dt.n_lv_entries | dte.lvx <= 0 then return;
	     lvep = addr (dt.lv_array (dte.lvx));
	     call ioa_$rs ("from ^a address ^o. Volume ^a of lv ^a.", linfo, lng,
		dte.drive_name, bin (pr_err.device_addr, 18), dte.pvname, lve.lvname);
	end;

	else if mte.outbounds then do;
	     call convert_status_code_ ((mc.errcode), sinfo, fslinfo);
	     linfo = fslinfo;
	end;

	else if mte.store then do;
	     if scup -> scu.ir.bm
	     then linfo = "Possible attempt to reference nonexistent memory.";
	     else linfo = "Attempt to reference out of bounds in BAR mode.";
	end;

	else if mte.storage then do;
	     if mcp = null
	     then linfo = "System storage for based and controlled variables is full.";
	     else do;				/* detected by hardware on stack */
		call convert_status_code_ ((mc.errcode), sinfo, fslinfo);
		linfo = fslinfo;
		if mc.errcode = error_table_$stack_overflow /* noplace to put the info */
		then no_restart = "1"b;
		end;
	     end;


	else if mte.lotfault then do;
	     if crlsw then pathname = "";
	     else do;
		sb = ptr (mc.prs (6), 0);
		segno = bin (scup -> scu.ca, 18) - bin (rel (sb -> stack_header.lot_ptr), 18);
		segptr = baseptr (segno);
		call hcs_$fs_get_path_name (segptr, dirname, lng, ename, ecode);
		if ecode = 0 then call ioa_$rsnnl ("^a^[>^]^a", dirname, lng ^= 1, ename);
		else pathname = "";
	     end;
	     linfo = "Attempt to execute non-object segment " || pathname;
	end;

	return;
						/*  */

%include mc;
%include stack_header;
%include message_table_entry;
     end special_messages_;




		    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
