


		    arithmetic_to_ascii_.pl1        10/24/88  1628.4r w 10/24/88  1400.3       43506


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


/*
   Modified in July 1977 by R.J.C. Kissel to handle new data types.  When any_to_any_ is
   updated to handle all data types, all references to probe_assign_ should be changed to references
   to assign_ and probe_assign_ and probe_convert_ should be deleted.
   Modified 11 Apr 79 JRDavis for proper handling of unaligned dec  -use data_type_info_
   Modified 20 June 79 JRDavis to use assign_$computational_ instead of probe_assign_
   Modified 2 Feb 84 JRGray to use generic_decimal types and to remove call to numeric_to_ascii_
*/
arithmetic_to_ascii_: proc (p, type, packed, precision, scale, ans);

dcl  p ptr parameter,				/* input: to the arithmetic data to convert */
     type fixed bin parameter,			/* input: data type of the input: data */
     packed bit (1) aligned parameter,			/* input: is it packed? */
     precision fixed bin parameter,			/* input: precision of the data */
     scale fixed bin parameter,			/* input: scale factor (if fixed) */
     ans char (132) varying parameter;			/* output: ASCII rep of data */

dcl  01 generic_decimal_struc aligned based,
	02 exponent fixed bin(35) aligned,
	02 sign char(1) unaligned,
	02 mantissa char(k) unaligned;

dcl  01 number aligned based(addr(number_block)),		/* temp to convert all types to */
	02 (real, imaginary) like generic_decimal_struc aligned;

dcl  number_block bit(36 * 32) aligned;			/* storage for temporary */

dcl  k fixed bin;
dcl 1 src_str aligned like computational_data;
dcl 1 tar_str aligned like computational_data;
dcl  code fixed bin (35);

dcl  assign_$computational_ entry (ptr, ptr, fixed bin (35));
dcl (addr, ceil, char, copy, divide, hbound, length, ltrim, null, rtrim, substr) builtin;

	if type < 1 | type > hbound (data_type_info_$info, 1) /* bad data type */
	then do;
	     ans = "(bad data type)";
	     return;
	end;

	if ^data_type_info_$info (type).arithmetic	/* not arithmetic type */
	then do;
	     ans = "(not arithmetic type)";
	     return;
	end;

/* Get decimal precision corresponding to input
   Note: assign_$computational will take care of rounding/truncation */

	if precision < 1 then k = data_type_info_$max_decimal_precision;
	else if data_type_info_$info (type).decimal then k = precision;
	else k = ceil (divide (precision * 100, 332, 17, 0)) + 1;

/* convert to internal storage - complex generic dec */
	tar_str.address = addr (number_block);
	tar_str.data_type = cplx_flt_dec_generic_dtype;
	tar_str.flags = "0"b;
	tar_str.prec_or_length = k;
	tar_str.scale = 0;
	tar_str.picture_image_ptr = null ();		/* superfluous, but be safe */

	src_str.address = p;
	src_str.data_type = type;
	src_str.flags = "0"b;
	src_str.packed = packed;
	src_str.prec_or_length = precision;
	src_str.scale = scale;

	/* let assign_$computational_ do rounding/truncation */
	call assign_$computational_ (addr (tar_str), addr (src_str), code);

	ans = ltrim(simplify(addr(number.real), k), "+");
	if data_type_info_$info (type).complex		/* has complex part */
	then ans = ans || simplify (addr(number.imaginary), k) || "i";
	return;

/*	simplify returns a compact form of a generic number.
	Note: simplify leaves on the sign "+" or "-"	*/

simplify:	proc(NUMBER_ptr, precision) returns(char(72) varying);
dcl	(NUMBER_ptr, number_ptr) ptr;
dcl	01 number aligned based(number_ptr),
	  02 exponent fixed bin(35),
	  02 sign char(1) unaligned,
	  02 mantissa char(precision) unaligned;

dcl	mantissa char(72) varying;
dcl	exponent fixed bin(35);
dcl	(precision, digits) fixed bin;

	/*  force normalization  */
	number_ptr = NUMBER_ptr;
	mantissa = ltrim(number.mantissa, "0");
	if mantissa="" then return("+0");
	exponent = number.exponent + length(mantissa) -1;
	mantissa = rtrim(mantissa, "0");
	digits = length(mantissa);

	if 2-exponent > precision | exponent+1 > precision		/* exponential form */
	then return(sign || substr(mantissa, 1, 1) || rtrim("." || substr(mantissa, 2), ".")
		|| "e" || ltrim(char(exponent)) );

	/* use real form */
	if exponent < 0 then return(sign || "0." || copy("0", -exponent-1) || mantissa);
	if exponent+1 >= digits then return(sign || mantissa || copy("0", exponent-digits+1));
	return(sign || substr(mantissa, 1, exponent+1) || "." || substr(mantissa, exponent+2));
end simplify;

%include computational_data;
%include data_type_info_;
%include std_descriptor_types;
     end;
  



		    continue_to_signal_.pl1         11/05/86  1218.8r w 11/04/86  1033.7       27675


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

continue_to_signal_: proc (code);

/* this procedure looks for the most recent call to a condition handler   and sets the continue bit

   modified 10 May 79 JRDavis to not use arg_list.incl.pl1 (which it wasn't using anyway)
*/

declare (null, ptr, rel) builtin;

declare (limit, type, ndims, size, scale) fixed bin;
declare  code fixed bin (35);
declare  error_table_$not_done ext fixed bin (35);
declare  ap ptr;					/* to arg list */
declare (bbit based, packed) bit (1) aligned;

declare  ptra (0 : 10) ptr based;			/* template for argument ptrs */

declare  cu_$stack_frame_ptr entry () returns (ptr);
declare  decode_descriptor_ entry (ptr, fixed bin, fixed bin, bit (1) aligned,
         fixed bin, fixed bin, fixed bin);


%include stack_frame;

%include stack_header;

/*  */
	code = 0;
	sp = cu_$stack_frame_ptr ();			/* find starting point */
	sb = ptr (sp, 0);				/* get ptr to stack header */

	do while (sp ^= null);			/* look for a signal_ frame */

	     if ^(sp -> stack_frame_flags.signal)
	     then sp = sp -> stack_frame.prev_sp;	/* look some more */

	     else do;				/* look for an argument list to handler */
		do limit = 1 to 2;			/* but limit search to 2 frames */
		     sp = sp -> stack_frame.next_sp;
		     ap = sp -> stack_frame.arg_ptr;	/* pick up arglist ptr */

		     if ap ^= null then do;		/* have an argument list */
			call decode_descriptor_ (ap, 5, type, packed, ndims, size, scale);
			if (type = 19) & (size = 1) then do; /* have bit(1) */
			     ap -> ptra (5) -> bbit = "1"b;
			     return;		/* got what we came for */
			end;
		     end;
		end;
		go to error;			/* couldn't find proper arg list */
	     end;
	end;

error:	code = error_table_$not_done;

	return;


/*  */
is_condition_frame_: entry (a_sp) returns (bit (1) aligned);

/* this procedure is for use when tracing an arbitrary stack forward */

declare (a_sp, nsp) ptr;

	sp = a_sp;				/* get ptr to frame in question */

	if sp -> stack_frame_flags.signaller then	/* faulted out of this frame */
	     return ("1"b);

	nsp = ptr (sp, rel (sp -> stack_frame.next_sp));	/* may need to look at next frame also */
	if nsp -> stack_frame_flags.crawl_out then return ("1"b);

	if nsp -> stack_frame_flags.signal then do;

/*	distinguish between software and hardware conditions;
   for the former, condition frame is just before signal_'s;
   for the latter, condition frame is 2 before signal_'s */

	     if ptr (sp, rel (sp -> stack_frame.prev_sp)) -> stack_frame_flags.signaller
	     then return ("0"b);

	     else return ("1"b);			/* software condition */

	end;

	return ("0"b);

     end;
 



		    data_type_info_.cds             11/12/86  1736.3rew 11/12/86  1607.9      363060


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


/* HISTORY COMMENTS:
  1) change(86-09-05,JMAthane), approve(86-09-05,MCR7525),
     audit(86-09-11,Martinson), install(86-11-12,MR12.0-1212):
     Added information concerning new pascal_string_type_dtype.
                                                   END HISTORY COMMENTS */


data_type_info_: proc;

/* Calls create_data_segment_ to create the data segment data_type_info_
   which gives attributes of all data types used in Multics.

   James R. Davis 6 Apr 79
   JRD 16 Oct 79 for new COBOL type 40
   JRD 10 Nov 80 MCR 4503 (I forgot to zero the pad fields)
   MBW 31 July 1981 to add algol68 data types
   JMAthane June 83 to add new PASCAL types and "type" bit in info.
   S. Herbst 01/23/84 Added types 47-50, 81-86, "hex" and "generic" bits.
   JMAthane June 85. Added type 87 (pascal string type dtype)
*/

	dcl     create_data_segment_	 entry (ptr, fixed bin (35));

	dcl     1 dti_struc		 aligned,
		2 version_number	 fixed bin,
		2 info,				/* extra level because of cds restriction! */
		  3 real_info	 (87) like data_type_info_$info,
		2 ninebit_sign_chars char (2),
		2 ninebit_digit_chars char (10),
		2 ninebit_overpunched_sign_chars char (22),
		2 max_decimal_precision fixed bin,
		2 max_float_binary_precision fixed bin,
		2 max_fixed_binary_precision fixed bin;

	dcl     1 cdsa		 aligned automatic internal like cds_args;

	dcl     (addr, hbound, null, size, string, unspec) builtin;
	dcl     code		 fixed bin (35);
	dcl     com_err_		 entry options (variable);
	dcl     exclude		 (1) char (32) static internal options (constant) init ("highest");


	call fillin;
	call init_cds_struc;
	call create_data_segment_ (addr (cdsa), code);
	if code ^= 0 then call com_err_ (code, "make_dti");
	return;

fillin: proc;
	dcl     (Y		 init ("1"b),
	        N			 init ("0"b)) bit (1) aligned internal static options (constant);
	dti_struc.version_number = 1;
	dti_struc.ninebit_sign_chars = "+-";
	dti_struc.ninebit_digit_chars = "0123456789";
	dti_struc.ninebit_overpunched_sign_chars = "{}ABCDEFGHIJKLMNOPQR";

	dti_struc.max_decimal_precision = 59;
	dti_struc.max_float_binary_precision = 63;
	dti_struc.max_fixed_binary_precision = 71;

	dti_struc.info.real_info (*) = "0"b;

	info (1).computational = Y;
	info (1).arithmetic = Y;
	info (1).fixed = Y;
	info (1).complex = N;
	info (1).decimal = N;
	info (1).signed = Y;
	info (1).trailing_sign = N;
	info (1).packed_dec = N;
	info (1).digit_aligned = N;
	info (1).overpunched = N;
	info (1).char_string = N;
	info (1).bit_string = N;
	info (1).varying = N;
	info (1).type = N;
	info (1).hex = N;
	info (1).generic = N;

	info (2).computational = Y;
	info (2).arithmetic = Y;
	info (2).fixed = Y;
	info (2).complex = N;
	info (2).decimal = N;
	info (2).signed = Y;
	info (2).trailing_sign = N;
	info (2).packed_dec = N;
	info (2).digit_aligned = N;
	info (2).overpunched = N;
	info (2).char_string = N;
	info (2).bit_string = N;
	info (2).varying = N;
	info (2).type = N;
	info (2).hex = N;
	info (2).generic = N;

	info (3).computational = Y;
	info (3).arithmetic = Y;
	info (3).fixed = N;
	info (3).complex = N;
	info (3).decimal = N;
	info (3).signed = Y;
	info (3).trailing_sign = N;
	info (3).packed_dec = N;
	info (3).digit_aligned = N;
	info (3).overpunched = N;
	info (3).char_string = N;
	info (3).bit_string = N;
	info (3).varying = N;
	info (3).type = N;
	info (3).hex = N;
	info (3).generic = N;

	info (4).computational = Y;
	info (4).arithmetic = Y;
	info (4).fixed = N;
	info (4).complex = N;
	info (4).decimal = N;
	info (4).signed = Y;
	info (4).trailing_sign = N;
	info (4).packed_dec = N;
	info (4).digit_aligned = N;
	info (4).overpunched = N;
	info (4).char_string = N;
	info (4).bit_string = N;
	info (4).varying = N;
	info (4).type = N;
	info (4).hex = N;
	info (4).generic = N;

	info (5).computational = Y;
	info (5).arithmetic = Y;
	info (5).fixed = Y;
	info (5).complex = Y;
	info (5).decimal = N;
	info (5).signed = Y;
	info (5).trailing_sign = N;
	info (5).packed_dec = N;
	info (5).digit_aligned = N;
	info (5).overpunched = N;
	info (5).char_string = N;
	info (5).bit_string = N;
	info (5).varying = N;
	info (5).type = N;
	info (5).hex = N;
	info (5).generic = N;

	info (6).computational = Y;
	info (6).arithmetic = Y;
	info (6).fixed = Y;
	info (6).complex = Y;
	info (6).decimal = N;
	info (6).signed = Y;
	info (6).trailing_sign = N;
	info (6).packed_dec = N;
	info (6).digit_aligned = N;
	info (6).overpunched = N;
	info (6).char_string = N;
	info (6).bit_string = N;
	info (6).varying = N;
	info (6).type = N;
	info (6).hex = N;
	info (6).generic = N;

	info (7).computational = Y;
	info (7).arithmetic = Y;
	info (7).fixed = N;
	info (7).complex = Y;
	info (7).decimal = N;
	info (7).signed = Y;
	info (7).trailing_sign = N;
	info (7).packed_dec = N;
	info (7).digit_aligned = N;
	info (7).overpunched = N;
	info (7).char_string = N;
	info (7).bit_string = N;
	info (7).varying = N;
	info (7).type = N;
	info (7).hex = N;
	info (7).generic = N;

	info (8).computational = Y;
	info (8).arithmetic = Y;
	info (8).fixed = N;
	info (8).complex = Y;
	info (8).decimal = N;
	info (8).signed = Y;
	info (8).trailing_sign = N;
	info (8).packed_dec = N;
	info (8).digit_aligned = N;
	info (8).overpunched = N;
	info (8).char_string = N;
	info (8).bit_string = N;
	info (8).varying = N;
	info (8).type = N;
	info (8).hex = N;
	info (8).generic = N;

	info (9).computational = Y;
	info (9).arithmetic = Y;
	info (9).fixed = Y;
	info (9).complex = N;
	info (9).decimal = Y;
	info (9).signed = Y;
	info (9).trailing_sign = N;
	info (9).packed_dec = N;
	info (9).digit_aligned = N;
	info (9).overpunched = N;
	info (9).char_string = N;
	info (9).bit_string = N;
	info (9).varying = N;
	info (9).type = N;
	info (9).hex = N;
	info (9).generic = N;

	info (10).computational = Y;
	info (10).arithmetic = Y;
	info (10).fixed = N;
	info (10).complex = N;
	info (10).decimal = Y;
	info (10).signed = Y;
	info (10).trailing_sign = N;
	info (10).packed_dec = N;
	info (10).digit_aligned = N;
	info (10).overpunched = N;
	info (10).char_string = N;
	info (10).bit_string = N;
	info (10).varying = N;
	info (10).type = N;
	info (10).hex = N;
	info (10).generic = N;

	info (11).computational = Y;
	info (11).arithmetic = Y;
	info (11).fixed = Y;
	info (11).complex = Y;
	info (11).decimal = Y;
	info (11).signed = Y;
	info (11).trailing_sign = N;
	info (11).packed_dec = N;
	info (11).digit_aligned = N;
	info (11).overpunched = N;
	info (11).char_string = N;
	info (11).bit_string = N;
	info (11).varying = N;
	info (11).type = N;
	info (11).hex = N;
	info (11).generic = N;

	info (12).computational = Y;
	info (12).arithmetic = Y;
	info (12).fixed = N;
	info (12).complex = Y;
	info (12).decimal = Y;
	info (12).signed = Y;
	info (12).trailing_sign = N;
	info (12).packed_dec = N;
	info (12).digit_aligned = N;
	info (12).overpunched = N;
	info (12).char_string = N;
	info (12).bit_string = N;
	info (12).varying = N;
	info (12).type = N;
	info (12).hex = N;
	info (12).generic = N;

	info (13).computational = N;
	info (13).arithmetic = N;
	info (13).fixed = N;
	info (13).complex = N;
	info (13).decimal = N;
	info (13).signed = N;
	info (13).trailing_sign = N;
	info (13).packed_dec = N;
	info (13).digit_aligned = N;
	info (13).overpunched = N;
	info (13).char_string = N;
	info (13).bit_string = N;
	info (13).varying = N;
	info (13).type = N;
	info (13).hex = N;
	info (13).generic = N;

	info (14).computational = N;
	info (14).arithmetic = N;
	info (14).fixed = N;
	info (14).complex = N;
	info (14).decimal = N;
	info (14).signed = N;
	info (14).trailing_sign = N;
	info (14).packed_dec = N;
	info (14).digit_aligned = N;
	info (14).overpunched = N;
	info (14).char_string = N;
	info (14).bit_string = N;
	info (14).varying = N;
	info (14).type = N;
	info (14).hex = N;
	info (14).generic = N;

	info (15).computational = N;
	info (15).arithmetic = N;
	info (15).fixed = N;
	info (15).complex = N;
	info (15).decimal = N;
	info (15).signed = N;
	info (15).trailing_sign = N;
	info (15).packed_dec = N;
	info (15).digit_aligned = N;
	info (15).overpunched = N;
	info (15).char_string = N;
	info (15).bit_string = N;
	info (15).varying = N;
	info (15).type = N;
	info (15).hex = N;
	info (15).generic = N;

	info (16).computational = N;
	info (16).arithmetic = N;
	info (16).fixed = N;
	info (16).complex = N;
	info (16).decimal = N;
	info (16).signed = N;
	info (16).trailing_sign = N;
	info (16).packed_dec = N;
	info (16).digit_aligned = N;
	info (16).overpunched = N;
	info (16).char_string = N;
	info (16).bit_string = N;
	info (16).varying = N;
	info (16).type = N;
	info (16).hex = N;
	info (16).generic = N;

	info (17).computational = N;
	info (17).arithmetic = N;
	info (17).fixed = N;
	info (17).complex = N;
	info (17).decimal = N;
	info (17).signed = N;
	info (17).trailing_sign = N;
	info (17).packed_dec = N;
	info (17).digit_aligned = N;
	info (17).overpunched = N;
	info (17).char_string = N;
	info (17).bit_string = N;
	info (17).varying = N;
	info (17).type = N;
	info (17).hex = N;
	info (17).generic = N;

	info (18).computational = N;
	info (18).arithmetic = N;
	info (18).fixed = N;
	info (18).complex = N;
	info (18).decimal = N;
	info (18).signed = N;
	info (18).trailing_sign = N;
	info (18).packed_dec = N;
	info (18).digit_aligned = N;
	info (18).overpunched = N;
	info (18).char_string = N;
	info (18).bit_string = N;
	info (18).varying = N;
	info (18).type = N;
	info (18).hex = N;
	info (18).generic = N;

	info (19).computational = Y;
	info (19).arithmetic = N;
	info (19).fixed = N;
	info (19).complex = N;
	info (19).decimal = N;
	info (19).signed = N;
	info (19).trailing_sign = N;
	info (19).packed_dec = N;
	info (19).digit_aligned = N;
	info (19).overpunched = N;
	info (19).char_string = N;
	info (19).bit_string = Y;
	info (19).varying = N;
	info (19).type = N;
	info (19).hex = N;
	info (19).generic = N;

	info (20).computational = Y;
	info (20).arithmetic = N;
	info (20).fixed = N;
	info (20).complex = N;
	info (20).decimal = N;
	info (20).signed = N;
	info (20).trailing_sign = N;
	info (20).packed_dec = N;
	info (20).digit_aligned = N;
	info (20).overpunched = N;
	info (20).char_string = N;
	info (20).bit_string = Y;
	info (20).varying = Y;
	info (20).type = N;
	info (20).hex = N;
	info (20).generic = N;

	info (21).computational = Y;
	info (21).arithmetic = N;
	info (21).fixed = N;
	info (21).complex = N;
	info (21).decimal = N;
	info (21).signed = N;
	info (21).trailing_sign = N;
	info (21).packed_dec = N;
	info (21).digit_aligned = N;
	info (21).overpunched = N;
	info (21).char_string = Y;
	info (21).bit_string = N;
	info (21).varying = N;
	info (21).type = N;
	info (21).hex = N;
	info (21).generic = N;

	info (22).computational = Y;
	info (22).arithmetic = N;
	info (22).fixed = N;
	info (22).complex = N;
	info (22).decimal = N;
	info (22).signed = N;
	info (22).trailing_sign = N;
	info (22).packed_dec = N;
	info (22).digit_aligned = N;
	info (22).overpunched = N;
	info (22).char_string = Y;
	info (22).bit_string = N;
	info (22).varying = Y;
	info (22).type = N;
	info (22).hex = N;
	info (22).generic = N;

	info (23).computational = N;
	info (23).arithmetic = N;
	info (23).fixed = N;
	info (23).complex = N;
	info (23).decimal = N;
	info (23).signed = N;
	info (23).trailing_sign = N;
	info (23).packed_dec = N;
	info (23).digit_aligned = N;
	info (23).overpunched = N;
	info (23).char_string = N;
	info (23).bit_string = N;
	info (23).varying = N;
	info (23).type = N;
	info (23).hex = N;
	info (23).generic = N;

	info (24).computational = N;			/* not used */
	info (24).arithmetic = N;
	info (24).fixed = N;
	info (24).complex = N;
	info (24).decimal = N;
	info (24).signed = N;
	info (24).trailing_sign = N;
	info (24).packed_dec = N;
	info (24).digit_aligned = N;
	info (24).overpunched = N;
	info (24).char_string = N;
	info (24).bit_string = N;
	info (24).varying = N;
	info (24).type = N;
	info (24).hex = N;
	info (24).generic = N;

	info (25).computational = N;			/* not used */
	info (25).arithmetic = N;
	info (25).fixed = N;
	info (25).complex = N;
	info (25).decimal = N;
	info (25).signed = N;
	info (25).trailing_sign = N;
	info (25).packed_dec = N;
	info (25).digit_aligned = N;
	info (25).overpunched = N;
	info (25).char_string = N;
	info (25).bit_string = N;
	info (25).varying = N;
	info (25).type = N;
	info (25).hex = N;
	info (25).generic = N;

	info (26).computational = N;			/* not used */
	info (26).arithmetic = N;
	info (26).fixed = N;
	info (26).complex = N;
	info (26).decimal = N;
	info (26).signed = N;
	info (26).trailing_sign = N;
	info (26).packed_dec = N;
	info (26).digit_aligned = N;
	info (26).overpunched = N;
	info (26).char_string = N;
	info (26).bit_string = N;
	info (26).varying = N;
	info (26).type = N;
	info (26).hex = N;
	info (26).generic = N;

	info (27).computational = N;			/* not used */
	info (27).arithmetic = N;
	info (27).fixed = N;
	info (27).complex = N;
	info (27).decimal = N;
	info (27).signed = N;
	info (27).trailing_sign = N;
	info (27).packed_dec = N;
	info (27).digit_aligned = N;
	info (27).overpunched = N;
	info (27).char_string = N;
	info (27).bit_string = N;
	info (27).varying = N;
	info (27).type = N;
	info (27).hex = N;
	info (27).generic = N;

	info (28).computational = N;			/* not used */
	info (28).arithmetic = N;
	info (28).fixed = N;
	info (28).complex = N;
	info (28).decimal = N;
	info (28).signed = N;
	info (28).trailing_sign = N;
	info (28).packed_dec = N;
	info (28).digit_aligned = N;
	info (28).overpunched = N;
	info (28).char_string = N;
	info (28).bit_string = N;
	info (28).varying = N;
	info (28).type = N;
	info (28).hex = N;
	info (28).generic = N;

	info (29).computational = Y;
	info (29).arithmetic = Y;
	info (29).fixed = Y;
	info (29).complex = N;
	info (29).decimal = Y;
	info (29).signed = Y;
	info (29).trailing_sign = N;
	info (29).packed_dec = N;
	info (29).digit_aligned = N;
	info (29).overpunched = Y;
	info (29).char_string = N;
	info (29).bit_string = N;
	info (29).varying = N;
	info (29).type = N;
	info (29).hex = N;
	info (29).generic = N;

	info (30).computational = Y;
	info (30).arithmetic = Y;
	info (30).fixed = Y;
	info (30).complex = N;
	info (30).decimal = Y;
	info (30).signed = Y;
	info (30).trailing_sign = Y;
	info (30).packed_dec = N;
	info (30).digit_aligned = N;
	info (30).overpunched = Y;
	info (30).char_string = N;
	info (30).bit_string = N;
	info (30).varying = N;
	info (30).type = N;
	info (30).hex = N;
	info (30).generic = N;

	info (31).computational = N;			/* not used */
	info (31).arithmetic = N;
	info (31).fixed = N;
	info (31).complex = N;
	info (31).decimal = N;
	info (31).signed = N;
	info (31).trailing_sign = N;
	info (31).packed_dec = N;
	info (31).digit_aligned = N;
	info (31).overpunched = N;
	info (31).char_string = N;
	info (31).bit_string = N;
	info (31).varying = N;
	info (31).type = N;
	info (31).hex = N;	
	info (31).generic = N;

	info (32).computational = N;			/* not used */
	info (32).arithmetic = N;
	info (32).fixed = N;
	info (32).complex = N;
	info (32).decimal = N;
	info (32).signed = N;
	info (32).trailing_sign = N;
	info (32).packed_dec = N;
	info (32).digit_aligned = N;
	info (32).overpunched = N;
	info (32).char_string = N;
	info (32).bit_string = N;
	info (32).varying = N;
	info (32).type = N;
	info (32).hex = N;
	info (32).generic = N;

	info (33).computational = Y;
	info (33).arithmetic = Y;
	info (33).fixed = Y;
	info (33).complex = N;
	info (33).decimal = N;
	info (33).signed = N;
	info (33).trailing_sign = N;
	info (33).packed_dec = N;
	info (33).digit_aligned = N;
	info (33).overpunched = N;
	info (33).char_string = N;
	info (33).bit_string = N;
	info (33).varying = N;
	info (33).type = N;
	info (33).hex = N;
	info (33).generic = N;

	info (34).computational = Y;
	info (34).arithmetic = Y;
	info (34).fixed = Y;
	info (34).complex = N;
	info (34).decimal = N;
	info (34).signed = N;
	info (34).trailing_sign = N;
	info (34).packed_dec = N;
	info (34).digit_aligned = N;
	info (34).overpunched = N;
	info (34).char_string = N;
	info (34).bit_string = N;
	info (34).varying = N;
	info (34).type = N;
	info (34).hex = N;
	info (34).generic = N;

	info (35).computational = Y;
	info (35).arithmetic = Y;
	info (35).fixed = Y;
	info (35).complex = N;
	info (35).decimal = Y;
	info (35).signed = N;
	info (35).trailing_sign = N;
	info (35).packed_dec = N;
	info (35).digit_aligned = N;
	info (35).overpunched = N;
	info (35).char_string = N;
	info (35).bit_string = N;
	info (35).varying = N;
	info (35).type = N;
	info (35).hex = N;
	info (35).generic = N;

	info (36).computational = Y;
	info (36).arithmetic = Y;
	info (36).fixed = Y;
	info (36).complex = N;
	info (36).decimal = Y;
	info (36).signed = Y;
	info (36).trailing_sign = Y;
	info (36).packed_dec = N;
	info (36).digit_aligned = N;
	info (36).overpunched = N;
	info (36).char_string = N;
	info (36).bit_string = N;
	info (36).varying = N;
	info (36).type = N;
	info (36).hex = N;
	info (36).generic = N;

	info (37).computational = N;			/* not used */
	info (37).arithmetic = N;
	info (37).fixed = N;
	info (37).complex = N;
	info (37).decimal = N;
	info (37).signed = N;
	info (37).trailing_sign = N;
	info (37).packed_dec = N;
	info (37).digit_aligned = N;
	info (37).overpunched = N;
	info (37).char_string = N;
	info (37).bit_string = N;
	info (37).varying = N;
	info (37).type = N;
	info (37).hex = N;
	info (37).generic = N;

	info (38).computational = Y;
	info (38).arithmetic = Y;
	info (38).fixed = Y;
	info (38).complex = N;
	info (38).decimal = Y;
	info (38).signed = N;
	info (38).trailing_sign = N;
	info (38).packed_dec = Y;
	info (38).digit_aligned = Y;
	info (38).overpunched = N;
	info (38).char_string = N;
	info (38).bit_string = N;
	info (38).varying = N;
	info (38).type = N;
	info (38).hex = N;
	info (38).generic = N;

	info (39).computational = Y;
	info (39).arithmetic = Y;
	info (39).fixed = Y;
	info (39).complex = N;
	info (39).decimal = Y;
	info (39).signed = Y;
	info (39).trailing_sign = Y;
	info (39).packed_dec = Y;
	info (39).digit_aligned = N;
	info (39).overpunched = N;
	info (39).char_string = N;
	info (39).bit_string = N;
	info (39).varying = N;
	info (39).type = N;
	info (39).hex = N;
	info (39).generic = N;

	info (40).computational = Y;			/* comp-5 unsigned byte aligned */
	info (40).arithmetic = Y;
	info (40).fixed = Y;
	info (40).complex = N;
	info (40).decimal = Y;
	info (40).signed = N;
	info (40).trailing_sign = N;
	info (40).packed_dec = Y;
	info (40).digit_aligned = N;
	info (40).overpunched = N;
	info (40).char_string = N;
	info (40).bit_string = N;
	info (40).varying = N;
	info (40).type = N;
	info (40).hex = N;
	info (40).generic = N;

	info (41).computational = Y;
	info (41).arithmetic = Y;
	info (41).fixed = Y;
	info (41).complex = N;
	info (41).decimal = Y;
	info (41).signed = Y;
	info (41).trailing_sign = N;
	info (41).packed_dec = Y;
	info (41).digit_aligned = Y;
	info (41).overpunched = N;
	info (41).char_string = N;
	info (41).bit_string = N;
	info (41).varying = N;
	info (41).type = N;
	info (41).hex = N;
	info (41).generic = N;

	info (42).computational = Y;
	info (42).arithmetic = Y;
	info (42).fixed = N;
	info (42).complex = N;
	info (42).decimal = Y;
	info (42).signed = Y;
	info (42).trailing_sign = N;
	info (42).packed_dec = Y;
	info (42).digit_aligned = Y;
	info (42).overpunched = N;
	info (42).char_string = N;
	info (42).bit_string = N;
	info (42).varying = N;
	info (42).type = N;
	info (42).hex = N;
	info (42).generic = N;

	info (43).computational = Y;
	info (43).arithmetic = Y;
	info (43).fixed = Y;
	info (43).complex = N;
	info (43).decimal = Y;
	info (43).signed = Y;
	info (43).trailing_sign = N;
	info (43).packed_dec = Y;
	info (43).digit_aligned = N;
	info (43).overpunched = N;
	info (43).char_string = N;
	info (43).bit_string = N;
	info (43).varying = N;
	info (43).type = N;
	info (43).hex = N;
	info (43).generic = N;

	info (44).computational = Y;
	info (44).arithmetic = Y;
	info (44).fixed = N;
	info (44).complex = N;
	info (44).decimal = Y;
	info (44).signed = Y;
	info (44).trailing_sign = N;
	info (44).packed_dec = Y;
	info (44).digit_aligned = N;
	info (44).overpunched = N;
	info (44).char_string = N;
	info (44).bit_string = N;
	info (44).varying = N;
	info (44).type = N;
	info (44).hex = N;
	info (44).generic = N;

	info (45).computational = Y;
	info (45).arithmetic = Y;
	info (45).fixed = Y;
	info (45).complex = Y;
	info (45).decimal = Y;
	info (45).signed = Y;
	info (45).trailing_sign = N;
	info (45).packed_dec = Y;
	info (45).digit_aligned = N;
	info (45).overpunched = N;
	info (45).char_string = N;
	info (45).bit_string = N;
	info (45).varying = N;
	info (45).type = N;
	info (45).hex = N;
	info (45).generic = N;

	info (46).computational = Y;
	info (46).arithmetic = Y;
	info (46).fixed = N;
	info (46).complex = Y;
	info (46).decimal = Y;
	info (46).signed = Y;
	info (46).trailing_sign = N;
	info (46).packed_dec = Y;
	info (46).digit_aligned = N;
	info (46).overpunched = N;
	info (46).char_string = N;
	info (46).bit_string = N;
	info (46).varying = N;
	info (46).type = N;
	info (46).hex = N;
	info (46).generic = N;

	info (47).computational = Y;			/* real_flt_hex_1_dtype */
	info (47).arithmetic = Y;
	info (47).fixed = N;
	info (47).complex = N;
	info (47).decimal = N;
	info (47).signed = Y;
	info (47).trailing_sign = N;
	info (47).packed_dec = N;
	info (47).digit_aligned = N;
	info (47).overpunched = N;
	info (47).char_string = N;
	info (47).bit_string = N;
	info (47).varying = N;
	info (47).type = N;
	info (47).hex = Y;
	info (47).generic = N;

	info (48).computational = Y;			/* real_flt_hex_2_dtype */
	info (48).arithmetic = Y;
	info (48).fixed = N;
	info (48).complex = N;
	info (48).decimal = N;
	info (48).signed = Y;
	info (48).trailing_sign = N;
	info (48).packed_dec = N;
	info (48).digit_aligned = N;
	info (48).overpunched = N;
	info (48).char_string = N;
	info (48).bit_string = N;
	info (48).varying = N;
	info (48).type = N;
	info (48).hex = Y;
	info (48).generic = N;

	info (49).computational = Y;			/* cplx_flt_hex_1_dtype */
	info (49).arithmetic = Y;
	info (49).fixed = N;
	info (49).complex = Y;
	info (49).decimal = N;
	info (49).signed = Y;
	info (49).trailing_sign = N;
	info (49).packed_dec = N;
	info (49).digit_aligned = N;
	info (49).overpunched = N;
	info (49).char_string = N;
	info (49).bit_string = N;
	info (49).varying = N;
	info (49).type = N;
	info (49).hex = Y;
	info (49).generic = N;

	info (50).computational = Y;			/* cplx_flt_hex_2_dtype */
	info (50).arithmetic = Y;
	info (50).fixed = N;
	info (50).complex = Y;
	info (50).decimal = N;
	info (50).signed = Y;
	info (50).trailing_sign = N;
	info (50).packed_dec = N;
	info (50).digit_aligned = N;
	info (50).overpunched = N;
	info (50).char_string = N;
	info (50).bit_string = N;
	info (50).varying = N;
	info (50).type = N;
	info (50).hex = Y;
	info (50).generic = N;

	info (51).computational = N;			/* not used */
	info (51).arithmetic = N;
	info (51).fixed = N;
	info (51).complex = N;
	info (51).decimal = N;
	info (51).signed = N;
	info (51).trailing_sign = N;
	info (51).packed_dec = N;
	info (51).digit_aligned = N;
	info (51).overpunched = N;
	info (51).char_string = N;
	info (51).bit_string = N;
	info (51).varying = N;
	info (51).type = N;
	info (51).hex = N;
	info (51).generic = N;

	info (52).computational = N;			/* not used */
	info (52).arithmetic = N;
	info (52).fixed = N;
	info (52).complex = N;
	info (52).decimal = N;
	info (52).signed = N;
	info (52).trailing_sign = N;
	info (52).packed_dec = N;
	info (52).digit_aligned = N;
	info (52).overpunched = N;
	info (52).char_string = N;
	info (52).bit_string = N;
	info (52).varying = N;
	info (52).type = N;
	info (52).hex = N;
	info (52).generic = N;

	info (53).computational = N;			/* not used */
	info (53).arithmetic = N;
	info (53).fixed = N;
	info (53).complex = N;
	info (53).decimal = N;
	info (53).signed = N;
	info (53).trailing_sign = N;
	info (53).packed_dec = N;
	info (53).digit_aligned = N;
	info (53).overpunched = N;
	info (53).char_string = N;
	info (53).bit_string = N;
	info (53).varying = N;
	info (53).type = N;
	info (53).hex = N;
	info (53).generic = N;

	info (54).computational = N;			/* not used */
	info (54).arithmetic = N;
	info (54).fixed = N;
	info (54).complex = N;
	info (54).decimal = N;
	info (54).signed = N;
	info (54).trailing_sign = N;
	info (54).packed_dec = N;
	info (54).digit_aligned = N;
	info (54).overpunched = N;
	info (54).char_string = N;
	info (54).bit_string = N;
	info (54).varying = N;
	info (54).type = N;
	info (54).hex = N;
	info (54).generic = N;

	info (55).computational = N;			/* not used */
	info (55).arithmetic = N;
	info (55).fixed = N;
	info (55).complex = N;
	info (55).decimal = N;
	info (55).signed = N;
	info (55).trailing_sign = N;
	info (55).packed_dec = N;
	info (55).digit_aligned = N;
	info (55).overpunched = N;
	info (55).char_string = N;
	info (55).bit_string = N;
	info (55).varying = N;
	info (55).type = N;
	info (55).hex = N;
	info (55).generic = N;

	info (56).computational = N;			/* not used */
	info (56).arithmetic = N;
	info (56).fixed = N;
	info (56).complex = N;
	info (56).decimal = N;
	info (56).signed = N;
	info (56).trailing_sign = N;
	info (56).packed_dec = N;
	info (56).digit_aligned = N;
	info (56).overpunched = N;
	info (56).char_string = N;
	info (56).bit_string = N;
	info (56).varying = N;
	info (56).type = N;
	info (56).hex = N;
	info (56).generic = N;

	info (57).computational = N;			/* not used */
	info (57).arithmetic = N;
	info (57).fixed = N;
	info (57).complex = N;
	info (57).decimal = N;
	info (57).signed = N;
	info (57).trailing_sign = N;
	info (57).packed_dec = N;
	info (57).digit_aligned = N;
	info (57).overpunched = N;
	info (57).char_string = N;
	info (57).bit_string = N;
	info (57).varying = N;
	info (57).type = N;
	info (57).hex = N;
	info (57).generic = N;

	info (58).computational = N;			/* not used */
	info (58).arithmetic = N;
	info (58).fixed = N;
	info (58).complex = N;
	info (58).decimal = N;
	info (58).signed = N;
	info (58).trailing_sign = N;
	info (58).packed_dec = N;
	info (58).digit_aligned = N;
	info (58).overpunched = N;
	info (58).char_string = N;
	info (58).bit_string = N;
	info (58).varying = N;
	info (58).type = N;
	info (58).hex = N;
	info (58).generic = N;

	info (59).computational = N;			/* algol68 straight */
	info (59).arithmetic = N;
	info (59).fixed = N;
	info (59).complex = N;
	info (59).decimal = N;
	info (59).signed = N;
	info (59).trailing_sign = N;
	info (59).packed_dec = N;
	info (59).digit_aligned = N;
	info (59).overpunched = N;
	info (59).char_string = N;
	info (59).bit_string = N;
	info (59).varying = N;
	info (59).type = N;
	info (59).hex = N;
	info (59).generic = N;

	info (60).computational = N;			/* algol68 format */
	info (60).arithmetic = N;
	info (60).fixed = N;
	info (60).complex = N;
	info (60).decimal = N;
	info (60).signed = N;
	info (60).trailing_sign = N;
	info (60).packed_dec = N;
	info (60).digit_aligned = N;
	info (60).overpunched = N;
	info (60).char_string = N;
	info (60).bit_string = N;
	info (60).varying = N;
	info (60).type = N;
	info (60).hex = N;
	info (60).generic = N;

	info (61).computational = N;			/* algol68 array descriptor */
	info (61).arithmetic = N;
	info (61).fixed = N;
	info (61).complex = N;
	info (61).decimal = N;
	info (61).signed = N;
	info (61).trailing_sign = N;
	info (61).packed_dec = N;
	info (61).digit_aligned = N;
	info (61).overpunched = N;
	info (61).char_string = N;
	info (61).bit_string = N;
	info (61).varying = N;
	info (61).type = N;
	info (61).hex = N;
	info (61).generic = N;

	info (62).computational = N;			/* algol68 union */
	info (62).arithmetic = N;
	info (62).fixed = N;
	info (62).complex = N;
	info (62).decimal = N;
	info (62).signed = N;
	info (62).trailing_sign = N;
	info (62).packed_dec = N;
	info (62).digit_aligned = N;
	info (62).overpunched = N;
	info (62).char_string = N;
	info (62).bit_string = N;
	info (62).varying = N;
	info (62).type = N;
	info (62).hex = N;
	info (62).generic = N;

	info (63).computational = Y;			/* picture */
	info (63).arithmetic = N;
	info (63).fixed = N;
	info (63).complex = N;
	info (63).decimal = N;
	info (63).signed = N;
	info (63).trailing_sign = N;
	info (63).packed_dec = N;
	info (63).digit_aligned = N;
	info (63).overpunched = N;
	info (63).char_string = N;
	info (63).bit_string = N;
	info (63).varying = N;
	info (63).type = N;
	info (63).hex = N;
	info (63).generic = N;

	info (64).computational = N;			/* pascal_typed_pointer_type_dtype */
	info (64).arithmetic = N;
	info (64).fixed = N;
	info (64).complex = N;
	info (64).decimal = N;
	info (64).signed = N;
	info (64).trailing_sign = N;
	info (64).packed_dec = N;
	info (64).digit_aligned = N;
	info (64).overpunched = N;
	info (64).char_string = N;
	info (64).bit_string = N;
	info (64).varying = N;
	info (64).type = Y;
	info (64).hex = N;
	info (64).generic = N;

	info (65).computational = N;			/* pascal_char_dtype */
	info (65).arithmetic = N;
	info (65).fixed = N;
	info (65).complex = N;
	info (65).decimal = N;
	info (65).signed = N;
	info (65).trailing_sign = N;
	info (65).packed_dec = N;
	info (65).digit_aligned = N;
	info (65).overpunched = N;
	info (65).char_string = N;
	info (65).bit_string = N;
	info (65).varying = N;
	info (65).type = N;
	info (65).hex = N;
	info (65).generic = N;

	info (66).computational = N;			/*pascal_boolean_dtype*/
	info (66).arithmetic = N;
	info (66).fixed = N;
	info (66).complex = N;
	info (66).decimal = N;
	info (66).signed = N;
	info (66).trailing_sign = N;
	info (66).packed_dec = N;
	info (66).digit_aligned = N;
	info (66).overpunched = N;
	info (66).char_string = N;
	info (66).bit_string = N;
	info (66).varying = N;
	info (66).type = N;
	info (66).hex = N;
	info (66).generic = N;

	info (67).computational = N;			/* pascal_record_file_type_dtype*/
	info (67).arithmetic = N;
	info (67).fixed = N;
	info (67).complex = N;
	info (67).decimal = N;
	info (67).signed = N;
	info (67).trailing_sign = N;
	info (67).packed_dec = N;
	info (67).digit_aligned = N;
	info (67).overpunched = N;
	info (67).char_string = N;
	info (67).bit_string = N;
	info (67).varying = N;
	info (67).type = Y;
	info (67).hex = N;
	info (67).generic = N;

	info (68).computational = N;			/*pascal_record_type_dtype*/
	info (68).arithmetic = N;
	info (68).fixed = N;
	info (68).complex = N;
	info (68).decimal = N;
	info (68).signed = N;
	info (68).trailing_sign = N;
	info (68).packed_dec = N;
	info (68).digit_aligned = N;
	info (68).overpunched = N;
	info (68).char_string = N;
	info (68).bit_string = N;
	info (68).varying = N;
	info (68).type = Y;
	info (68).hex = N;
	info (68).generic = N;

	info (69).computational = N;			/*pascal_set_type_dtype*/
	info (69).arithmetic = N;
	info (69).fixed = N;
	info (69).complex = N;
	info (69).decimal = N;
	info (69).signed = N;
	info (69).trailing_sign = N;
	info (69).packed_dec = N;
	info (69).digit_aligned = N;
	info (69).overpunched = N;
	info (69).char_string = N;
	info (69).bit_string = N;
	info (69).varying = N;
	info (69).type = Y;
	info (69).hex = N;
	info (69).generic = N;

	info (70).computational = N;			/*pascal_enumerated_type_dtype*/
	info (70).arithmetic = N;
	info (70).fixed = N;
	info (70).complex = N;
	info (70).decimal = N;
	info (70).signed = N;
	info (70).trailing_sign = N;
	info (70).packed_dec = N;
	info (70).digit_aligned = N;
	info (70).overpunched = N;
	info (70).char_string = N;
	info (70).bit_string = N;
	info (70).varying = N;
	info (70).type = Y;
	info (70).hex = N;
	info (70).generic = N;

	info (71).computational = N;			/*pascal_enumerated_type_element_dtype*/
	info (71).arithmetic = N;
	info (71).fixed = N;
	info (71).complex = N;
	info (71).decimal = N;
	info (71).signed = N;
	info (71).trailing_sign = N;
	info (71).packed_dec = N;
	info (71).digit_aligned = N;
	info (71).overpunched = N;
	info (71).char_string = N;
	info (71).bit_string = N;
	info (71).varying = N;
	info (71).type = N;
	info (71).hex = N;
	info (71).generic = N;

	info (72).computational = N;			/*pascal_enumerated_type_instance_dtype*/
	info (72).arithmetic = N;
	info (72).fixed = N;
	info (72).complex = N;
	info (72).decimal = N;
	info (72).signed = N;
	info (72).trailing_sign = N;
	info (72).packed_dec = N;
	info (72).digit_aligned = N;
	info (72).overpunched = N;
	info (72).char_string = N;
	info (72).bit_string = N;
	info (72).varying = N;
	info (72).type = N;
	info (72).hex = N;
	info (72).generic = N;

	info (73).computational = N;			/*pascal_user_defined_type_dtype */
	info (73).arithmetic = N;
	info (73).fixed = N;
	info (73).complex = N;
	info (73).decimal = N;
	info (73).signed = N;
	info (73).trailing_sign = N;
	info (73).packed_dec = N;
	info (73).digit_aligned = N;
	info (73).overpunched = N;
	info (73).char_string = N;
	info (73).bit_string = N;
	info (73).varying = N;
	info (73).type = Y;
	info (73).hex = N;
	info (73).generic = N;

	info (74).computational = N;			/* pascal_user_defined_type_instance_dtype */
	info (74).arithmetic = N;
	info (74).fixed = N;
	info (74).complex = N;
	info (74).decimal = N;
	info (74).signed = N;
	info (74).trailing_sign = N;
	info (74).packed_dec = N;
	info (74).digit_aligned = N;
	info (74).overpunched = N;
	info (74).char_string = N;
	info (74).bit_string = N;
	info (74).varying = N;
	info (74).type = N;
	info (74).hex = N;
	info (74).generic = N;

	info (75).computational = N;			/* pascal_text_file_dtype*/
	info (75).arithmetic = N;
	info (75).fixed = N;
	info (75).complex = N;
	info (75).decimal = N;
	info (75).signed = N;
	info (75).trailing_sign = N;
	info (75).packed_dec = N;
	info (75).digit_aligned = N;
	info (75).overpunched = N;
	info (75).char_string = N;
	info (75).bit_string = N;
	info (75).varying = N;
	info (75).type = N;
	info (75).hex = N;
	info (75).generic = N;

	info (76).computational = N;			/* pascal_procedure_type_dtype */
	info (76).arithmetic = N;
	info (76).fixed = N;
	info (76).complex = N;
	info (76).decimal = N;
	info (76).signed = N;
	info (76).trailing_sign = N;
	info (76).packed_dec = N;
	info (76).digit_aligned = N;
	info (76).overpunched = N;
	info (76).char_string = N;
	info (76).bit_string = N;
	info (76).varying = N;
	info (76).type = Y;
	info (76).hex = N;
	info (76).generic = N;

	info (77).computational = N;			/* pascal_var_formal_parm_dtype*/
	info (77).arithmetic = N;
	info (77).fixed = N;
	info (77).complex = N;
	info (77).decimal = N;
	info (77).signed = N;
	info (77).trailing_sign = N;
	info (77).packed_dec = N;
	info (77).digit_aligned = N;
	info (77).overpunched = N;
	info (77).char_string = N;
	info (77).bit_string = N;
	info (77).varying = N;
	info (77).type = N;
	info (77).hex = N;
	info (77).generic  = N;

	info (78).computational = N;			/* pascal_value_formal_parm_dtype*/
	info (78).arithmetic = N;
	info (78).fixed = N;
	info (78).complex = N;
	info (78).decimal = N;
	info (78).signed = N;
	info (78).trailing_sign = N;
	info (78).packed_dec = N;
	info (78).digit_aligned = N;
	info (78).overpunched = N;
	info (78).char_string = N;
	info (78).bit_string = N;
	info (78).varying = N;
	info (78).type = N;
	info (78).hex = N;
	info (78).generic = N;

	info (79).computational = N;			/* pascal_parameter_procedure_dtype*/
	info (79).arithmetic = N;
	info (79).fixed = N;
	info (79).complex = N;
	info (79).decimal = N;
	info (79).signed = N;
	info (79).trailing_sign = N;
	info (79).packed_dec = N;
	info (79).digit_aligned = N;
	info (79).overpunched = N;
	info (79).char_string = N;
	info (79).bit_string = N;
	info (79).varying = N;
	info (79).type = N;
	info (79).hex = N;
	info (79).generic = N;

	info (80).computational = N;			/* pascal_entry_formal_parm_dtype*/
	info (80).arithmetic = N;
	info (80).fixed = N;
	info (80).complex = N;
	info (80).decimal = N;
	info (80).signed = N;
	info (80).trailing_sign = N;
	info (80).packed_dec = N;
	info (80).digit_aligned = N;
	info (80).overpunched = N;
	info (80).char_string = N;
	info (80).bit_string = N;
	info (80).varying = N;
	info (80).type = N;
	info (80).hex = N;
	info (80).generic = N;

	info (81).computational = Y;			/* real_flt_dec_extended_dtype */
	info (81).arithmetic = Y;
	info (81).fixed = N;
	info (81).complex = N;
	info (81).decimal = Y;
	info (81).signed = Y;
	info (81).trailing_sign = N;
	info (81).packed_dec = N;
	info (81).digit_aligned = N;
	info (81).overpunched = N;
	info (81).char_string = N;
	info (81).bit_string = N;
	info (81).varying = N;
	info (81).type = N;
	info (81).hex = N;
	info (81).generic = N;

	info (82).computational = Y;			/* cplx_flt_dec_extended_dtype */
	info (82).arithmetic = Y;
	info (82).fixed = N;
	info (82).complex = Y;
	info (82).decimal = Y;
	info (82).signed = Y;
	info (82).trailing_sign = N;
	info (82).packed_dec = N;
	info (82).digit_aligned = N;
	info (82).overpunched = N;
	info (82).char_string = N;
	info (82).bit_string = N;
	info (82).varying = N;
	info (82).type = N;
	info (82).hex = N;
	info (82).generic = N;

	info (83).computational = Y;			/* real_flt_dec_generic_dtype */
	info (83).arithmetic = Y;
	info (83).fixed = N;
	info (83).complex = N;
	info (83).decimal = Y;
	info (83).signed = Y;
	info (83).trailing_sign = N;
	info (83).packed_dec = N;
	info (83).digit_aligned = N;
	info (83).overpunched = N;
	info (83).char_string = N;
	info (83).bit_string = N;
	info (83).varying = N;
	info (83).type = N;
	info (83).hex = N;
	info (83).generic = Y;

	info (84).computational = Y;			/* cplx_flt_dec_generic_dtype */
	info (84).arithmetic = Y;
	info (84).fixed = N;
	info (84).complex = Y;
	info (84).decimal = Y;
	info (84).signed = N;
	info (84).trailing_sign = N;
	info (84).packed_dec = N;
	info (84).digit_aligned = N;
	info (84).overpunched = N;
	info (84).char_string = N;
	info (84).bit_string = N;
	info (84).varying = N;
	info (84).type = N;
	info (84).hex = N;
	info (84).generic = Y;

	info (85).computational = Y;			/* real_flt_bin_generic_dtype */
	info (85).arithmetic = Y;
	info (85).fixed = N;
	info (85).complex = N;
	info (85).decimal = N;
	info (85).signed = Y;
	info (85).trailing_sign = N;
	info (85).packed_dec = N;
	info (85).digit_aligned = N;
	info (85).overpunched = N;
	info (85).char_string = N;
	info (85).bit_string = N;
	info (85).varying = N;
	info (85).type = N;
	info (85).hex = N;
	info (85).generic = Y;

	info (86).computational = Y;			/* cplx_flt_bin_generic_dtype */
	info (86).arithmetic = Y;
	info (86).fixed = N;
	info (86).complex = Y;
	info (86).decimal = N;
	info (86).signed = Y;
	info (86).trailing_sign = N;
	info (86).packed_dec = N;
	info (86).digit_aligned = N;
	info (86).overpunched = N;
	info (86).char_string = N;
	info (86).bit_string = N;
	info (86).varying = N;
	info (86).type = N;
	info (86).hex = N;
	info (86).generic = Y;

	info (87).computational = N;			/* pascal_string_type_dtype */
	info (87).arithmetic = N;
	info (87).fixed = N;
	info (87).complex = N;
	info (87).decimal = N;
	info (87).signed = N;
	info (87).trailing_sign = N;
	info (87).packed_dec = N;
	info (87).digit_aligned = N;
	info (87).overpunched = N;
	info (87).char_string = N;
	info (87).bit_string = N;
	info (87).varying = N;
	info (87).type = Y;
	info (87).hex = N;
	info (87).generic = N;

     end fillin;


init_cds_struc: proc;


	unspec (cdsa) = "0"b;
	cdsa.seg_name = "data_type_info_";
	cdsa.sections (1).p = addr (dti_struc);
	cdsa.sections (1).len = size (dti_struc);
	cdsa.sections (1).struct_name = "dti_struc";

	cdsa.sections (2).p = null;
	cdsa.sections (2).len = 0;
	cdsa.sections (2).struct_name = "";

	cdsa.num_exclude_names = hbound (exclude, 1);
	cdsa.exclude_array_ptr = addr (exclude);

	string (cdsa.switches) = "0"b;
	cdsa.switches.defs_in_link = "0"b;
	cdsa.switches.separate_static = "0"b;
	cdsa.switches.have_text = "1"b;
	cdsa.switches.have_static = "0"b;

     end;

%include cds_args;
%include data_type_info_;
     end;						/* program */



		    disassemble.pl1                 04/07/83  1606.7rew 04/07/83  1051.5       69570


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

dissassemble:	disassemble:	procedure ( data_ptr, ret_string, instr_word_num );


/*	This procedure is called to produce a character string, symbolic
*	representation of an instruction word (an instruction in object form).
*
*	Rewritten on  Nov 9, 1972  for the  6180  by  Bill Silver.
*/


dcl	data_ptr	    ptr,		/* The input pointer to the object instruction
				*  word to be  dissassembled. */

	ret_string    char (72) var,	/* The return string which will contain the
				*  instruction in symbolic form.  */

	instr_word_num	fixed bin;	/* The number of the instruction word to be
					*  processed.
					*  0 => process word 1 - do not return anything
					*  1 => process word 1 - return the number of
					*       words in this instrruction in instr_word_num
					*  2-4 => process one of the descriptors.
					*       The data_ptr must still point to the
					*       instruction word.  */


dcl	real_ilc fixed bin(18);	/* The program offset of the instruction */
				/* when it is being taken from the break map */


dcl  1 op_mnemonic_$op_mnemonic(0:1023) ext static aligned,
	2 opcode		char(6) unal,
	2 dtype		fixed bin(2) unal,
	2 num_desc	fixed bin(5) unal,
	2 num_words	fixed bin(8) unal;

dcl	opcode	    fixed bin,	/* A numeric representation of the opcode.  */

	offset	    fixed bin(17);	/* The value of the instruction offset. */

dcl	note_offset fixed bin(17);	/* result of ic modification. */

dcl	mnemonic	    char (6),	/* Op code name. */

	sym_pr	    char (4),	/* Symbolic pointer register field. */

	sym_tag	    char (4),	/* Symbolic tag field. */

	note	    char (24);	/* Special message returned with instruction. */


dcl	string_len    fixed bin;		/* A dummy return variable  -  length of
					*  string returned by  ioa_$rsnnl.  */

dcl	word	    fixed bin (35)	based;	/* Used to reference 1 word of data. */

dcl	ic_word	    fixed bin (35);		/* Word referenced by computed address
					*  of an instruction that has  "ic"
					*  modification.  */


dcl	out_of_bounds	condition;

dcl	ioa_$rsnnl	entry	options(variable);


dcl	( addrel, fixed, rel, substr )	builtin;
/**/
% include db_inst;
/**/
% include db_data_map;
/**/
	real_ilc = fixed(rel(data_ptr), 18);

join:
	ilc_ptr  =  data_ptr;	/* Copy argument pointer to instruction. */

	note  =  " ";		/* We don't usually have to return a note. */


	opcode  =  fixed(ilc_ptr -> instr.opcode);	/* Get numeric value of op code. */

	mnemonic  =  op_mnemonic_$op_mnemonic(opcode).opcode;	/* Get op code opcode. */


/*	Find out which instruction word we must test.  If the word to be tested is greater
*	thane the number of words in the instruction then there is an error.  If it is
*	OK then we will transfer to the routine which will process this particular word
*	of the instruction.
*/

	if	op_mnemonic_$op_mnemonic(opcode).num_words < instr_word_num

		then  do;
		ret_string  =  "Error in call to disassemble - word number too big.";
		return;
		end;

	goto	instruction_word ( instr_word_num );


instruction_word(0):			/* This is the first word of the instruction. */
instruction_word(1):


/*	Look for multi-word instruction.  */

	if	op_mnemonic_$op_mnemonic(opcode).num_words  >  1

		then  do;				/* This is a multi-word instr. */
		call	multi_word_instr;
		return;
		end;


/*	Now get the  pr  name if there is one.  Note, the presence of the  pr  field
*	will imply that there is a small offset field.
*/
	if	ilc_ptr -> instr.pr_bit

		then  do;
		sym_pr  =  substr( db_data$names( fixed( ilc_ptr->instr_pr.pr ) ), 1,3)  ||  "|";
		offset  =  ilc_ptr -> instr_pr.offset;
		end;

		else  do;
		sym_pr  =  " ";
		offset  =  ilc_ptr -> instr.offset;
		end;


/*	Now get the tag field.  Note, some instructions use their tag fields in non
*	standard ways.   Also special processing is required for the  "ic"  modifier.
*/

	if	op_mnemonic_$op_mnemonic(opcode).num_desc  =  0

		then  do;				/* Standard tag field. */
		sym_tag  =  db_data$tags(fixed(ilc_ptr->instr.tag));
		if	sym_tag  =  ",ic"
			then  call  ic_modifier;
		end;


/*	Non standard tag field.  Get octal representation.  */

		else  call  ioa_$rsnnl(",^o", sym_tag, string_len, fixed(ilc_ptr->instr.tag, 17));


/*	Now generate the return string.  */

	call	ioa_$rsnnl("^6o   ^w     ^8a^a^o^a^a", ret_string, string_len,
		real_ilc,  ilc_ptr -> word, mnemonic,
		sym_pr, offset, sym_tag, note);


	return;


with_ilc:	entry(data_ptr, ret_string, instr_word_num, arg_ilc);

dcl	arg_ilc fixed bin(18);

/* This entry is used when the instruction being disassembled is in the
*  break map. The fourth argument contains the original offset of the instrucion.
*/


	real_ilc = arg_ilc;
	go to join;
/**/
instruction_word(2):
instruction_word(3):
instruction_word(4):

	/* make sure we point to the right word */

	real_ilc = real_ilc + instr_word_num - 1;
	ilc_ptr = addrel(ilc_ptr, instr_word_num - 1);

	call	ioa_$rsnnl ("^6o   ^w^-^5x(EIS desc.)",
		ret_string, string_len, real_ilc, ilc_ptr -> word );

	return;
multi_word_instr:	procedure;


/*	This procedure returns a string that will print a multi-word instruction.
*	We don't want to actually dissassemble it.  We will just print a note telling
*	that  it is a multi-word instruction and then the octal representation of the
*	of the instruction word.
*/


/*	We must test to see if we have to return the number of words in this instruction.
*	If the argument  instr_word_num  =  0  then the caller does not want us to return
*	this data.
*/

	if	instr_word_num  =  1

		then    instr_word_num  =  op_mnemonic_$op_mnemonic(opcode).num_words;


	call	ioa_$rsnnl ("^6o   ^w     ^8a (EIS)",
		ret_string, string_len,
		real_ilc, ilc_ptr -> word, mnemonic);


	end	multi_word_instr;
/**/
ic_modifier:	procedure;


/*	This procedure produces a special note which is appended to the end of a
*	dissassembled instruction which uses  ic  modification.
*/

	if	ilc_ptr->instr.pr_bit	/* If there is a  pr  field just forget */
		then  return;		/* it.  Too complicated and too rare to
					*  worry about.  */

/*	No  pr  field implies that the computed address of the instruction will be in
*	the procedure segment.  We will try to retrieve the word the computed address
*	references.  If the computed address is out of the bounds of the segment then
*	we will set up a special note.
*/

	on	condition  (out_of_bounds)

	begin;				/* Execute here only if out of bounds
					*  condition signalled. */

	note  =  "    (address not in seg)";	/* Set up special note. */

	goto	revert_oob_cond;		/* Go eliminate the condition. */

	end;


/*	The next statement is executed after the  "on"  statement.  This is where
*	the  out of bounds  may occur.
*/

	ic_word  =  addrel(ptr(ilc_ptr, real_ilc), offset) -> word;


revert_oob_cond:

	revert  condition (out_of_bounds);	/* Turn off condition. */

/*	If  note  not equal to blank then the condition was signalled and we will
*	just return.  If it is still blank then the computed address was within
*	the bounds of the segment.  Thus the  note  will contain the computed
*	address and the word that it references.
*/

	if	note  ^=  " "  then  return;

	note_offset  =  offset + real_ilc;

	call  ioa_$rsnnl ("^-  ^6o   ^w", note, string_len, note_offset, ic_word);


	end	ic_modifier;


	end	disassemble;
  



		    find_condition_frame_.pl1       11/05/86  1218.8r w 11/04/86  1033.8       27216


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

find_condition_frame_:	proc(startp) returns(ptr);

/* This procedure returns a pointer to the stack frame associated with the most recent
   condition to occur before the stack frame pointer to be startp.
   It is written to work with an arbitrary stack segment.

	coded by M. Weaver 20 June 1973 */

/* Changed to view stack_frame.return_ptr through RETURN_PTR_MASK 03/07/84 S. Herbst */

declare	startp ptr;
declare	sig_caller_count fixed bin;
declare	cu_$stack_frame_ptr entry(ptr);
declare	(null, ptr, rel) builtin;

%include stack_frame;


%include stack_header;

/**/
	/* get starting pointer if not provided */

	if startp = null then call cu_$stack_frame_ptr(sp);
	else sp = startp;
	sb = ptr(sp, 0);
	sig_caller_count = 0;

	/* We may need to skip the first frame--it may be the frame found
	   the last time around; but we don't ignore it since it could still affect
	   interpretation of the next level */

	if sp -> stack_frame_flags.signaller then do;

	     if sp -> stack_frame.entry_ptr = sb -> stack_header.signal_ptr
		then sig_caller_count = 2;	/* have found signal frame */

	     sp = ptr(sp, rel(sp -> stack_frame.prev_sp));  /* skip this frame */

	end;

	/* Loop through the stack looking for a condition frame.
	   If a signal frame is found, we must determine whether signal_ was
	   invoked for a software condition or a hardware fault.
	   If there is a signaller flag 2 frames before the signal_ frame, there
	   was a hardware fault; otherwise the condition is associated
	   with the caller of signal_ */

	do while (sp ^= null);

	     if sp -> stack_frame_flags.signaller then return(sp);	/* this frame got fault */

	     if sp -> stack_frame_flags.crawl_out
		then if unspec (sp -> stack_frame.return_ptr) & RETURN_PTR_MASK ^=
		     unspec (sb -> stack_header.unwinder_ptr) & RETURN_PTR_MASK
						/* flag is also set by unwinder_ */
			then return (ptr(sp, rel(sp -> stack_frame.prev_sp)));

	     if sig_caller_count = 1 then return (ptr(sp, rel(sp -> stack_frame.next_sp)));
				/* didn't find signaller frame; must have software condition */

	     else if sig_caller_count = 2 then sig_caller_count = 1;  /* must go back one more */

	     else if sp -> stack_frame_flags.signal
		then sig_caller_count = 2;	/* note existence of signal_ frame */

	     if sp -> stack_frame.prev_sp = null then sp = null;	/* must special case null */
	     else sp = ptr(sp, rel(sp -> stack_frame.prev_sp));	/* go look at previous frame */

	end;

	return (sp);			/* no condition frames; return null */
	end find_condition_frame_;



		    find_condition_info_.pl1        11/05/86  1218.8r w 11/04/86  1033.8       84897


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

find_condition_info_: proc (a_sp, a_cip, a_code);

/* This procedure is given a pointer to a stack frame being used when a condition occurred
   and returns the information relevant to that condition.
   0)  coded by M. Weaver  6 / 21 / 73
   1)  modified by C. D. Tavares on 09/28/78 to fix bug where signal_ args were
   always assumed to be in stack (via dead process code)
   2)  modified by JRDavis  10 May 79 to use new include file arg_list.incl, stackframeptr () */
/* Fixed not to fault if no condition frame 12/12/79 S. Herbst */
/* Fixed to initialize fff_sw correctly 11/22/83 by M. Weaver */
/* Changed to copy stack_frame.return_ptr through RETURN_PTR_MASK 03/07/84 S. Herbst */


declare (a_sp, a_cip, nsp, locp, callp, temptr) ptr;
declare  ptra (0 : 10) ptr based aligned;
declare  bptr ptr based;
declare  ap ptr;					/* to arg list */
declare  live_stack bit (1) aligned,
         old_stack_segno bit (18);

declare (a_code, code) fixed bin (35);
declare  error_table_$noentry ext fixed bin (35);
declare (lng, nargs) fixed bin;

declare  op_name char (32) aligned;
declare  bchar char (lng) based unaligned;

declare (fff_sw, trap_sw, frame_flag) bit (1) aligned;
declare  spno bit (18) aligned;


declare  find_condition_frame_ entry (ptr) returns (ptr);
declare  is_condition_frame_ entry (ptr) returns (bit (1) aligned);
declare  interpret_op_ptr_ entry (ptr, ptr, ptr, char (32) aligned, bit (1) aligned);
declare (addr, addrel, baseno, baseptr, bin, null, pointer, ptr, rel, rtrim, stackframeptr, substr) builtin;

declare 1 string_desc aligned based,			/* overlay of string descriptor */
        2 xxx bit (18) unaligned,
        2 string_lng bit (18) unaligned;

declare 1 auto_cond_info like condition_info;

%include arg_list;

%include its;

%include stack_frame;

%include stack_header;
%include mc;
%include condition_info;
/* this procedure is coded to work on any stack, even a defunct one */

	condition_info_ptr = a_cip;
	fff_sw = "0"b;

	if a_sp = null then do;
	     sp = find_condition_frame_ (a_sp);
	     if sp = null then go to error;
	end;
	else sp = a_sp;

	if baseno (stackframeptr ()) = baseno (sp)	/* is supplied stack ptr same seg as our stack ? */
	then live_stack = "1"b;

	else do;
	     live_stack = ""b;			/* we are debugging a dead stack */
	     old_stack_segno = baseno (pointer (sp, 0) -> stack_header.stack_begin_ptr);
	end;

common:	code = 0;
	trap_sw = "0"b;				/* usually have real condition */

/* initialize output structure */

	condition_info.mc_ptr, condition_info.info_ptr, condition_info.wc_ptr, condition_info.loc_ptr = null;
	condition_info.condition_name = " ";
	condition_info.flags.crawlout = "0"b;

	if sp = null then go to error;		/* have no stack seg to look at */
	if a_sp ^= null				/* check for valid condition frame */
	then if ^is_condition_frame_ (sp) then go to error; /* no valid info */

/* check to be sure we in fact have a condition frame; also we have to know
   type of condition so we know where to find info */

	nsp = translate_ptr (sp -> stack_frame.next_sp);	/* get ptr to next frame */

	if sp -> stack_frame_flags.signaller then do;	/* had a fault */

	     if nsp -> stack_frame_flags.link_trap then trap_sw = "1"b;

	     else ap = translate_ptr (translate_ptr (nsp -> stack_frame.next_sp) -> stack_frame.arg_ptr);
						/* get ptr to signaller arg list */

	end;

	else do;					/* have crawlout or software signal */
	     if nsp -> stack_frame_flags.signal
	     then ap = translate_ptr (nsp -> stack_frame.arg_ptr);
	     else do;				/* only one more possibility left */
		if nsp -> stack_frame_flags.crawl_out then do;
		     ap = translate_ptr (nsp -> stack_frame.operator_and_lp_ptr);
		     condition_info.flags.crawlout = "1"b;
		end;
		else do;
error:		     code = error_table_$noentry;
		     go to return;
		end;
	     end;
	end;

/* fill output structure */

	if ^trap_sw then do;			/* get info from arg list */

	     if ap = null then go to error;		/* real ap was null ptr */
	     nargs = ap -> arg_list.arg_count;
	     if nargs < 1 | nargs > 4 then go to error;
	     go to fill_in (nargs);

fill_in (4):   condition_info.wc_ptr = translate_ptr (translate_ptr (ap -> ptra (4)) -> bptr);

fill_in (3):   condition_info.info_ptr = translate_ptr (translate_ptr (ap -> ptra (3)) -> bptr);

fill_in (2):   condition_info.mc_ptr = translate_ptr (translate_ptr (ap -> ptra (2)) -> bptr);

fill_in (1):   lng = bin (translate_ptr (ap -> ptra (nargs+1)) -> string_lng, 18);
						/* get name length from descriptor */
	     temptr = translate_ptr (ap -> ptra (1));
	     condition_info.condition_name = rtrim (substr (temptr -> bchar, 1, lng));
	end;

	else do;					/* link trap; not condition but did not call out of last frame */
	     condition_info.mc_ptr = addrel (nsp, 48);	/* have only machine conditions */
	     condition_info.condition_name = "fault_tag_2"; /* return something to distinguish this */
	end;

/* find out which, if any, mc we have to work with */

	if condition_info.wc_ptr ^= null then mcp = condition_info.wc_ptr; /* crawlout; left ring with fault */

	else if condition_info.flags.crawlout | (condition_info.mc_ptr = null) then mcp = null;

	else mcp = condition_info.mc_ptr;		/* have mc for this ring */

/* if condition occurred in pl1_operators_, find transfer point */

	if live_stack then
	     call interpret_op_ptr_ (mcp, sp, callp, op_name, frame_flag);
	else do;
	     callp = null;
	     op_name = "";
	     frame_flag = "1"b;
	end;

/* fill in loc_ptr */

	if callp ^= null then locp = callp;		/* this will be more useful */
	else if mcp ^= null then do;			/* use ppr from mc */
	     scup = addr (mcp -> mc.scu (0));
	     locp = ptr (baseptr (bin (bin (scup -> scu.ppr.psr, 15), 18)),
		scup -> scu.ilc);
	end;
	else do;					/* assume signal_ was called */
	     unspec (locp) = unspec (sp -> stack_frame.return_ptr) & RETURN_PTR_MASK;
	     if rel (locp) ^= "0"b
	     then locp = addrel (locp, -1);
	end;

	condition_info.loc_ptr, condition_info.user_loc_ptr = locp;

	if ^fff_sw then
	     if sp -> stack_frame_flags.support then do;	/* find most recent nonsupport frame */
		nsp = sp;
		spno = baseno (sp -> stack_frame.next_sp);
		do while (baseno (nsp -> stack_frame.prev_sp) = spno);
		     nsp = translate_ptr (nsp -> stack_frame.prev_sp);
		     if ^nsp -> stack_frame_flags.support then do; /* found one */
						/* see if this is condition frame; if it is, can't use ret_ptr */
			if is_condition_frame_ (nsp) then do;
			     call find_condition_info_ (nsp, addr (auto_cond_info), code);
			     if code = 0 then do;	/* have loc_ptr to use */
				condition_info.user_loc_ptr = auto_cond_info.loc_ptr;
				go to return;
			     end;
			end;
			call interpret_op_ptr_ (null, nsp, callp, op_name, frame_flag);
			if callp ^= null then condition_info.user_loc_ptr = callp;
			else do;			/* use return ptr with non-neg offset */
			     unspec (condition_info.user_loc_ptr) =
				unspec (nsp -> stack_frame.return_ptr) & RETURN_PTR_MASK;
			     if rel (condition_info.user_loc_ptr) ^= "0"b
			     then condition_info.user_loc_ptr = addrel (condition_info.user_loc_ptr, -1);
			end;
			go to return;
		     end;
		end;
	     end;

/* if we are in find_fault_frame_, fill in return args */

return:	if fff_sw then do;
	     a_mcp = condition_info.mc_ptr;
	     faultptr = condition_info.loc_ptr;
	     cname = condition_info.condition_name;
	     cop = condition_info.wc_ptr;		/* this isn't compatible but is more useful */
	end;
	else a_code = code;

	return;

/*  */
find_fault_frame_: entry (a_sp, a_mcp, faultsp, faultptr, cop, cname);

/* this interface  is from the precurser to find_condition_info_
   which was written for trace_stack_ */

declare (a_mcp, faultsp, faultptr, cop) ptr;
declare  cname char (32) aligned;

	sp = find_condition_frame_ (a_sp);
	faultsp = sp;

	if sp = null then do;			/* nothing there */
	     a_mcp, faultptr, cop = null;
	     cname = " ";
	     return;
	end;

	condition_info_ptr = addr (auto_cond_info);	/* will use find_condition_info_'s setup */
	fff_sw = "1"b;
	go to common;

translate_ptr: proc (inptr) returns (pointer);

/* This internal procedure translates pointers in dead stacks to pointers
   valid within the process trying to debug them. */

declare  inptr pointer parameter;

	     if live_stack then return (inptr);		/* usual case, easy enough. */

	     if inptr = null then return (inptr);	/* next easiest thing */

	     if baseno (inptr) = old_stack_segno then
		return (pointer (sp, rel (inptr)));

/* If we got here, we have a dead stack, and a pointer to something not in the stack.
   If we ever install a subsystem to debug dead processes, we should put here a call
   to its address-space manager who can tell us what the pointer pointed to and
   what number it goes by in this process.  But for now, we just punt and give
   back the original pointer. */

	     return (inptr);

	end translate_ptr;

     end find_condition_info_;
   



		    find_ls_owner_.pl1              11/05/86  1218.8r w 11/04/86  1033.8       38241


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

find_ls_owner_:	proc(lptr, target, ls_offset);

/* This procedure takes a pointer, presumably to the combined linkage segment, and
	returns the segment number of the owning procedure.
	If the pointer is not to the cls or if it is not a pointer,
	-1 is returned */

/* initially coded as trace_link_ by M. Weaver 17 June 1971 */
/* last modified by M. Weaver 21 August 1971 */
/* recoded as find_ls_owner_ by M. Weaver 11 June 1973 */
/* modified 14 September 1978 by M. Weaver to initialize after_beg, before_end */


/* numbers */

     dcl	(lng, i, hcsct, highct) fixed bin;
     dcl	(target, ls_offset) fixed bin(18);
     dcl	code fixed bin(35);

/* character strings */

     dcl	(dname, pdname) char(168) aligned;
     dcl	(ename, pename) char(32) aligned;

/* bit strings */

     dcl  (tseg, toff, closest_off, lsoff) bit(18) aligned;
     dcl	check_sw bit(1) aligned;

/* pointers */

     dcl	(lptr, linkp based) ptr;

/* entries */

     dcl  hcs_$high_low_seg_count entry(fixed bin, fixed bin);

/* structures */

     dcl	1 lot(0:999) based(lot_ptr) aligned,
		2 (seg, off) bit(18) unal;

/* builtins */
     dcl	(addr, baseno, fixed, ptr, null, rel, substr) builtin;
/**/
%include stack_header;

%include its;

/* * * * * * * * * * * * * * * * * * * * */
	check_sw = "0"b;
	target = -1;			/* initialize; return this if error */
	ls_offset = 0;
common:	if lptr = null then go to return;		/* don't risk simfault */

	/* check to see if we have a real pointer */
	if addr(lptr)->its.its_mod ^= "100011"b then go to return;		/* not a ptr */

	sb = ptr(addr(tseg),0);				/* get ptr to base of stack */

	call hcs_$high_low_seg_count(highct, hcsct);	/* find range */

	/* copy sections of lptr to save accessing time */
	tseg = baseno(lptr);
	toff = rel(lptr);

	if check_sw then go to check;		/* see if ptr points to a cls */

	closest_off = "0"b;		/* keep track of closest linkage header */

	/* loop through LOT looking for a match; if don't find any, lptr doesn't
	   point to a linkage section */
	/* pointer to LOT (linkage offset table) is conveniently stored in stack header */
	do i = hcsct to hcsct + highct;	/* check all possible segs; link won't be pointing to a ring 0 seg */
		lsoff = lot_ptr -> lot(i).off;  /* isolate offset of seg's ls */
		if lot_ptr->lot(i).seg = tseg		/* get correct segment */
		   then if lsoff <= toff	/* could be in range */
		      then if lsoff >= closest_off	/* got better value */
		         then do;
				closest_off = lsoff;	/* update */
				target = i;
				ls_offset = bin(closest_off, 18);
				end;
		end;				/* finished looking */
	return;			/* used only for find_ls_owner_ entry */

check:	stack_seg = baseno(sb);		/* get segno of stack in case cls is there */

	/* assume LOT is contiguous with cls if they are in same seg */
	/* also assume that a ls in a seg other than stack is combined only with other ls's */

	if (baseno(lot_ptr) = tseg) & (rel(lot_ptr) <= toff) then after_beg = "1"b;

	do i = hcsct to hcsct + highct;	/* may need to look at entire LOT */
		lsoff = lot_ptr -> lot(i).off; /* extract ahead of time */
		if lot_ptr -> lot(i).seg = tseg /* same seg */
		     then if tseg ^= stack_seg then do;
yes:			return ("1"b);
			end;
		     else if lsoff > toff
			then if after_beg then go to yes;
			else before_end = "1"b;
		     else if lsoff = toff then go to yes;
		     else if lsoff < toff
			then if before_end then go to yes;
			else after_beg = "1"b;
		end;
	if after_beg & before_end then go to yes;

return:
	if check_sw then return ("0"b);	/* all done */
	else return;
/**/
is_cls_:	entry(lptr) returns(bit(1) aligned);

declare	(after_beg, before_end) bit(1) aligned;
declare	stack_seg bit(18) aligned;

	after_beg, before_end = "0"b;
	check_sw = "1"b;

	go to common;

	end find_ls_owner_;
   



		    find_nonobject_info_.pl1        04/07/83  1606.7rew 04/07/83  1051.5       27333


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

find_nonobject_info_: proc (eptr, ename, owner, section, adj_offset, code);


/* This procedure takes the address of an entry point in the linkage section and
   attempts to return its name */


dcl  eptr pointer;					/* Pointer to the entry point. */
dcl  ename char (*);				/* Entry name output */
dcl  owner fixed bin(18);				/* seg no. of text */
dcl  section char(8) aligned;				/* name of section */
dcl  adj_offset fixed bin(18);			/* offset relative to section */
dcl  code fixed bin (35);				/* Standard File System Error Code. Returned. */


/* Automatic Storage */


dcl  pls pointer;					/* Pointer to the linkage section */
dcl  offset bit (18) aligned;				/* Offset of the entry in the linkage section */
dcl  section_offset fixed bin(18);			/* offset of section within cls */
dcl  (i, class) fixed bin;

/* Externals */


dcl  error_table_$name_not_found ext fixed bin (35);
dcl  get_def_name_ entry (ptr, ptr, bit (18) aligned, fixed bin, char (*), fixed bin (35));
dcl  hcs_$get_lp entry (ptr, ptr);
dcl  find_owner_ entry (ptr, fixed bin(18), fixed bin(18), char(8) aligned, fixed bin, ptr);
dcl (addrel, bit, fixed, null, rel, bin, baseno, ptr, baseptr) builtin;


/* this procedure should be called only for non-object segments */

program_begins_here:

	ename = "";
	section = "text";				/* initialize in case of error */

	if eptr = null then goto error;

	/* be sure this is a linkage section before we go looking for an entry sequence */
	call find_owner_ (eptr, owner, section_offset, section, class, pls);
	if owner = -1 then do;			/* eptr doesn't point to a linkage section,
						   but maybe it points to a seg that has one,
						   as for example a seg created by datmk_ or type 6 link */
	     owner = bin (baseno (eptr), 18);		/* we have ptr to seg itself */
	     offset = rel (eptr);			/* so use offset directly from ptr */
	     class = 0;				/* it's text if anything */
	     section = "text";
	     call hcs_$get_lp (ptr (eptr, 0), pls);
	     if pls = null then do;			/* may have a ring 0 seg (they're
						   not all complete object segs); but
						   must go into r0 to get pls */
		call get_def_name_(null, ptr(eptr, 0), offset, -1, ename, code);
		go to return;
	     end;
	     go to get_name;			/* and forget about entry sequence */
	end;
	offset = bit (fixed (fixed (rel (eptr), 18)-section_offset, 18), 18); /* Offset to entry */

get_name: call get_def_name_ (pls, null, offset, class, ename, code); /* Get name */

return:	adj_offset = bin(offset, 18);
	return;

error:	code = error_table_$name_not_found;
     end;
   



		    find_operator_name_.pl1         11/05/86  1218.8r w 11/04/86  1033.8       64890


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


/* format: style3,^indnoniterdo */
find_operator_name_:
     proc (tname, callp, op_name);

/* This procedure is given a pointer to an instruction transferring to pl1_operators_ (or cobol_operators_, etc.)
   and returns the name of the operator being referenced.

	coded by M. Weaver 11 July 1973
*/
/* Modified by M. Weaver 1/12/74 for 10-bit opcodes */
/* Modified by S.E. Barr 7/76 to remove version I operator decoding */
/* Modified: 5-4-77 by SHW for more general operator name segments */
/* Modified 7/81 by M. Weaver for algol68 and to call hcs_$make_ptr */
/* Modified 5/82 by M. Weaver to fix bug in above change */
/* Modified 9/82 by JM Athane for pascal compiler and bug fix */
/* Changed to use interpret_link_info.incl.pl1 05/12/83 S. Herbst */

declare	tname		char (*);			/* name of translator or operator segment */
declare	(callp, nptr, linkp, entryp)
			ptr;

declare	(op_index, offset, nsize, i)
			fixed bin;
declare	code		fixed bin (35);

declare	op_name		char (32) aligned;
declare	onp		ptr;
declare	name		char (nsize) based (nptr) aligned;

declare	word		bit (36) aligned based,
	masked_word	bit (36) aligned;

dcl	(
	mask		init ("700000777777"b3),
	tsx0_ap		init ("000000700100"b3),	/* tsx0 pr0|0 */
	tsp2_bp		init ("200000272100"b3),	/* tsp2 pr2|0 */
	tra_ap		init ("000000710100"b3),	/* tra pr0|0 */
	tsp3_ap		init ("000000273100"b3),	/* tsp3 pr0|0 */
	tsp3_lp		init ("400000273100"b3)	/* tsp3 pr4|0 */
	)		bit (36) aligned static;

declare	(
	tsx0		init ("1110000000"b),
	tsp2		init ("0101110100"b),
	tra		init ("1110010000"b),
	tsp3		init ("0101110110"b),
	tsp4		init ("1101110000"b)
	)		bit (10) aligned;


dcl	other_language_names
			(4) char (8) varying static options (constant) init ("cobol", "basic", "pascal", "algol68");
dcl	other_language_xfer_instruction
			(4) bit (36) aligned static options (constant) init ("000000700100"b3,
						/* tsx0 pr0|0 */
			"000000707100"b3,		/* tsx7 pr0|0 */
			"000000273100"b3,		/* tsp3 pr0|0 */
			"000000702100"b3) /* tsx2 */;
dcl	other_language_masks
			(4) bit (36) aligned static options (constant)
			init ("700000777777"b3, "700000777777"b3, "700000777777"b3, "000000777777"b3);

dcl	pl1_operator_names_$pl1_operator_names_
			ext;

%include operator_names;

%include interpret_link_info;
declare	interpret_link_	entry (ptr, ptr, fixed bin (35));
declare	get_operator_names_ptr_
			entry (char (*), ptr);
declare	get_link_ptr_	entry (ptr, ptr, ptr);
declare	hcs_$make_ptr	entry (ptr, char (*), char (*), ptr, fixed bin (35));

declare	(addr, bin, hbound, lbound, null, ptr, rel, substr)
			builtin;

declare	1 inst		aligned based,		/* template for instruction word */
	  2 base		bit (3) unal,
	  2 address	bit (15) unal,
	  2 opcode	bit (10) unal,
	  2 junk1		bit (1) unal,
	  2 base_flag	bit (1) unal,
	  2 junk2		bit (6) unal;

declare	1 name_pair	aligned based,		/* template for word in operator name table */
	  2 rel_ptr	bit (18) unal,
	  2 size		fixed bin (17) unal;

dcl	1 auto_interpret_link_info
			aligned like interpret_link_info;


/**/
%include stack_header;

/**/

	op_name = "";				/* initialize output arg */
	call get_operator_names_ptr_ (tname, onp);	/* map translator name into appropriate pointer */
	masked_word = callp -> word & mask;

	offset = bin (callp -> inst.address, 15);	/* get offset in op transfer vector */
	if offset > 16384
	then offset = offset - 32768;

	if onp = addr (pl1_operator_names_$pl1_operator_names_)
	then do;

	     if masked_word = tsp3_lp
	     then do;				/* xfer to math routines via link */
		call get_link_ptr_ (callp, linkp, entryp);
						/* get ptr to link */
		if linkp = null
		then return;			/* can't find name */

		auto_interpret_link_info.version = INTERPRET_LINK_INFO_VERSION_1;

		call interpret_link_ (addr (auto_interpret_link_info), linkp, code);
		if code = 0
		then op_name = substr (auto_interpret_link_info.entry_point_name, 2);
		return;
	     end;

	     if masked_word ^= tsx0_ap
	     then if masked_word ^= tsp3_ap
		then if masked_word ^= tsp2_bp
		     then if masked_word ^= tra_ap
			then go to try_alm_ops;	/* not tsx0 pr0|k or tsp2 pr2|k or tsp3 pr0|k */

	     call standard_operator_names;

	end;

	else if onp = null
	then do;					/* try alm */
try_alm_ops:
	     sb = ptr (addr (nptr), 0);		/* get ptr to stack header */
	     if ^((callp -> inst.base_flag) & (callp -> inst.base = "111"b))
	     then return;				/* doesn't reference stack header */
	     if callp -> inst.opcode = tsp4
	     then do;
		if "000"b || callp -> inst.address = rel (addr (sb -> stack_header.call_op_ptr))
		then op_name = "alm_call";
	     end;
	     else if callp -> inst.opcode = tsp2
	     then do;
		if "000"b || callp -> inst.address = rel (addr (sb -> stack_header.push_op_ptr))
		then op_name = "alm_push";
		else if "000"b || callp -> inst.address = rel (addr (sb -> stack_header.entry_op_ptr))
		then op_name = "alm_entry";
	     end;
	     else if callp -> inst.opcode = tra
	     then do;
		if "000"b || callp -> inst.address = rel (addr (sb -> stack_header.return_op_ptr))
		then op_name = "alm_return";
		else if "000"b || callp -> inst.address = rel (addr (sb -> stack_header.return_no_pop_op_ptr))
		then op_name = "alm_return_no_pop";
	     end;
	     else return;
	end;

	else do i = lbound (other_language_names, 1) to hbound (other_language_names, 1);

		if onp = operator_names_ptr (other_language_names (i))
		then do;
		     if (callp -> word & other_language_masks (i)) = other_language_xfer_instruction (i)
		     then call standard_operator_names;
		     return;
		end;
	     end;

	return;					/* unknown operator seg */

operator_names_ptr:
     proc (language_name) returns (ptr);

declare	language_name	char (8) varying;
declare	op_names_segname	char (24);
declare	op_names_ptr	ptr;

	op_names_segname = language_name || "_operator_names_";
	call hcs_$make_ptr (onp, op_names_segname, op_names_segname, op_names_ptr, code);

	return (op_names_ptr);

     end;


standard_operator_names:
     proc;

	op_names_pt = onp;
	if offset >= operator_names.first & offset <= operator_names.last
	then do;
	     nptr = addr (operator_names.names (offset));
	     goto common;
	end;

	else if offset >= operator_names.first_special & offset <= operator_names.last_special
	then do;
	     do op_index = 1 to operator_names.number_special;
		if operator_names.special (op_index).offset = offset
		then do;
		     nptr = addr (operator_names.special (op_index).namep);
		     goto common;
		end;
	     end;
	end;

	return;

common:
	nsize = nptr -> name_pair.size;		/* get size of name */
	nptr = ptr (nptr, nptr -> name_pair.rel_ptr);

	op_name = name;				/* copy name into arg */

	return;
     end;

     end find_operator_name_;
  



		    find_owner_.pl1                 11/05/86  1218.8r w 11/04/86  1033.8       36054


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

find_owner_: proc (in_ptr, a_owner, a_section_offset, a_section,
	     a_class, a_ls_ptr);

/* This procedure determines whether a pointer points to a linkage or static
   section and returns the useful information it finds along the way. */

/* coded July 1975 by M. Weaver */

/* arguments:
   1) in_ptr	input pointer

   2) a_owner	segno of owner of linkage or static section (output)

   3) a_section_offset offset of beginning of linkage or static section (output)

   4) a_section	name of logical section (output)

   5) a_class	class of physical section (output)

   6) a_ls_ptr	ptr to beginning of owner's linkage section (output)
*/


dcl (in_ptr, a_ls_ptr, ls_ptr, is_ptr, lotp, isotp) ptr;

dcl (i, class, a_class, highct, hcsct) fixed bin;
dcl (owner, a_owner, section_offset, a_section_offset, tempseg) fixed bin (18);

dcl (a_section, section) char(8) aligned;

dcl (addr, baseptr, bin, null, ptr, rel) builtin;

dcl  hcs_$high_low_seg_count entry (fixed bin, fixed bin);

dcl 1 lot (0:1000) aligned based(lotp),			/* template for lot */
    2 seg bit (18) unaligned,				/* segment number of linkage section */
    2 offset bit (18) unaligned;			/* offset of beginning of linkage section */

dcl 1 isot(0:1000) aligned based(isotp) like lot;

	
%include stack_header;
	
%include its;

	
%include linkdcl;
	
	class = 0;				/* initialize "output" variables */
	section_offset = 0;
	section = "text";				/* until proven otherwise */
	ls_ptr = null;

	i = 100000;				/* test at end for large i */
	if addr (in_ptr) -> its.its_mod ^= "100011"b then go to finish; /* see if we have a ptr */
	if in_ptr = null then goto finish;

	sb = ptr (addr (owner), 0);			/* get ptr to base of stack */
	lotp = stack_header.lot_ptr;			/* so we can get ptr to base of LOT */
	isotp = stack_header.isot_ptr;
	tempseg = bin (baseno (in_ptr), 18);

	call hcs_$high_low_seg_count (highct, hcsct);

	do i = hcsct to hcsct + highct;
	     if bin (lot (i).seg, 18) ^= tempseg then goto check_isot; /* no LOT entry for this seg */
	     if rel (in_ptr) < lot (i).offset then goto check_isot; /* not possibly in linkage section */
	     ls_ptr = ptr (baseptr (lot (i).seg), lot (i).offset); /* get ptr to ls */
	     section_offset = bin (lot (i).offset, 18);
	     if bin (rel (in_ptr), 18) < bin (ls_ptr -> header.stats.block_length, 18) + section_offset
	     then do;				/* in_ptr pts to this linkage section */
		class = 1;
		if section_offset < bin(ls_ptr -> header.stats.begin_links, 18)
		then section = "static";
		else section = "linkage";		/* ptr points to links */
		go to finish;
	     end;

/* see if in_ptr points to separate static */

check_isot:    if bin (isot (i).seg, 18) ^= tempseg then go to next_segno;
						/* not even same seg */
	     is_ptr = ptr (baseptr (isot (i).seg), isot (i).offset);
	     if is_ptr = ls_ptr then goto next_segno;	/* no separate static */
	     if rel (in_ptr) < isot (i).offset then goto next_segno; /* not in this static */
	     section_offset = bin (isot (i).offset, 18);
	     if bin (rel (in_ptr), 18) >= section_offset + bin(ls_ptr -> header.stats.static_length, 18)
	     then goto next_segno;
	     class = 4;
	     section = "static";
	     go to finish;

next_segno:
	end;

finish:
	a_section = section;
	a_class = class;
	if section = "text" then do;			/* no matching ls or ss found */
	     a_section_offset = 0;
	     a_owner = -1;
	     a_ls_ptr = null;
	end;
	else do;
	     a_section_offset = section_offset;
	     a_owner = i;
	     a_ls_ptr = ls_ptr;
	end;

	return;
     end;
  



		    generic_math_.pl1               02/06/85  1040.2rew 02/05/85  1108.7      104643


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
generic_math_:	proc;
/*	This is a set of utilities that allow the basic functions:
	 add, subtract, multiply, divide and negation to be performed
	 on the generic number types.	*/

/*	Written by Rick Gray 02/02/84 to help provide Fortran Hex support	*/
/*	Modified by R. Gray 01/01/84 to work on unnormalized decimal data */

/*	Note for possible future expansion:
	log(x)   ==  log(manitissa) + log(exponent base) * exponent
	exp(x)   --  exponent = floor(x / log(exponent base))
	         --  mantissa = exp(x - exponent * log(exponent base)) */
 
dcl	zerodivide condition;

dcl	dbl_max_decimal_precision fixed bin int static options(constant) init(118);
dcl	max_binary_precision fixed bin int static options(constant) init(63);
dcl	01 gen_decimal_struc based aligned,
	  02 exponent fixed bin(35),
	  02 mantissa fixed decimal(59);

dcl	01 cplx_gen_decimal_struc based aligned,
	  02 (real, imaginary) aligned like gen_decimal_struc;

dcl	01 float_decimal_struc based aligned,
	  02 mantissa fixed decimal(59),
	  02 pad bit(1) unaligned,
	  02 exponent fixed bin(7) unaligned;

dcl	fldt float decimal(59) based aligned;

dcl	01 gen_binary_struc based aligned,
	  02 pad bit(8) unaligned,
	  02 mantissa fixed bin(63) unaligned,
	  02 exponent fixed bin(35) aligned;

dcl	01 cplx_gen_binary_struc based aligned,
	  02 real like gen_binary_struc aligned,
	  02 pad fixed bin(35),
	  02 imaginary like gen_binary_struc aligned;

dcl	01 float_binary_struc based aligned,
	  02 exponent fixed bin(7) unaligned,
	  02 mantissa fixed bin(63) unaligned;

dcl	flbt float binary(63) based aligned;

dcl	01 (xd, yd, zd) parameter like gen_decimal_struc aligned;
dcl	01 (xdc, ydc, zdc) parameter like cplx_gen_decimal_struc aligned;
dcl	01 (ad, bd, cd) like float_decimal_struc aligned;

dcl	01 (xb, yb, zb) parameter like gen_binary_struc aligned;
dcl	01 (xbc, ybc, zbc) parameter like cplx_gen_binary_struc aligned;
dcl	01 (ab, bb, cb) like float_binary_struc aligned;

/* ******************** generic decimal routines ******************** */

negate_decimal:	entry(yd, xd);
	xd.exponent = yd.exponent;
	xd.mantissa = - yd.mantissa;
	return;

negate_decimal_complex:	entry(ydc, xdc);
	xdc.real.exponent = ydc.real.exponent;
	xdc.real.mantissa = - ydc.real.mantissa;
	xdc.imaginary.exponent = ydc.imaginary.exponent;
	xdc.imaginary.mantissa = - ydc.imaginary.mantissa;
	return;

add_decimal:	entry(yd, zd, xd);
	if yd.mantissa = 0 then xd = zd;
	else if zd.mantissa = 0 then xd = yd;
	else if yd.exponent > zd.exponent then
	     if yd.exponent-zd.exponent > dbl_max_decimal_precision then xd = yd;
	     else do;
		ad.exponent = 0;
		ad.mantissa = yd.mantissa;
		bd.exponent = zd.exponent - yd.exponent;
		bd.mantissa = zd.mantissa;
		addr(cd) -> fldt = addr(ad) -> fldt + addr(bd) -> fldt;
		xd.mantissa = cd.mantissa;
		xd.exponent = yd.exponent + cd.exponent;
	       end;
	else if zd.exponent-yd.exponent > dbl_max_decimal_precision then xd = zd;
	     else do;
		ad.exponent = 0;
		ad.mantissa = zd.mantissa;
		bd.exponent = yd.exponent - zd.exponent;
		bd.mantissa = yd.mantissa;
		addr(cd) -> fldt = addr(ad) -> fldt + addr(bd) -> fldt;
		xd.mantissa = cd.mantissa;
		xd.exponent = zd.exponent + cd.exponent;
	       end;
	return;

add_decimal_complex:	entry(ydc, zdc, xdc);
	call add_decimal(ydc.real, zdc.real, xdc.real);
	call add_decimal(ydc.imaginary, zdc.imaginary, xdc.imaginary);
	return;

subtract_decimal:	entry(yd, zd, xd);
	if zd.mantissa = 0 then xd = yd;
	else if yd.mantissa = 0 then call negate_decimal(zd, xd);
	else if yd.exponent > zd.exponent then
	     if yd.exponent-zd.exponent > dbl_max_decimal_precision then xd = yd;
	     else do;
		ad.exponent = 0;
		ad.mantissa = yd.mantissa;
		bd.exponent = zd.exponent - yd.exponent;
		bd.mantissa = zd.mantissa;
		addr(cd) -> fldt = addr(ad) -> fldt - addr(bd) -> fldt;
		xd.mantissa = cd.mantissa;
		xd.exponent = yd.exponent + cd.exponent;
	       end;
	else if zd.exponent-yd.exponent > dbl_max_decimal_precision then do;
		xd.mantissa = -zd.mantissa;
		xd.exponent = zd.exponent;
	       end;
	     else do;
		ad.exponent = 0;
		ad.mantissa = zd.mantissa;
		bd.exponent = yd.exponent - zd.exponent;
		bd.mantissa = yd.mantissa;
		addr(cd) -> fldt = addr(bd) -> fldt - addr(ad) -> fldt;
		xd.mantissa = cd.mantissa;
		xd.exponent = zd.exponent + cd.exponent;
	       end;
	return;

subtract_decimal_complex:	entry(ydc, zdc, xdc);
	call subtract_decimal(ydc.real, zdc.real, xdc.real);
	call subtract_decimal(ydc.imaginary, zdc.imaginary, xdc.imaginary);
	return;

multiply_decimal:	entry(yd, zd, xd);
	if yd.mantissa = 0 | zd.mantissa = 0 then do;
		xd.mantissa = 0;
		xd.exponent = 127;
		return;
	  end;
	ad.exponent, bd.exponent = 0;
	ad.mantissa = yd.mantissa;
	bd.mantissa = zd.mantissa;
	addr(cd) -> fldt = addr(ad) -> fldt * addr(bd) -> fldt;
	xd.mantissa = cd.mantissa;
	xd.exponent = yd.exponent + zd.exponent + cd.exponent;
	return;

multiply_decimal_complex:	entry(ydc, zdc, xdc);
	begin;
	dcl	01 (product1, product2, temp) like gen_decimal_struc aligned;

		call multiply_decimal(ydc.real, zdc.real, product1);
		call multiply_decimal(ydc.imaginary, zdc.imaginary, product2);
		call subtract_decimal(product1, product2, temp);

		call multiply_decimal(ydc.real, zdc.imaginary, product1);
		call multiply_decimal(ydc.imaginary, zdc.real, product2);
		call add_decimal(product1, product2, xdc.imaginary);
		xdc.real = temp;	/* temp is used to allow operand & result to be same variable */
	end;
	return;

divide_decimal:	entry(yd, zd, xd);
	if zd.mantissa = 0 then signal zerodivide;
	if yd.mantissa = 0 then do;
		xd = yd;
		return;
	  end;
	ad.exponent, bd.exponent = 0;
	ad.mantissa = yd.mantissa;
	bd.mantissa = zd.mantissa;
	addr(cd) -> fldt = addr(ad) -> fldt / addr(bd) -> fldt;
	xd.mantissa = cd.mantissa;
	xd.exponent = yd.exponent + cd.exponent - zd.exponent;
	return;

divide_decimal_complex:	entry(ydc, zdc, xdc);
	begin;
	dcl	01 (product1, product2, divisor, temp) like gen_decimal_struc aligned;

		call multiply_decimal(zdc.real, zdc.real, product1);
		call multiply_decimal(zdc.imaginary, zdc.imaginary, product2);
		call add_decimal(product1, product2, divisor);

		call multiply_decimal(ydc.real, zdc.real, product1);
		call multiply_decimal(ydc.imaginary, zdc.imaginary, product2);
		call add_decimal(product1, product2, xdc.real);
		call divide_decimal(xdc.real, divisor, temp);

		call multiply_decimal(ydc.imaginary, zdc.real, product1);
		call multiply_decimal(ydc.real, zdc.imaginary, product2);
		call subtract_decimal(product1, product2, xdc.imaginary);
		call divide_decimal(xdc.imaginary, divisor, xdc.imaginary);
		xdc.real = temp;	/* temp is used to allow operand & result to be same variable */
	end;					
	return;

/* ******************** generic binary routines ******************** */

negate_binary:	entry(yb, xb);
	ab.exponent = 0;
	ab.mantissa = yb.mantissa;
	addr(ab) -> flbt = - addr(ab) -> flbt;
	xb.exponent = yb.exponent + ab.exponent;
	xb.mantissa = ab.mantissa;
	return;

negate_binary_complex:	entry(ybc, xbc);
	call negate_binary(ybc.real, xbc.real);
	call negate_binary(ybc.imaginary, xbc.imaginary);
	return;

add_binary:	entry(yb, zb, xb);
	if yb.mantissa = 0 then xb = zb;
	else if zb.mantissa = 0 then xb = yb;
	else if yb.exponent > zb.exponent then
	     if yb.exponent-zb.exponent > max_binary_precision then xb = yb;
	     else do;
		ab.exponent = 0;
		ab.mantissa = yb.mantissa;
		bb.exponent = zb.exponent - yb.exponent;
		bb.mantissa = zb.mantissa;
		addr(cb) -> flbt = addr(ab) -> flbt + addr(bb) -> flbt;
		xb.mantissa = cb.mantissa;
		xb.exponent = yb.exponent + cb.exponent;
	       end;
	else if zb.exponent-yb.exponent > max_binary_precision then xb = zb;
	     else do;
		ab.exponent = 0;
		ab.mantissa = zb.mantissa;
		bb.exponent = yb.exponent - zb.exponent;
		bb.mantissa = yb.mantissa;
		addr(cb) -> flbt = addr(ab) -> flbt + addr(bb) -> flbt;
		xb.mantissa = cb.mantissa;
		xb.exponent = zb.exponent + cb.exponent;
	       end;
	return;

add_binary_complex:	entry(ybc, zbc, xbc);
	call add_binary(ybc.real, zbc.real, xbc.real);
	call add_binary(ybc.imaginary, zbc.imaginary, xbc.imaginary);
	return;

subtract_binary:	entry(yb, zb, xb);
	if yb.mantissa = 0 then call negate_binary(zb, xb);
	else if zb.mantissa = 0 then xb = yb;
	else if yb.exponent > zb.exponent then
	     if yb.exponent-zb.exponent > max_binary_precision then xb = yb;
	     else do;
		ab.exponent = 0;
		ab.mantissa = yb.mantissa;
		bb.exponent = zb.exponent - yb.exponent;
		bb.mantissa = zb.mantissa;
		addr(cb) -> flbt = addr(ab) -> flbt - addr(bb) -> flbt;
		xb.mantissa = cb.mantissa;
		xb.exponent = yb.exponent + cb.exponent;
	       end;
	else if zb.exponent-yb.exponent > max_binary_precision then do;
		xb.mantissa = -zb.mantissa;
		xb.exponent = zb.exponent;
	       end;
	     else do;
		ab.exponent = 0;
		ab.mantissa = zb.mantissa;
		bb.exponent = yb.exponent - zb.exponent;
		bb.mantissa = yb.mantissa;
		addr(cb) -> flbt = addr(bb) -> flbt - addr(ab) -> flbt;
		xb.mantissa = cb.mantissa;
		xb.exponent = zb.exponent + cb.exponent;
	       end;
	return;

subtract_binary_complex:	entry(ybc, zbc, xbc);
	call subtract_binary(ybc.real, zbc.real, xbc.real);
	call subtract_binary(ybc.imaginary, zbc.imaginary, xbc.imaginary);
	return;

multiply_binary:	entry(yb, zb, xb);
	if yb.mantissa = 0 | xb.mantissa = 0 then do;
		xb.mantissa = 0;
		xb.exponent = 127;
		return;
	  end;
	ab.exponent, bb.exponent = 0;
	ab.mantissa = yb.mantissa;
	bb.mantissa = zb.mantissa;
	addr(cb) -> flbt = addr(ab) -> flbt * addr(bb) -> flbt;
	xb.mantissa = cb.mantissa;
	xb.exponent = yb.exponent + zb.exponent + cb.exponent;
	return;

multiply_binary_complex:	entry(ybc, zbc, xbc);
	begin;
	dcl	01 (product1, product2) like gen_binary_struc aligned;

		call multiply_binary(ybc.real, zbc.real, product1);
		call multiply_binary(ybc.imaginary, zbc.imaginary, product2);
		call subtract_binary(product1, product2, xbc.real);

		call multiply_binary(ybc.real, zbc.imaginary, product1);
		call multiply_binary(ybc.imaginary, zbc.real, product2);
		call add_binary(product1, product2, xbc.imaginary);
	end;
	return;

divide_binary:	entry(yb, zb, xb);
	if zb.mantissa = 0 then signal zerodivide;
	if yb.mantissa = 0 then do;
		xb = yb;
		return;
	  end;
	ab.exponent, bb.exponent = 0;
	ab.mantissa = yb.mantissa;
	bb.mantissa = zb.mantissa;
	addr(cb) -> flbt = addr(ab) -> flbt / addr(bb) -> flbt;
	xb.mantissa = cb.mantissa;
	xb.exponent = yb.exponent + cb.exponent - zb.exponent;
	return;

divide_binary_complex:	entry(ybc, zbc, xbc);
	begin;
	dcl	01 (product1, product2, divisor) like gen_binary_struc aligned;

		call multiply_binary(zbc.real, zbc.real, product1);
		call multiply_binary(zbc.imaginary, zbc.imaginary, product2);
		call add_binary(product1, product2, divisor);

		call multiply_binary(ybc.real, zbc.real, product1);
		call multiply_binary(ybc.imaginary, zbc.imaginary, product2);
		call add_binary(product1, product2, xbc.real);
		call divide_binary((xbc.real), divisor, xbc.real);

		call multiply_binary(ybc.imaginary, zbc.real, product1);
		call multiply_binary(ybc.real, zbc.imaginary, product2);
		call subtract_binary(product1, product2, xbc.imaginary);
		call divide_binary((xbc.imaginary), divisor, xbc.imaginary);
	end;					
	return;
end generic_math_;
 



		    get_def_name_.pl1               04/07/83  1606.7rew 04/07/83  1051.5        9936


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

get_def_name_:	proc (linkptr, defptr, offset, section, ename, code);

/* This procedure is currently a writearound for hcs_$get_defname_.
   If and when gates become readable within the call bracket, the code in
   hcs_$get_defname_ will be moved to this procedure. */
/* coded by M. Weaver 24 July 1973 */


declare	(linkptr, defptr) ptr;
declare	offset bit(18) aligned;
declare	ename char(*);
declare	section fixed bin;
declare	code fixed bin(35);

declare	hcs_$get_defname_ entry (ptr, ptr, bit(18) aligned, fixed bin, char(*), fixed bin(35));

	call hcs_$get_defname_ (linkptr, defptr, offset, section, ename, code);
	return;
	end;



		    get_entry_name_.pl1             01/24/89  0857.0rew 01/24/89  0847.8       88812


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


/****^  HISTORY COMMENTS:
  1) change(88-11-07,Lee), approve(88-12-05,MCR8030), audit(88-12-23,Flegel),
     install(89-01-24,MR12.3-1012):
     phx20737 (Commands 573) - Fix a bug which prevents the entry name from
     being returned when passed an entry point at location 0 of a non-PL1 or
     non-BASIC object segment.
                                                   END HISTORY COMMENTS */


/* format: style1,^indattr,declareind10 */
get_entry_name_: proc (entry_ptr, ename, segnum, comp, code);

/* If entry_ptr points to an entry sequence or to a segdef, this procedure will
   do its best to return the associated name.
   If entry_ptr points to an entry sequence in the combined linkage section, the segment number
   returned will be that of the owner of the entry.

   coded 7 June 1973 by M. Weaver
   modified 26 June 1975 by J.M. Broughton to handle begin block entry
   modified 31 July 1975 by M. Weaver to call find_nonobject_info_
*/

	declare	entry_ptr ptr;			/* ptr to entry sequence (input) */
	declare	ename char (*);			/* name associated with entry seqence (output) */
	declare	segnum fixed bin (18);		/* segment number of text */
	declare	code fixed bin (35);		/* status code (output) */
	declare	comp char (8) aligned;		/* if ^blank, name of entry's compiler */

	declare	(addr, addrel, baseno, bin, divide, hbound, index, null, ptr, rel, string) builtin;

	declare	(i, j, size, based_fixed based, lang, adjust, section) fixed bin;
	declare	adj_offset fixed bin (18);
	declare	type fixed bin (2);
	declare	mode fixed bin (5);
	declare	bitcnt fixed bin (24);
	declare	first_seq (4) fixed bin init (1, 3, 3, 5);
	declare	last_seq (4) fixed bin init (2, 4, 4, 5);
	declare	seq_lng (5) fixed bin init (3, 6, 3, 3, 3);

	declare	(error_table_$name_not_found, error_table_$moderr, error_table_$dirseg,
		error_table_$invalidsegno, error_table_$begin_block) ext fixed bin (35);

	declare	known_names char (32) aligned init ("pl1     v2pl1   PL/I    basic   ");
	declare	name char (size) based (namep);
	declare	section_name char (8) aligned;

	declare	std_sw bit (1) aligned;
	declare	op_seq (5, 6) bit (10) unaligned int static init (
		     "1100101110"b /* eax7 */, "1100101100"b /* eax6 */, "0101110100"b /* tsp2 */, "0"b, "0"b, "0"b,
		     "1100101110"b /* eax7 */, "1100101100"b /* eax6 */, "0100111010"b /* lda */,
		     "0111010100"b /*epp2 */, "0111110000"b /* epsp4 */, "0101110100"b /* tsp2 */,
		     "1100101110"b /* eax7 */, "0111010100"b /* epp2 */, "0101110100"b /* tsp2 */, "0"b, "0"b, "0"b,
		     "1100101110"b /* eax7 */, "1110000000"b /* tsx0 */, "0101110100"b /* tsp2 */, "0"b, "0"b, "0"b,
		     "1100101110"b /* eax7 */, "0111010100"b /* epp2 */, "0101110100"b /* tsp2 */, "0"b, "0"b, "0"b);

	declare	begin_block_entries (2) bit (36) aligned initial
		     ("000000000110001100010111010001000000"b, /* tsp2 pr0|614 */
		     "000000001011111110010111010001000000"b /* tsp2 pr0|1376 */);

	declare	(segptr, np, namep, def_ptr) ptr;

	declare	hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
	declare	hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35));
	declare	object_info_$display ext entry (ptr, fixed bin (24), ptr, fixed bin (35));
	declare	component_info_$offset ext entry (ptr, fixed bin (18), ptr, fixed bin (35));
	declare	find_nonobject_info_ entry (ptr, char (*), fixed bin (18), char (8) aligned,
		     fixed bin (18), fixed bin (35));
	declare	get_def_name_ ext entry (ptr, ptr, bit (18), fixed bin, char (*), fixed bin (35));
	declare	condition_ entry (char (*), entry);

	declare	1 half aligned based,
		  2 (left, right) bit (18) unaligned;

	declare	1 acc aligned based,		/* overlay for acc string */
		  2 count fixed bin (8) unaligned,
		  2 string char (31) unaligned;	/* string will never be used as string */

	declare	1 inst_seq (6) aligned based,		/* template for 6180 instruction */
		  2 address bit (18) unaligned,
		  2 opcode bit (10) unaligned,
		  2 mod bit (8) unaligned;

/* declaration of non class 3 definition (new format) */
%include definition;

/**/
%include object_info;

	declare	1 oi structure aligned like object_info;
						/**/
%include component_info;
/**/

/* initialize some stuff */

	lang = 0;
	comp = " ";
	std_sw = "0"b;
	ename = " ";
	adjust = 1;				/* assume standard object or v2pl1 */

	call condition_ ("any_other", catch);
	segptr = ptr (entry_ptr, 0);			/* get ptr to base of seg */
	segnum = bin (baseno (entry_ptr), 18);		/* get segment number of input ptr */
	section = -1;				/* in case we can't tell if it's text */
	def_ptr = segptr;				/* till we get something better */
	call hcs_$status_mins (segptr, type, bitcnt, code); /* get type and bitcnt */
	if code ^= 0
	then if code = error_table_$invalidsegno	/* probably hardcore */
	     then go to search_defs;
	     else return;
	if type = 2 then do;
		code = error_table_$dirseg;		/* dirs don't have entry points */
		return;
	     end;
	call hcs_$fs_get_mode (segptr, mode, code);	/* get mode wrt validation level */
	if code ^= 0 then return;			/* don't see how this could happen */
	if mode < 8				/* no read access */
	then if mode < 4				/* no execute access */
	     then do;				/* can't see defs (probably none anyway */
		     code = error_table_$moderr;
		     return;
		end;
	     else go to search_defs;			/* probably a gate; read defs in ro */

	oi.version_number = object_info_version_2;
	call object_info_$display (segptr, bitcnt, addr (oi), code); /* may need def ptr */
	if code ^= 0 then do;			/* not object seg; see if it's a linkage section */
		call find_nonobject_info_ (entry_ptr, ename, segnum, section_name, adj_offset, code);
		return;				/* everything done that can be */
	     end;
	def_ptr = oi.defp;				/* now we have ptr to actual defs */

	i = bin (rel (entry_ptr), 18);		/* get offset of input ptr */
	j = bin (rel (oi.textp), 18);			/* get offset of beginning of text */
	if (i >= j) & (i <= j + oi.tlng) then section = 0;/* is text */
	else go to no_name;				/* not in text; can't be entry */

	if oi.compiler ^= "binder" then do;		/* this compiler generated all entries */
		std_sw = oi.format.standard;
		comp = oi.compiler;
	     end;
	else do;					/* consult the bind map for this component */
		call component_info_$offset (segptr, bin (rel (entry_ptr), 18), addr (ci), code);
		if code ^= 0 then go to no_name;
		std_sw = ci.standard;
		comp = ci.compiler;
	     end;

/* if language is familiar, determine if we have a valid entry sequence */

	lang = divide (index (known_names, comp) + 7, 8, 17, 0); /* see if it's pl1 */
	if lang = 0 then if std_sw then go to get_std_name; /* std obj seg */
	     else go to search_defs;			/* non-std obj; look for match in defs */

/* check for valid entry sequence; v1pl1, v2pl1, and basic are the only langs we know */

	do i = first_seq (lang) to last_seq (lang);	/* each lang may have several sequence types */
	     do j = 1 to seq_lng (i);			/* look only at relevant number */
		if entry_ptr -> inst_seq (j).opcode ^= op_seq (i, j) then go to try_next;
	     end;
	     go to valid_entry;			/* sequence matches */
try_next: end;

/* if lang is PL/I, then we will check if the entry is for a begin block */

	if (lang = 2) | (lang = 3) then do;
		do i = 1 to hbound (begin_block_entries, 1);
		     if string (entry_ptr -> inst_seq (2)) = begin_block_entries (i) then do;
			     code = error_table_$begin_block;
			     ename = "begin block";
			     return;
			end;
		end;
	     end;

no_name:	code = error_table_$name_not_found;
	return;

valid_entry: if lang = 1 then adjust = 3;		/* v1pl1 is different */

get_std_name:
	if i - adjust < 0 then go to search_defs;	/* RL: phx20737 - handle location 0 */
	np = addrel (entry_ptr, -adjust);		/* get ptr to size or rel ptr */
	if std_sw then do;				/* look for name in defs */
		if bin (np -> half.left, 18) > oi.dlng then go to search_defs; /* not in def section */
		namep = addrel (oi.defp, np -> half.left); /* get ptr to entry's def */
		if namep -> definition.value ^= rel (entry_ptr) then goto search_defs;
						/* be sure we have correct def */
		if bin (namep -> definition.symbol, 18) > oi.dlng then go to search_defs;
		namep = addrel (oi.defp, namep -> definition.symbol); /* get ptr to def name */
		size = namep -> acc.count;
		namep = addr (namep -> acc.string);
	     end;
	else do;					/* not standard object, but is pl1  */
		size = np -> based_fixed;		/* get name length in chars */
		if size > 256 then go to no_name;	/* somehow this isn't a name */
		namep = addrel (np, -divide (size + 3, 4, 17, 0)); /* name string is in text */
	     end;

	ename = name;				/* fill in return args */
	return;

search_defs:					/* non-standard object; look for def for this offset */
	call get_def_name_ (null, def_ptr, rel (entry_ptr), section, ename, code);

	return;

catch: proc (mcptr, condname, wcptr, infoptr, continue);

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

	if condname = "quit"
	     | condname = "alrm"
	     | condname = "cput"
	     | condname = "program_interrupt"
	     | condname = "finish"
	     | condname = "storage"
	     | condname = "mme2"
	then continue = "1"b;

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

     end get_entry_name_;



		    get_link_entry_name_.pl1        04/07/83  1606.7rew 04/07/83  1051.5       26874


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

get_link_entry_name_: proc (eptr, ename, segnum, code);


/* This procedure takes the address of an entry point in the linkage section and
   attempts to return its name */


dcl  eptr pointer;					/* Pointer to the entry point. */
dcl  ename char (*);				/* Entry name output */
dcl  segnum fixed bin(18);				/* seg no. of text */
dcl  code fixed bin (35);				/* Standard File System Error Code. Returned. */


/* Automatic Storage */


dcl  pls pointer;					/* Pointer to the linkage section */
dcl  offset bit (18) aligned;				/* Offset of the entry in the linkage section */
dcl  owner fixed bin (18);				/* segno of ls owner */
dcl  ls_offset fixed bin(18);				/* offset of ls within cls */
dcl  (i, section) fixed bin;

/* Externals */


dcl  error_table_$name_not_found ext fixed bin (35);
dcl  get_def_name_ entry (ptr, ptr, bit (18) aligned, fixed bin, char (*), fixed bin (35));
dcl  hcs_$get_lp entry (ptr, ptr);
dcl  find_ls_owner_ entry (ptr, fixed bin(18), fixed bin(18));
dcl (addrel, bit, fixed, null, rel, bin, baseno, ptr, baseptr) builtin;


/* this procedure should be called only for non-object segments */

program_begins_here:

	if eptr = null then goto error;

	/* be sure this is a linkage section before we go looking for an entry sequence */
	call find_ls_owner_ (eptr, owner, ls_offset);
	if owner = -1 then do;			/* eptr doesn't point to a linkage section,
						   but maybe it points to a seg that has one,
						   as for example a seg created by datmk_ or type 6 link */
	     owner = bin (baseno (eptr), 18);		/* we have ptr to seg itself */
	     segnum = owner;			/* assume we already have ptr to text */
	     offset = rel (eptr);			/* so use offset directly from ptr */
	     call hcs_$get_lp (ptr (eptr, 0), pls);
	     if pls = null then do;			/* may have a ring 0 seg (they're
						   not all complete object segs); but
						   must go into r0 to get pls */
		call get_def_name_(null, ptr(eptr, 0), offset, -1, ename, code);
		return;
	     end;
	     section = 0;				/* probably have ptr to text */
	     go to get_name;			/* and forget about entry sequence */
	end;
	segnum = owner;				/* return ptr to real text */
	pls = ptr (eptr, ls_offset);			/* get ptr to linkage header */
	section = 1;				/* have ptr to linkage section */
	offset = bit (fixed (fixed (rel (eptr), 18)-ls_offset, 18), 18); /* Offset to entry */

get_name: call get_def_name_ (pls, null, offset, section, ename, code); /* Get name */

	return;

error:	code = error_table_$name_not_found;
     end;
  



		    get_link_ptr_.pl1               11/20/86  1405.1r w 11/20/86  1145.0       55134


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

/* format: style4,delnl,insnl,ifthenstmt,ifthen,indnoniterend,indend,^indproc */

get_link_ptr_:
     proc (loc_ptr, link_ptr, entry_ptr);

/* This procedure  is given a pointer to a text location and tries to find an external reference
   just before the location.   If a link reference is found, a pointer to the original link and the snapped
   link itself are returned.  If a text-to-text transfer appears to be found, a pointer to the target
   is returned.  In the latter case, the caller is responsible for determining that
   the returned pointer in fact points to an entry sequence (this can be done by
   calling get_entry_name_).  */
/* coded by M. Weaver 7/5/73 */
/* last modified by M. Weaver 10/17/73 */
/* last modified by M. Weaver 1/10/74 to change opcodes to 10 bits */
/* last modified by J.M. Broughton on 2 July 1975 to prevent fault when
   rel (loc_ptr) is small, i.e. -~ 0  */
/* Modified 2/82 BIM to make sure temp_ptr is initialized when used. */


declare  (loc_ptr, link_ptr, temp_ptr, segptr, entry_ptr, ls_ptr) ptr;
declare  based_ptr ptr based;

declare  i fixed bin;
declare  type fixed bin (2);
declare  link_offset fixed bin (18);
declare  bitcnt fixed bin (24);
declare  code fixed bin (35);

declare  lang char (8) aligned;

declare  (
         epp2 init ("0111010100"b),
         tra init ("1110010000"b),
         tsp3 init ("0101110110"b)
         ) bit (10) aligned int static options (constant);

declare  object_info_$display entry (ptr, fixed bin (24), ptr, fixed bin (35));
declare  hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
declare  component_info_$offset entry (ptr, fixed bin (18), ptr, fixed bin (35));

declare  (addr, addrel, baseno, bin, null, rel, ptr) builtin;

%page;
%include object_info;
declare  1 oi aligned like object_info;
%page;
%include component_info;
%page;
%include stack_header;
%page;
%include lot;
%page;
%include instruction;
%page;
%include object_link_dcls;


	link_ptr, entry_ptr, temp_ptr = null;		/* initialize output args */

	segptr = ptr (loc_ptr, 0);			/* get ptr to beg of seg */

/* get ptrs to sections of object seg and determine language */

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

	oi.version_number = object_info_version_2;
	call object_info_$display (segptr, bitcnt, addr (oi), code);
	if code ^= 0 then return;

	if oi.compiler = "binder" then do;		/* find language of component */
	     call component_info_$offset (loc_ptr, bin (rel (loc_ptr), 18), addr (ci), code);
	     if code = 0 then
		lang = ci.compiler;
	     else lang = "binder";
	     end;
	else lang = oi.compiler;

/* now look for external reference; if proc is pl1 type, we know what code should look like */

	instruction_ptr = loc_ptr;

	if (lang = "pl1") | (lang = "v2pl1") | (lang = "fortran") | (lang = "PL/I") then do;
						/* look for epp2  pr4|k,* */

	     if instruction_common.opcode = epp2	/* at link ref; probably linkage error */
		| instruction_common.opcode = tsp3	/* transfer to math operator is by link */
	     then temp_ptr = loc_ptr;

	     else do;				/* should be at transfer to pl1 call operator */

		if lang = "pl1" then do;		/* version 1 */
		     if rel (temp_ptr) < bit (bin (2, 18)) then return;
		     temp_ptr = addrel (loc_ptr, -2);
		     end;
		else do;				/* version 2 */
		     if rel (temp_ptr) = (18)"0"b then return;
		     temp_ptr = addrel (loc_ptr, -1);
		     end;

		if temp_ptr = null then return;
		if temp_ptr -> instruction_common.opcode ^= epp2 then return;

		end;

	     if temp_ptr = null then return;
	     if temp_ptr -> instruction_common.pr	/* has a PR */
	     then if temp_ptr -> instruction_pr.address.pr = 4
						/* PR4 */
		     & temp_ptr -> instruction_pr.tag = "010100"b /* ,* */ then
		     go to get_link;
		else return;
	     else if temp_ptr -> instruction_common.tag = ""b then go to get_ttr;
						/* assume text-text transfer */
	     else return;

	     end;

	else do;					/* not pl1 */

	     temp_ptr = loc_ptr;
	     do i = 1 to 3;				/* look back in text */

		if temp_ptr -> instruction_common.pr	/* PR */
		     & temp_ptr -> instruction_pr.address.pr = 4 & temp_ptr -> instruction_pr.tag = "010100"b then
		     go to get_link;		/* something  pr4|k,* */

		if rel (temp_ptr) = (18)"0"b then go to check_for_tra;
		temp_ptr = addrel (temp_ptr, -1);	/* move ptr back */

		end;

check_for_tra:
	     temp_ptr = loc_ptr;			/* reset */

	     if temp_ptr -> instruction_common.opcode = tra & temp_ptr -> instruction_common.tag = "0"b then
		go to get_ttr;			/* have tra  n */

	     return;				/* couldn't find anything */

	     end;

get_link:						/* instruction address should be the offset of the link in the linkage section */
						/* use original object linkage section for link_ptr and active
						   linkage section fo entry_ptr */
	link_offset = temp_ptr -> instruction_pr.address.offset;

	link_ptr = addrel (oi.linkp, link_offset);

	if link_ptr -> object_link.tag ^= "100110"b then
	     link_ptr = null;			/* not ft2 */

	else do;					/* find link being used; will probably be snapped */

	     sb = ptr (addr (temp_ptr), 0);		/* get ptr to stack header */

	     ls_ptr = lot_ptr -> lot.lp (bin (baseno (segptr), 18));

	     entry_ptr = addrel (ls_ptr, link_offset) -> based_ptr;
						/* pick up link itself */

	     if addr (entry_ptr) -> object_link.tag = "100110"b then entry_ptr = null;
						/* not snapped yet */
	     end;

	return;


get_ttr:						/* instruction address should be offset in text of entry sequence */
	entry_ptr = ptr (loc_ptr, temp_ptr -> instruction_off.offset);

	return;

     end get_link_ptr_;
  



		    get_operator_names_ptr_.pl1     11/02/83  1335.3rew 11/02/83  1230.0       18000


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


get_operator_names_ptr_: proc (name, onp);

/* modified 7/81 by Melanie Weaver for algol68 */
/* modified 5/82 by Melanie Weaver to really work for basic, algol68, etc. */

/* Parameters */

dcl  name char (*);					/* name of translator or operator segment */
dcl  onp ptr;					/* returned pointer to appropriate operator names segment */

/* Builtins */

dcl  (addr, null) builtin;

/* External */

dcl  pl1_operator_names_$pl1_operator_names_ ext;
dcl  basic_operator_names_$basic_operator_names_ ext;
dcl  cobol_operator_names_$cobol_operator_names_ ext;
dcl  algol68_operator_names_$algol68_operator_names_ ext;
dcl  pascal_operator_names_$pascal_operator_names_ ext;

/*  */

	if name = "PL/I"
	| name = "v2pl1"
	| name = "pl1"
	| name = "fortran"
	| name = "fortran2"
	| name = "pl1_operators_"
	then onp = addr (pl1_operator_names_$pl1_operator_names_);

	else if name = "cobol"
	| name = "COBOL"
	| name = "cobol_operators_"
	then onp = addr (cobol_operator_names_$cobol_operator_names_);

	else if name = "basic"
	| name = "BASIC"
	| name = "basic_operators_"
	then onp = addr (basic_operator_names_$basic_operator_names_);

	else if name  = "algol68"
	| name = "Algol68"
	| name = "ALGOL68"
	| name = "algol68_operators_"
	then onp = addr (algol68_operator_names_$algol68_operator_names_);

	else if name = "pascal"
	| name = "Pascal"
	| name = "PASCAL"
	| name = "pascal_operators_"
	then onp = addr (pascal_operator_names_$pascal_operator_names_);

	else onp = null;

     end;



		    interpret_bind_map_.pl1         04/07/83  1606.7rew 04/07/83  1051.5       50256


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


interpret_bind_map_:  procedure(loc_ptr, segname, new_offset, xcode);

/* initially coded as interpret_bind_map by M. Spier 21 May 1971 */
/* converted to a subroutine by M. Weaver 17 June 1971 */
/* last modified by M. Weaver 27 July 1971 */


	/* DECLARATION OF EXTERNAL ENTRIES */

declare	get_bound_seg_info_ entry(ptr, fixed bin(24), ptr, ptr, ptr, fixed bin);
declare	hcs_$status_mins ext entry(ptr, fixed bin(2), fixed bin(24), fixed bin);
declare   (error_table_$bad_segment, error_table_$name_not_found, error_table_$oldobj) ext fixed bin;
declare	error_table_$not_bound ext fixed bin;

declare	(addr, addrel, divide, fixed, null, ptr, rel, substr) builtin;

	/* DECLARATION OF AUTOMATIC STORAGE VARIABLES */

dcl	xcode fixed bin;				/* Parameter */
declare	(i,j,k,l,value,nargs,nopts,lng,arg_lng,link_offset,m,compsw) fixed bin;
declare	new_offset fixed bin(18);
declare   bitcount fixed bin(24);
declare   type fixed bin(2);
declare	store_value(2) fixed bin;		/* so offsets will be more referenceable in a do loop */
declare	(defbase, t_lng, l_lng, s_lng, d_lng) fixed bin;
declare	noff(2) fixed bin init(0,0);			/* indicates whish components offsets are in */
declare	(loc_ptr, p, argp, objp, symb_addr, bmp, sblkp) pointer;
declare	string char(50000) based;		/* for looking at symbol table header */
declare	segname char(32) aligned;

dcl codep ptr,
    (code based(codep), auto_code) fixed bin;

declare	1 symb_def aligned,
	2 next_def pointer,
	2 last_def pointer,
	2 block_ptr pointer,
	2 section char(4) aligned,
	2 offset fixed bin,
	2 entrypoint fixed bin,
	2 defname char(32) aligned;

	/* DECLARATION OF BASED STRUCTURES */

declare 1 linkheader based aligned,
	2 defseg fixed bin,
	2 defoffset bit(18) unaligned,
	2 dum1 bit(18) unaligned,
	2 block_thread pointer,
	2 dum2 pointer,
	2 link_begin bit(18) unaligned,
	2 sect_lng bit(18) unaligned;

declare	var_string char(lng) based(p);

declare 1 symbol_header based aligned,		/* structure of symbol table header */
	2 com_boff fixed bin aligned,		/* offset of compiler name from symbp, in bits */
	2 (dum1,com_lng) bit(18) unal,		/* length of compiler name, in bits */
	2 vers_boff fixed bin aligned,		/* offset of version name, in bits */
	2 (dum2, vers_lng) bit(18) unal;		/* length of version name */
					/* there's more but we don't want it here */
/*  */

% include object_info;

declare	1 oi structure aligned like object_info;
% include symbol_block;

/*  */


/*  */

% include bind_map;

/*  */

	/* new_offset is not initialized to 0 because default_error_handler_ programs expect
	   its value to be changed only if there is something valid to change it to */
	compsw = 1;				/* only looking for 1 offset */
	objp = ptr(loc_ptr,0);			/* get ptr to base of object segment */
	store_value(1) = fixed(rel(loc_ptr),18);		/* get desired offset */

	codep = addr(xcode);				/* Set for proper reference */

decode:	call hcs_$status_mins(objp, type, bitcount, code);	/* get bit count for decode definition */
	if code ^= 0 then return;			/* can't do anything more */

	oi.version_number = object_info_version_2;
	call get_bound_seg_info_(objp, bitcount, addr(oi), bmp, sblkp, code);
	if code ^= 0 then do;		/* 2 offsets are in same proc if seg not bound */
	  	if code = error_table_$not_bound then if compsw = 2 then samesw = "1"b;
		return;
	end;

display:
	do m = 1 to compsw;			/* do twice if comparing */
	     value = store_value(m);		/* use scalar for more speed */
	     do j = 1 to n_components;			/* look at values for each object component */
		k = fixed(component(j).text_start, 18);
		l = fixed(component(j).text_lng, 18);
		if value >= k then if value < k+l then do;
		     if compsw = 2 then do;		/* just comparing */
			noff(m) = j;		/* save component no. so can compare */
			go to end_display;		/* don't look at any more now */
		     end;
		     else do;			/* want name */
			p = addrel(sblkp, component(j).name_ptr);
			lng = fixed(component(j).name_lng, 18);
			segname = var_string;			/* copy name into argument */
			new_offset = value - k;			/* calculate offset also */
			return;					/* done */
		     end;
		end;
	     end;

	     code = error_table_$name_not_found;		/* can't find component for ptr */
	     return;

end_display: end;

	if noff(1) = noff(2) then samesw = "1"b;	/* offsets are in same procedure */
	return;
						/* error_table_$different_procs */


compare_offsets_:   entry(object_ptr, off1, off2, samesw);

	/* procedure to see if 2 offsets into the same bound segment belong to the same procedure */

declare	object_ptr ptr;			/* ptr to beginning of bound segment */
declare	(off1, off2) fixed bin(18);		/* offsets to be compared */
declare	samesw bit(1) aligned;		/* indicates whether offsets are in same proc */

	compsw = 2;				/* looking for 2 offsets */
	samesw = "0"b;				/* set it to false until we are sure */
	objp = object_ptr;			/* copy arg */
	store_value(1) = off1;		/* save offsets so we can reference them in a do loop */
	store_value(2) = off2;

	codep = addr(auto_code);			/* no code parameter here */

	go to decode;			/* go do rest */

	end interpret_bind_map_;



		    interpret_op_ptr_.pl1           11/05/86  1218.8r w 11/04/86  1042.1      139014


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

/* format: style3,^indnoniterdo */
interpret_op_ptr_:
     proc (mcptr, a_sp, callp, op_name, frame_flag);

/* This procedure  checks to see if p points to pl1_operators_ or pl1_operators.
   If it does, the procedure tries to obtain the location of the transfer to the
   operator segment.  An effort is made to determine whether the given stack
   frame was in use at the time of the transfer.
   Coded by M. Weaver 26 June 1973 */
/* modified by M. Weaver 6 October 1973  to make use of new operator segdefs */
/* modified by M. Weaver 1/17/74  to handle operator call outs */
/* modified by J.M. Broughton on 26 June 1975 to handle trace operators and calls through entry vars */
/* modified by JMB on 8 July 1975 to handle basic operators */
/* Modified by R.J.C. Kissel in June 1977 to handle COBOL operators. */
/* Modified by S. Webber Oct 1977 to fix bugs in handling of cobol operators */
/* Modified by P. Krupp November 1977 to handle the ALM entry operator used by trace */
/* Modified by M. Weaver July 1981 to handle algol68_operators_ and remove code for pl1_operators (version 1) */
/* Modified by M. Weaver January 1982 to not activate linkage sections of non-pl1 operators */
/* Modified by M. Weaver October 1983 to handle pascal_operators_ and check for null condition pointer */
/* Changed to view stack_frame.return_ptr through RETURN_PTR_MASK 03/07/84 S. Herbst */


declare	(p, a_sp, mcptr, callp, rsp, return_ptr_copy)
			ptr;
declare	(p1, p2, p3, p4, p5)
			ptr;
declare	cobol_operators_ptr ptr;
declare	algol68_operators_ptr
			ptr;
declare	basic_operators_ptr ptr;
declare 	pascal_operators_ptr ptr;

declare	op_name		char (32) aligned;


declare	frame_flag	bit (1) aligned;
declare	opsegno		bit (18) aligned;
declare	sx		(0:7) bit (18) unaligned based;
declare	have_made_basic_search
			bit (1) aligned;
declare	real_condition_segno
			bit (18) aligned;

declare	(addr, addrel, baseno, baseptr, bin, null, ptr, rel, unspec)
			builtin;

declare	1 tra_inst	aligned based,
	  2 addr		bit (18) unaligned,
	  2 opcode	bit (10) unaligned,
	  2 junk		bit (8) unaligned;

declare	hcs_$make_ptr	entry (ptr, char (*), char (*), ptr, fixed bin (35));

declare	offset		fixed bin (18);
declare	code		fixed bin (35);
declare	(
	pl1_operators_$entry_operators,
	pl1_operators_$entry_operators_end,
	pl1_operators_$trace_entry_operators,
	pl1_operators_$trace_entry_operators_end,
	pl1_operators_$math_routines_,
	pl1_operators_$math_routines_end_,
	pl1_operators_$alm_operators_begin,
	pl1_operators_$alm_operators_end,
	pl1_operators_$alm_call,
	pl1_operators_$alm_push,
	pl1_operators_$alm_return,
	pl1_operators_$forward_call,
	pl1_operators_$var_call,
	pl1_operators_$alm_trace_operators_begin,
	pl1_operators_$alm_trace_operators_end
	)		fixed bin (35) external;

declare	(
	basic_operators_$end_basic_operators,
	basic_operators_$enter_proc,
	basic_operators_$end_entry_ops,
	basic_operators_$call_op_begin,
	basic_operators_$new_frame,
	basic_operators_$call_op_end,
	cobol_operators_$cobol_operators_,
	cobol_operators_$cobol_operators_end,
	algol68_operators_$algol68_operators_,
	algol68_operators_$end_operators,
	algol68_operators_$entry_operators_begin,
	algol68_operators_$entry_operators_end,
	pascal_operators_$pascal_operators_,
	pascal_operators_$pascal_operators_end
	)		fixed bin (35) external;

dcl	1 cobol_stack_frame aligned based (sp),
	  2 pad1		(1:64) bit (36),
	  2 return_to_main_ptr
			ptr;			/* actual cobol return pointer */

%include stack_frame;

/*  */
%include mc;

%include basic_operator_frame;

declare	bo_pt		pointer;


/*  */
	sp = a_sp;				/* initialize */
	callp = null;
	op_name = " ";
	frame_flag = "1"b;
	have_made_basic_search = "0"b;

/* be sure that given environment is usable */

	if mcptr ^= null
	then do;					/* had a fault */
	     scup = addr (mcptr -> mc.scu (0));
	     p = ptr (baseptr (bin (bin (scup -> scu.ppr.psr, 15), 18)), scup -> scu.ilc);
	end;
	else if sp ^= null
	then unspec (p) = unspec (sp -> stack_frame.return_ptr) & RETURN_PTR_MASK;
	else return;				/* have no environment to use */

	real_condition_segno = baseno (p);
	if real_condition_segno = baseno (null)		/* this is safer than p = null */
	then return;				/* believe it or not, this does sometimes happen */

/* see if we have pl1_operators_ */

	if real_condition_segno = baseno (addr (pl1_operators_$entry_operators))
	then do;

/* Assume all ops are bound together either
   with no other segs or at beginning
   of bound segment */

	     opsegno = baseno (addr (pl1_operators_$entry_operators));
	     p1 = addr (pl1_operators_$math_routines_end_);
						/* see if we can tell  where end of ops is */
	     if bin (rel (p), 18) > bin (rel (p1), 18)
	     then return;

	     op_name = "pl1_operators_";

	     if mcptr = null
	     then do;				/* assume p is ret_ptr */
		if sp -> stack_frame.entry_ptr ^= null	/* should be OK, but just in case.. */
		then if baseno (sp -> stack_frame.entry_ptr) ^= opsegno
		     then do;			/* see if frame belongs to an op */
			if sp -> stack_frame.operator_return_offset ^= "0"b
			then callp = ptr (sp -> stack_frame.entry_ptr, sp -> stack_frame.operator_return_offset);
			else callp = ptr (sp -> stack_frame.entry_ptr, addrel (sp, 8) -> sx (0));
			if rel (callp) ^= "0"b
			then callp = addrel (callp, -1);
						/* never return neg offset */
		     end;
		return;				/* in any case, that's all we can do */
	     end;

/* have machine conditions, assume p is ppr */

	     offset = bin (rel (p), 18);		/* use to find out what kind of operator we're in */

/* see if fault occurred in an entry operator */

	     if offset >= bin (addr (pl1_operators_$entry_operators) -> tra_inst.addr, 18)
	     then do;				/* have entry operator */
		p1 = addr (pl1_operators_$entry_operators_end);
		if offset <= bin (rel (p1), 18)
		then do;
		     callp = addrel (mcptr -> mc.prs (2), -1);
						/* transfer was by tsp2 inst */
		     frame_flag = "0"b;		/* we were creating new frame, probably not completed */
		     return;
		end;
	     end;

	     if offset >= bin (addr (pl1_operators_$trace_entry_operators) -> tra_inst.addr, 18)
	     then do;
		p1 = addr (pl1_operators_$trace_entry_operators_end);
		if offset <= bin (rel (p1), 18)
		then do;
		     callp = addrel (mcptr -> mc.prs (2), -1);
		     frame_flag = "0"b;
		     return;
		end;
	     end;

/* check to see if fault frame is same as given frame;
   in any case, use fault frame */

	     rsp = mcptr -> mc.prs (6);		/* pick up sp from mc */
	     if sp ^= null
	     then rsp = ptr (sp, rel (rsp));		/* in case we are working on dead stack */
	     if rsp ^= sp
	     then frame_flag = "0"b;			/* different frame */

/* see if we were in an alm operator */

	     p1 = addr (pl1_operators_$alm_operators_begin);
	     p2 = addr (pl1_operators_$alm_operators_end);
	     if (offset >= bin (rel (p1), 18)) & (offset <= bin (rel (p2), 18))
	     then do;				/* find out which alm operator */
		p3 = addr (pl1_operators_$alm_call);
		p4 = addr (pl1_operators_$alm_push);
		if (offset >= bin (rel (p3), 18)) & (offset < bin (rel (p4), 18))
		then do;				/* alm call */
		     callp = addrel (mcptr -> mc.prs (4), -1);
		     return;
		end;
		p5 = addr (pl1_operators_$alm_return);
		if (offset >= bin (rel (p4), 18)) & (offset < bin (rel (p5), 18))
		then do;				/* alm push or entry */
		     callp = addrel (mcptr -> mc.prs (2), -1);
		     frame_flag = "0"b;		/* were working on new frame */
		     return;
		end;
		else return;			/* must have been in a return op; can do nothing */
	     end;

/* see if we were in the alm trace entry operator */

	     p1 = addr (pl1_operators_$alm_trace_operators_begin);
	     p2 = addr (pl1_operators_$alm_trace_operators_end);
	     if (offset >= bin (rel (p1), 18)) & (offset <= bin (rel (p2), 18))
	     then do;
		callp = addrel (mcptr -> mc.prs (2), -1);
		frame_flag = "0"b;			/* were working on a new frame */
		return;
	     end;

/* see if fault occurred in math routines */

	     p1 = addr (pl1_operators_$math_routines_);
	     if offset > bin (rel (p1), 18)
	     then do;
		callp = addrel (mcptr -> mc.prs (3), -1);
		if baseno (callp) = basic_operators_segno ()
		then do;				/* basic programs transfer to math operators from basic operators
						   and store return_pt in temp3 when they do */

		     unspec (p2) = unspec (sp -> d_basic_operators_frame.d_temp (3));
		     callp = addrel (p2, -1);
		end;
		return;
	     end;

/* see if we were in process of making a call */


check_call:
	     unspec (return_ptr_copy) = unspec (rsp -> stack_frame.return_ptr) & RETURN_PTR_MASK;

	     if p = addr (pl1_operators_$forward_call)
	     then callp = addrel (return_ptr_copy, -1);
						/* were making a call */

	     else if p = addr (pl1_operators_$var_call)
	     then callp = addrel (return_ptr_copy, -1);
						/* calling int proc or entry variable */

	     else if baseno (rsp -> stack_frame.entry_ptr) = opsegno
	     then ;				/* op had own frame */

/* call offset was stored either in x0 or at sp|37;
   can assume entry_ptr is good */

	     else if rsp -> stack_frame.operator_return_offset
	     then callp = ptr (rsp -> stack_frame.entry_ptr, bin (rsp -> stack_frame.operator_return_offset, 18) - 1);

	     else callp = ptr (rsp -> stack_frame.entry_ptr, bin (mcptr -> mc.regs.x (0), 18) - 1);

	     return;

	end;					/* done with pl1_operators_ */


	else if real_condition_segno = cobol_operators_segno ()
	then do;
	     if (rel (p) >= rel (addr (cobol_operators_$cobol_operators_)))
		& (rel (p) <= rel (addr (cobol_operators_$cobol_operators_end)))
	     then do;

/* Must be a cobol program.  Cobol always sets the return pointer to
   point to a special return operator so we can no use this.  However,
   in general cobol puts a return pointer to the main program in
   the stack frame at location 64 ( called return_to_main_ptr), and
   in the future this will always be valid;  so we will use it here.		*/

		op_name = "cobol_operators_";
		callp = cobol_stack_frame.return_to_main_ptr;

		if rel (callp) > "0"b
		then callp = addrel (callp, -1);	/* never return a neg offset */

	     end;
	end;

/* check here for basic_operators_; assume that basic_operators_ is bound
   first in bound_basic_runtime_ */

	else if real_condition_segno = basic_operators_segno ()
	then do;
	     if rel (p) < rel (addr (basic_operators_$end_basic_operators))
	     then do;
		op_name = "basic_operators_";

/* the offset of the operator return location is generally in x7;
   first take care of some special cases:  here look for part of entry
   sequence -- program has not yet been entered, but assume that
   we were in entry sequence. */

		p1 = addr (basic_operators_$enter_proc);
		p2 = addr (basic_operators_$end_entry_ops);
		if (rel (p1) <= rel (p)) & (rel (p) < rel (p2))
		then do;
		     if mcptr ^= null ()
		     then do;
			callp = addrel (mcptr -> mc.prs (2), 2);
						/* pr2 probably -> eax7 in entry code */
		     end;
		     return;
		end;

/* now check for case where we are calling another program,
   and before frame for program is created  -- cannot tell where we came
   from as x7 has been smashed, so use entry pointer of caller */

		p1 = addr (basic_operators_$call_op_begin);
		p2 = addr (basic_operators_$new_frame);
		if (rel (p1) <= rel (p)) & (rel (p) < rel (p2))
		then do;
		     if mcptr ^= null ()
		     then callp = sp -> stack_frame.entry_ptr;
		     return;
		end;

/* last special case: calling another basic program, and frame for the program
   has been pushed, use entry pointer in pr2 as location.  In this section
   pr2 -> location after tsp2, what addr of tsp2 */

		p1 = addr (basic_operators_$call_op_end);
		if (rel (p2) <= rel (p)) & (rel (p) < rel (p1))
		then do;
		     if mcptr ^= null ()
		     then callp = addrel (mcptr -> mc.prs (2), -1);
		     return;
		end;

/* try to get address from x7 */

		if mcptr ^= null ()
		then callp = addrel (ptr (sp -> stack_frame.entry_ptr, mcptr -> mc.regs.x (7)), -1);
		else do;				/* no fault, assume called out */
		     unspec (p1) = unspec (sp -> d_basic_operators_frame.d_temp (3));
						/* return pt */
		     do while (rel (p1) ^= (18)"0"b);	/* search for tsx7 to call op */
			p1 = addrel (p1, -1);
			if p1 -> tra_inst.opcode = "1110001110"b
			then do;
			     callp = p1;
			     return;
			end;
		     end;
		end;
		return;
	     end;

	end;

	else if real_condition_segno = algol68_operators_segno ()
	then do;
	     if (rel (p) >= rel (addr (algol68_operators_$algol68_operators_)))
		& (rel (p) <= rel (addr (algol68_operators_$end_operators)))
	     then do;
		op_name = "algol68_operators_";

/* first see if we are in an entry operator */

		p1 = addr (algol68_operators_$entry_operators_begin);
		p2 = addr (algol68_operators_$entry_operators_end);
		if (rel (p1) <= rel (p)) & (rel (p) <= rel (p2))
		then do;				/* in entry op; transferred by tsp2 */
		     if mcptr ^= null ()
		     then callp = addrel (mcptr -> mc.prs (2), -1);
		     return;
		end;

/* otherwise assume that transfer was by tsx2 */

		if mcptr ^= null ()
		then callp = ptr (sp -> stack_frame.entry_ptr, bin (mcptr -> mc.regs.x (2), 18) - 1);
	     end;
	end;

	else if real_condition_segno = pascal_operators_segno ()
	then do;
	     if (rel (p) >= rel (addr (pascal_operators_$pascal_operators_)))
		& (rel (p) <= rel (addr (pascal_operators_$pascal_operators_end)))
	     then do;
		op_name = "pascal_operators_";
		if mcptr ^= null ()			/* all xfers to pascal ops are by tsp3 */
		then callp = addrel (mcptr -> mc.prs (3), -1);
	     end;
	end;


	return;


/* This procedure is used to get a pointer to the end of basic_operators_.  It calls hcs_$make_ptr
   to avoid a linkage fault if basic is not at the current installation (it is unbundled).  This routine
   should be called before any other references are made to basic operators.
   This program will not cause basic_operators_' linkage section to be combined. */

basic_operators_segno:
     procedure () returns (bit (18) aligned);

	if ^have_made_basic_search
	then do;
	     call hcs_$make_ptr (null (), "basic_operators_", "", basic_operators_ptr, code);
	     have_made_basic_search = "1"b;
	end;

	return (baseno (basic_operators_ptr));

     end basic_operators_segno;

cobol_operators_segno:
     proc () returns (bit (18) aligned);

	call hcs_$make_ptr (null (), "cobol_operators_", "", cobol_operators_ptr, code);


	return (baseno (cobol_operators_ptr));


     end cobol_operators_segno;


algol68_operators_segno:
     proc () returns (bit (18) aligned);


	call hcs_$make_ptr (null (), "algol68_operators_", "", algol68_operators_ptr, code);

	return (baseno (algol68_operators_ptr));

     end algol68_operators_segno;


pascal_operators_segno:
     proc () returns (bit (18) aligned);

	call hcs_$make_ptr (null (), "pascal_operators_", "", pascal_operators_ptr, code);

	return (baseno (pascal_operators_ptr));

     end pascal_operators_segno;


     end interpret_op_ptr_;
  



		    pl1_operator_names_.alm         07/30/86  0919.2rew 07/28/86  1500.8      134667


" ***********************************************************
" *                                                         *
" * 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-1105):
"     Fix fortran bug 477.
"                                                      END HISTORY COMMENTS


"	Modified:	07 March 86, BW - Make names the same as those in 
"		pl1_operators_.alm.
"	Modified:	12 Dec 83, HH - Change displacements of "special" operators
"		from octal to decimal to allow negative values.  Move
"		'pl1_operators_$VLA_words_per_seg_' and add 'enter_BFP_mode'
"		and 'enter_HFP_mode'.

	name	pl1_operator_names_
	segdef	pl1_operator_names_,first,last,first_special,last_special,number_special

pl1_operator_names_:
	equ	first_n,361
	equ	first_s,-115
	equ	last_s,360

first:
	vfd	36/first_n
last:
	vfd	36/first_n+(last_normal-first_normal-1)
first_special:
	vfd	36/first_s
last_special:
	vfd	36/last_s
number_special:
	vfd	36/(last_spec-first_spec+1)/2

	macro	normal
	use	text
	zero	s&2,&l1
	use	data
s&2:	aci	"&1"
	&end

	macro	special
	use	text
	dec	&2
	zero	&U,&l1
	use	data
&U:	aci	"&1"
	&end

	use	text
first_normal:
	normal	(alloc_char_temp),0
	normal	(alloc_bit_temp),1
	normal	(alloc_temp),2
	normal	(realloc_char_temp),3
	normal	(realloc_bit_temp),4
	normal	(save_string),5
	normal	(pk_to_unpk),6
	normal	(unpk_to_pk),7
	normal	(move_chars),8
	normal	(move_chars_aligned),9
	normal	(move_bits),10
	normal	(move_bits_aligned),11
	normal	(chars_move),12
	normal	(chars_move_aligned),13
	normal	(bits_move),14
	normal	(bits_move_aligned),15
	normal	(move_not_bits),16
	normal	(move_not_bits_aligned),17
	normal	(ext_and_1),18
	normal	(ext_and_2),19
	normal	(comp_bits),20
	normal	(cpbs3),21
	normal	(cpbs3_aligned),22
	normal	(cpbs4),23
	normal	(cpcs_ext1),24
	normal	(cpcs_ext2),25
	normal	(cpbs_ext1),26
	normal	(cpbs_ext2),27
	normal	(store_string),28
	normal	(cat_realloc_chars),29
	normal	(cat_realloc_bits),30
	normal	(cp_chars),31
	normal	(cp_chars_aligned),32
	normal	(cp_bits),33
	normal	(cp_bits_aligned),34
	normal	(enter_begin_block),35
	normal	(leave_begin_block),36
	normal	(call_ent_var_desc),37
	normal	(call_ent_var),38
	normal	(call_ext_in_desc),39
	normal	(call_ext_in),40
	normal	(call_ext_out_desc),41
	normal	(call_ext_out),42
	normal	(call_int_this_desc),43
	normal	(call_int_this),44
	normal	(call_int_other_desc),45
	normal	(call_int_other),46
	normal	(begin_return_mac),47
	normal	(return_mac),48
	normal	(cat_move_chars),49
	normal	(cat_move_chars_aligned),50
	normal	(cat_move_bits),51
	normal	(cat_move_bits_aligned),52
	normal	(cat_chars),53
	normal	(cat_chars_aligned),54
	normal	(cat_bits),55
	normal	(cat_bits_aligned),56
	normal	(set_chars),57
	normal	(set_chars_aligned),58
	normal	(set_bits),59
	normal	(set_bits_aligned),60
	normal	(and_bits),61
	normal	(and_bits_aligned),62
	normal	(or_bits),63
	normal	(or_bits_aligned),64
	normal	(move_label_var),65
	normal	(make_label_var),66
	normal	(fl2_to_fx1),67
	normal	(fl2_to_fx2),68
	normal	(longbs_to_fx2),69
	normal	(tra_ext_1),70
	normal	(tra_ext_2),71
	normal	(alloc_auto_adj),72
	normal	(longbs_to_bs18),73
	normal	(stac_mac),74
	normal	(sign_mac),75
	normal	(bound_ck_signal),76
	normal	(trans_sign_fx1),77
	normal	(trans_sign_fl),78
	normal	(copy_words),79
	normal	(mpfx2),80
	normal	(mpfx3),81
	normal	(copy_const),82
	normal	(copy_const_vt),83
	normal	(sr_check),84
	normal	(chars_move_vt),85
	normal	(chars_move_vta),86
	normal	(bits_move_vt),87
	normal	(bits_move_vta),88
	normal	(mdfl1),89
	normal	(mdfl2),90
	normal	(mdfx1),91
	normal	(mdfx2),92
	normal	(mdfx3),93
	normal	(mdfx4),94
	normal	(copy_double),95
	normal	(string_store),96
	normal	(get_chars),97
	normal	(get_bits),98
	normal	(pad_chars),99
	normal	(pad_bits),100
	normal	(signal_op),101
	normal	(enable_op),102
	normal	(index_chars),103
	normal	(index_chars_aligned),104
	normal	(index_bits),105
	normal	(index_bits_aligned),106
	normal	(exor_bits),107
	normal	(exor_bits_aligned),108
	normal	(set_bits_co),109
	normal	(set_bits_ho),110
	normal	(set_chars_co),111
	normal	(set_chars_ho),112
	normal	(string_store_co),113
	normal	(string_store_ho),114
	normal	(get_chars_co),115
	normal	(get_chars_ho),116
	normal	(get_bits_co),117
	normal	(get_bits_ho),118
	normal	(and_bits_co),119
	normal	(and_bits_ho),120
	normal	(or_bits_co),121
	normal	(or_bits_ho),122
	normal	(exor_bits_co),123
	normal	(exor_bits_ho),124
	normal	(cat_move_bits_co),125
	normal	(cat_move_bits_ho),126
	normal	(move_not_bits_co),127
	normal	(move_not_bits_ho),128
	normal	(move_bits_co),129
	normal	(move_bits_ho),130
	normal	(move_chars_co),131
	normal	(move_chars_ho),132
	normal	(cat_move_chars_co),133
	normal	(cat_move_chars_ho),134
	normal	(cat_chars_co),135
	normal	(cat_chars_ho),136
	normal	(cat_bits_co),137
	normal	(cat_bits_ho),138
	normal	(io_signal),139
	normal	(index_cs_1),140
	normal	(index_cs_1_aligned),141
	normal	(fort_mdfl1),142
	normal	(rfb1_to_cflb1),143
	normal	(rfb2_to_cflb1),144
	normal	(mpcfl1_1),145
	normal	(mpcfl1_2),146
	normal	(dvcfl1_1),147
	normal	(dvcfl1_2),148
	normal	(chars_move_vt_co),149
	normal	(chars_move_vt_ho),150
	normal	(chars_move_co),151
	normal	(chars_move_ho),152
	normal	(bits_move_vt_co),153
	normal	(bits_move_vt_ho),154
	normal	(bits_move_co),155
	normal	(bits_move_ho),156
	normal	(cp_chars_co),157
	normal	(cp_chars_ho),158
	normal	(cp_bits_co),159
	normal	(cp_bits_ho),160
	normal	(cpbs3_co),161
	normal	(cpbs3_ho),162
	normal	(shorten_stack),163
	normal	(zero_bits),164
	normal	(zero_bits_aligned),165
	normal	(zero_bits_co),166
	normal	(zero_bits_ho),167
	normal	(blank_chars),168
	normal	(blank_chars_aligned),169
	normal	(blank_chars_co),170
	normal	(blank_chars_ho),171
	normal	(index_chars_co),172
	normal	(index_chars_ho),173
	normal	(index_bits_co),174
	normal	(index_bits_ho),175
	normal	(index_cs_1_co),176
	normal	(index_cs_1_ho),177
	normal	(index_bs_1),178
	normal	(index_bs_1_aligned),179
	normal	(index_bs_1_co),180
	normal	(index_bs_1_ho),181
	normal	(shift_bo),182
	normal	(return_words),183
	normal	(return_bits),184
	normal	(return_bits_co),185
	normal	(return_bits_ho),186
	normal	(return_bits_al),187
	normal	(ext_entry),188
	normal	(ext_entry_desc),189
	normal	(int_entry),190
	normal	(int_entry_desc),191
	normal	(val_entry),192
	normal	(val_entry_desc),193
	normal	(get_chars_aligned),194
	normal	(get_bits_aligned),195
	normal	(fetch_chars),196
	normal	(fetch_bits),197
	normal	(get_terminate),198
	normal	(put_terminate),199
	normal	(put_data_aligned),200
	normal	(get_list_aligned),201
	normal	(get_edit_aligned),202
	normal	(put_list_aligned),203
	normal	(put_edit_aligned),204
	normal	(strem_prep),205
	normal	(record_io),206
	normal	(open_file),207
	normal	(close_file),208
	normal	(put_data),209
	normal	(put_data_co),210
	normal	(put_data_ho),211
	normal	(get_list),212
	normal	(get_list_co),213
	normal	(get_list_ho),214
	normal	(get_edit),215
	normal	(get_edit_co),216
	normal	(get_edit_ho),217
	normal	(put_list),218
	normal	(put_list_co),219
	normal	(put_list_ho),220
	normal	(put_edit),221
	normal	(put_edit_co),222
	normal	(put_edit_ho),223
	normal	(suffix_cs),224
	normal	(suffix_bs),225
	normal	(fl2_to_fxscaled),226
	normal	(trunc_fx1),227
	normal	(trunc_fx2),228
	normal	(ceil_fx1),229
	normal	(ceil_fx2),230
	normal	(ceil_fl),231
	normal	(floor_fx1),232
	normal	(floor_fx2),233
	normal	(floor_fl),234
	normal	(trunc_fl),235
	normal	(round_fx1),236
	normal	(round_fx2),237
	normal	(repeat),238
	normal	(make_bit_table),239
	normal	(make_bit_table_al),240
	normal	(make_bit_table_co),241
	normal	(make_bit_table_ho),242
	normal	(verify),243
	normal	(verify_al),244
	normal	(verify_co),245
	normal	(verify_ho),246
	normal	(const_verify),247
	normal	(const_verify_al),248
	normal	(const_verify_co),249
	normal	(const_verify_ho),250
	normal	(reverse_cs),251
	normal	(reverse_bs),252
	normal	(form_bit_table),253
	normal	(form_bit_table_co),254
	normal	(form_bit_table_ho),255
	normal	(form_bit_table_al),256
	normal	(chars_move_ck),257
	normal	(chars_move_ck_co),258
	normal	(chars_move_ck_ho),259
	normal	(chars_move_ck_al),260
	normal	(bits_move_ck),261
	normal	(bits_move_ck_co),262
	normal	(bits_move_ck_ho),263
	normal	(bits_move_ck_al),264
	normal	(size_check_fx1),265
	normal	(size_check_fx2),266
	normal	(signal_stringsize),267
	normal	(suffix_cs_ck),268
	normal	(suffix_bs_ck),269
	normal	(pointer_hard),270
	normal	(alm_call),271
	normal	(alm_push),272
	normal	(alm_return),273
	normal	(alm_return_no_pop),274
	normal	(alm_entry),275
	normal	(packed_to_bp),276
	normal	(return_chars),277
	normal	(return_chars_co),278
	normal	(return_chars_ho),279
	normal	(return_chars_aligned),280
	normal	(rpd_odd_lp_bp),281
	normal	(rpd_odd_bp_lp),282
	normal	(rpd_even_lp_bp),283
	normal	(rpd_even_bp_lp),284
	normal	(offset_easy),285
	normal	(offset_easy_pk),286
	normal	(offset_hard),287
	normal	(offset_hard_pk),288
	normal	(pointer_hard_pk),289
	normal	(pointer_easy),290
	normal	(pointer_easy_pk),291
	normal	(round_fl),292
	normal	(enable_file),293
	normal	(revert_file),294
	normal	(alloc_block),295
	normal	(free_block),296
	normal	(push_ctl_data),297
	normal	(push_ctl_desc),298
	normal	(pop_ctl_data),299
	normal	(pop_ctl_desc),300
	normal	(allocation),301
	normal	(set_chars_eis),302
	normal	(set_bits_eis),303
	normal	(index_chars_eis),304
	normal	(index_bits_eis),305
	normal	(index_cs_1_eis),306
	normal	(index_bs_1_eis),307
	normal	(return_chars_eis),308
	normal	(return_bits_eis),309
	normal	(put_data_eis),310
	normal	(put_format_),311
	normal	(put_list_eis),312
	normal	(put_format_),313
	normal	(get_list_eis),314
	normal	(verify_eis),315
	normal	(search_eis),316
	normal	(fortran_read),317
	normal	(fortran_write),318
	normal	(fortran_manip),319
	normal	(fortran_scalar_xmit),320
	normal	(fortran_array_xmit),321
	normal	(fortran_terminate),322
	normal	(real_to_real_round_),323
	normal	(real_to_real_truncate_),324
	normal	(any_to_any_round_),325
	normal	(any_to_any_truncate_),326
	normal	(unpack_picture),327
	normal	(pack_picture),328
	normal	(divide_fx1),329
	normal	(divide_fx2),330
	normal	(divide_fx3),331
	normal	(divide_fx4),332
	normal	(scaled_mod_fx1),333
	normal	(scaled_mod_fx2),334
	normal	(scaled_mod_fx3),335
	normal	(scaled_mod_fx4),336
	normal	(translate_2),337
	normal	(translate_3),338
	normal	(square_root_),339
	normal	(sine_radians_),340
	normal	(sine_degrees_),341
	normal	(cosine_radians_),342
	normal	(cosine_degrees_),343
	normal	(tangent_radians_),344
	normal	(tangent_degrees_),345
	normal	(arc_sine_radians_),346
	normal	(arc_sine_degrees_),347
	normal	(arc_cosine_radians_),348
	normal	(arc_cosine_degrees_),349
	normal	(arc_tangent_radians_),350
	normal	(arc_tangent_degrees_),351
	normal	(log_base_2_),352
	normal	(log_base_e_),353
	normal	(log_base_10_),354
	normal	(exponential_),355
	normal	(double_square_root_),356
	normal	(double_sine_radians_),357
	normal	(double_sine_degrees_),358
	normal	(double_cosine_radians_),359
	normal	(double_cosine_degrees_),360
	normal	(double_tangent_radians_),361
	normal	(double_tangent_degrees_),362
	normal	(double_arc_sine_radians_),363
	normal	(double_arc_sine_degrees_),364
	normal	(double_arc_cosine_radians_),365
	normal	(double_arc_cosine_degrees_),366
	normal	(double_arc_tan_radians_),367
	normal	(double_arc_tan_degrees_),368
	normal	(double_log_base_2_),369
	normal	(double_log_base_e_),370
	normal	(double_log_base_10_),371
	normal	(double_exponential_),372
	normal	(arc_tangent_radians_2_),373
	normal	(arc_tangent_degrees_2_),374
	normal	(double_arc_tan_radians_2_),375
	normal	(double_arc_tan_degrees_2_),376
	normal	(integer_power_single_),377
	normal	(integer_power_double_),378
	normal	(double_power_single_),379
	normal	(double_power_double_),380
	normal	(double_power_integer_),381
	normal	(single_power_single_),382
	normal	(single_power_integer_),383
	normal	(integer_power_integer_),384
	normal	(signal_size),385
	normal	(ss_ext_entry),386
	normal	(ss_ext_entry_desc),387
	normal	(ss_int_entry),388
	normal	(ss_int_entry_desc),389
	normal	(ss_val_entry),390
	normal	(ss_val_entry_desc),391
	normal	(mpcdec),392
	normal	(dvcdec),393
	normal	(dvrcdec),394
	normal	(ceil),395
	normal	(floor),396
	normal	(sign),397
	normal	(cabs),398
	normal	(truncate),399
	normal	(mod),400
	normal	(set_support),401
	normal	(div_4_cplx_ops),402
	normal	(fetch_chars_eis),403
	normal	(signal_stringrange),404
	normal	(ss_enter_begin_block),405
	normal 	(put_field),406
	normal	(put_field_chk),407
	normal	(put_control),408
	normal	(op_alloc_),409
	normal	(alloc_storage),410
	normal	(op_freen_),411
	normal	(op_empty_),412
	normal	(cabs),413
	normal	(ccos),414
	normal	(cexp),415
	normal	(clog),416
	normal	(csin),417
	normal	(csqrt),418
	normal	(tanh),419
	normal	(dmod),420
	normal	(cmpx_p_cmpx),421
	normal	(get_math_entry),422
	normal	(fortran_pause),423
	normal	(fortran_stop),424
	normal	(fortran_chain),425
	normal	(long_profile),426
	normal	(index_before_cs),427
	normal	(index_before_bs),428
	normal	(index_after_cs),429
	normal	(index_after_bs),430
	normal	(index_before_bs_1),431
	normal	(index_after_bs_1),432
	normal	(verify_for_ltrim),433
	normal	(verify_for_rtrim),434
	normal	(stacq_mac),435
	normal	(clock_mac),436
	normal	(vclock_mac),437
	normal	(ftn_open_element),438
	normal	(ftn_get_area_ptr),439
	normal	(stop),440
	normal	(return_main),441
	normal	(set_main_flag),442
	normal	(begin_return_main),443
	normal	(size_check_uns_fx1),444
	normal	(size_check_uns_fx2),445
	normal	(fortran_end),446
	normal	(fort_dmod),447
	normal	(ix_rev_chars),448
	normal	(verify_rev_chars),449
	normal	(search_rev_chars),450
	normal	(shorten_stack_protect_ind),451
	normal	(save_stack_quick),452
	normal	(restore_stack_quick),453
	normal	(dtanh),454
	normal	(sinh),455
	normal	(dsinh),456
	normal	(cosh),457
	normal	(dcosh),458
	normal	(nearest_whole_number),459
	normal	(nearest_integer),460
	normal	(ftn_inquire_element),461
	normal	(mpy_overflow_check),462
	normal	(fort_return_mac),463
	normal	(fort_cleanup),464
	normal	(fort_storage),465
	normal	(enter_BFP_mode),466
	normal	(enter_HFP_mode),467
	use	text
last_normal:
first_spec:
	special	(VLA_words_per_seg_),-115
	special	(fx1_to_fx2),306
	special	(fx1_to_fl2),309
	special	(fx2_to_fl2),310
	special	(reset_stack),314
	special	(r_l_a),316
	special	(r_g_s),319
	special	(r_g_a),323
	special	(r_l_s),327
	special	(r_e_as),330
	special	(r_ne_as),333
	special	(r_le_a),336
	special	(r_ge_s),340
	special	(r_ge_a),343
	special	(r_le_s),346
	special	(set_stack),352
	use	text
last_spec:
	join	/text/text,data
	end
 



		    runtime_symbol_info_.pl1        11/12/86  1736.3rew 11/12/86  1607.4      216000


/****^  *************************************************************************
        *                                                                       *
        * Copyright (c) 1980 by Centre Interuniversitaire de Calcul de Grenoble *
        * and Institut National de Recherche en Informatique et Automatique     *
        *                                                                       *
        ************************************************************************* */


/****^  HISTORY COMMENTS:
  1) change(86-09-05,JMAthane), approve(86-09-05,MCR7525),
     audit(86-09-11,Martinson), install(86-11-12,MR12.0-1212):
     Added runtime_symbol_info_$subrange entry which was missing.  Added
     has_dimensions and has_subrange_limits fields in type_info record.
     Structure version numbers have not been changed since this change does not
     affect existing programs.
                                                   END HISTORY COMMENTS */

/* Written June 83 JMAthane Grenoble University */

/* This set of entries return information about both old (fixed format)
   and new (variable format designed for PASCAL) symbol tables */


/* The include segment runtime_symbol_info_.incl.pl1 contains declarations
          of these entries and of the structures filled by them.  */
/* Changed to use include file declarations 09/02/83 S. Herbst */
/* Added version strings to structures, status codes to entries using them 10/05/83 S. Herbst */
/* Added subrange entry, and filling of new fields in type_info
(size_is_encoded, has_subrange_limits and has_dimensions)	JMAthane 08/31/84 */

runtime_symbol_info_: proc;

	dcl     bp		 ptr parameter;
	dcl     info_ptr		 ptr parameter;
	dcl     code		 fixed bin (35);

	dcl     i			 fixed bin;
	dcl     work		 ptr;
	dcl     (addr, addrel, bin, fixed, min, null, size)
				 builtin;

	dcl     error_table_$unimplemented_version
				 fixed bin (35) external;
%page;
son: entry (bp) returns (ptr);

	if bp -> pascal_symbol_node_header.flags.version_flag then
	     if bp -> runtime_symbol.son = "0"b then return (null);
	     else return (addrel (bp, bp -> runtime_symbol.son));

	if ^bp -> pascal_symbol_node_header.flags.son_level then return (null);

	i = size (pascal_symbol_node_header);
	if bp -> pascal_symbol_node_header.flags.name_next then i = i + size (pascal_name_next);
	if bp -> pascal_symbol_node_header.flags.base_type_info then i = i + size (pascal_base_type_info);
	if bp -> pascal_symbol_node_header.flags.address then i = i + size (pascal_address);
	if bp -> pascal_symbol_node_header.flags.father_brother then i = i + size (pascal_father_brother);
	work = addrel (bp, i);
	if work -> pascal_son_level.son = 0 then return (null);
	return (addrel (bp, work -> pascal_son_level.son));
%page;
father_type: entry (bp) returns (ptr);

	if bp -> pascal_symbol_node_header.flags.version_flag then
	     return (null);

	if ^bp -> pascal_symbol_node_header.flags.father_type_successor then return (null);

	i = size (pascal_symbol_node_header);
	if bp -> pascal_symbol_node_header.flags.name_next then i = i + size (pascal_name_next);
	if bp -> pascal_symbol_node_header.flags.base_type_info then i = i + size (pascal_base_type_info);
	if bp -> pascal_symbol_node_header.flags.address then i = i + size (pascal_address);
	if bp -> pascal_symbol_node_header.flags.father_brother then i = i + size (pascal_father_brother);
	if bp -> pascal_symbol_node_header.flags.son_level then i = i + size (pascal_son_level);
	work = addrel (bp, i);
	if work -> pascal_father_type_successor.father_type = 0 then return (null);
	return (addrel (bp, work -> pascal_father_type_successor.father_type));
%page;
successor: entry (bp) returns (ptr);

	if bp -> pascal_symbol_node_header.flags.version_flag then
	     return (null);

	if ^bp -> pascal_symbol_node_header.flags.father_type_successor then return (null);

	i = size (pascal_symbol_node_header);
	if bp -> pascal_symbol_node_header.flags.name_next then i = i + size (pascal_name_next);
	if bp -> pascal_symbol_node_header.flags.base_type_info then i = i + size (pascal_base_type_info);
	if bp -> pascal_symbol_node_header.flags.address then i = i + size (pascal_address);
	if bp -> pascal_symbol_node_header.flags.father_brother then i = i + size (pascal_father_brother);
	if bp -> pascal_symbol_node_header.flags.son_level then i = i + size (pascal_son_level);
	work = addrel (bp, i);
	if work -> pascal_father_type_successor.successor = 0 then return (null);
	return (addrel (bp, work -> pascal_father_type_successor.successor));
%page;
level: entry (bp) returns (fixed bin);

	if bp -> pascal_symbol_node_header.flags.version_flag then
	     return (fixed (bp -> runtime_symbol.level, 6));

	if ^bp -> pascal_symbol_node_header.flags.son_level then return (0);

	i = size (pascal_symbol_node_header);
	if bp -> pascal_symbol_node_header.flags.name_next then i = i + size (pascal_name_next);
	if bp -> pascal_symbol_node_header.flags.base_type_info then i = i + size (pascal_base_type_info);
	if bp -> pascal_symbol_node_header.flags.address then i = i + size (pascal_address);
	if bp -> pascal_symbol_node_header.flags.father_brother then i = i + size (pascal_father_brother);
	return (addrel (bp, i) -> pascal_son_level.level);
%page;
type: entry (bp, info_ptr, code);

	dcl     1 type_info		 like runtime_type_info based (info_ptr);

	if type_info.version ^= RUNTIME_TYPE_INFO_VERSION_1 then do;
		code = error_table_$unimplemented_version;
		return;
	     end;

	code = 0;

	if bp -> pascal_symbol_node_header.version_flag then do;
		type_info.aligned = bp -> runtime_symbol.aligned;
		type_info.packed = bp -> runtime_symbol.packed;
		type_info.scale = fixed (bp -> runtime_symbol.scale, 8);
		type_info.size = bp -> runtime_symbol.size;
		type_info.size_is_encoded = is_encoded (type_info.size);
		type_info.type = fixed (bp -> runtime_symbol.type, 6);
		type_info.base_type = 0;
		type_info.type_addr = null;
		type_info.base_type_addr = null;
		type_info.has_dimensions = (bp -> runtime_symbol.ndims ^= "0"b);
		type_info.has_subrange_limits = "0"b;
		return;
	     end;

	type_info.aligned = bp -> pascal_symbol_node_header.aligned;
	type_info.packed = bp -> pascal_symbol_node_header.packed;
	type_info.type = bp -> pascal_symbol_node_header.type;
	type_info.size_is_encoded = bp -> pascal_symbol_node_header.size_is_encoded;
	type_info.has_dimensions = bp -> pascal_symbol_node_header.array_info;
	type_info.has_subrange_limits = bp -> pascal_symbol_node_header.subrange_limits;
	type_info.scale = 0;
	if bp -> pascal_symbol_node_header.type_offset = 0 then
	     type_info.type_addr = null;
	else
	     type_info.type_addr = addrel (bp, bp -> pascal_symbol_node_header.type_offset);
	if ^bp -> pascal_symbol_node_header.base_type_info then do;
		type_info.base_type = 0;
		type_info.base_type_addr = null;
		if ^bp -> pascal_symbol_node_header.size then type_info.size = 0;
		else do;
			i = size (pascal_symbol_node_header);
			if bp -> pascal_symbol_node_header.flags.name_next then
			     i = i + size (pascal_name_next);
			if bp -> pascal_symbol_node_header.flags.base_type_info then
			     i = i + size (pascal_base_type_info);
			if bp -> pascal_symbol_node_header.flags.address then
			     i = i + size (pascal_address);
			if bp -> pascal_symbol_node_header.flags.father_brother then
			     i = i + size (pascal_father_brother);
			if bp -> pascal_symbol_node_header.flags.son_level then
			     i = i + size (pascal_son_level);
			if bp -> pascal_symbol_node_header.flags.father_type_successor then
			     i = i + size (pascal_father_type_successor);
			work = addrel (bp, i);
			type_info.size = work -> pascal_size;
		     end;
	     end;
	else do;
		i = size (pascal_symbol_node_header);
		if bp -> pascal_symbol_node_header.flags.name_next then i = i + size (pascal_name_next);
		work = addrel (bp, i);
		type_info.base_type = work -> pascal_base_type_info.base_type;
		if work -> pascal_base_type_info.base_type_offset = 0 then
		     type_info.base_type_addr = null;
		else
		     type_info.base_type_addr = addrel (bp, work -> pascal_base_type_info.base_type_offset);
		if ^bp -> pascal_symbol_node_header.size then type_info.size = 0;
		else do;
			if bp -> pascal_symbol_node_header.flags.base_type_info then
			     i = i + size (pascal_base_type_info);
			if bp -> pascal_symbol_node_header.flags.address then
			     i = i + size (pascal_address);
			if bp -> pascal_symbol_node_header.flags.father_brother then
			     i = i + size (pascal_father_brother);
			if bp -> pascal_symbol_node_header.flags.son_level then
			     i = i + size (pascal_son_level);
			if bp -> pascal_symbol_node_header.flags.father_type_successor then
			     i = i + size (pascal_father_type_successor);
			work = addrel (bp, i);
			type_info.size = work -> pascal_size;
		     end;
	     end;
	return;
%page;
father: entry (bp) returns (ptr);

	if bp -> pascal_symbol_node_header.flags.version_flag then
	     if bp -> runtime_symbol.father = "0"b then return (null);
	     else return (addrel (bp, bp -> runtime_symbol.father));

	if ^bp -> pascal_symbol_node_header.flags.father_brother then return (null ());

	i = size (pascal_symbol_node_header);
	if bp -> pascal_symbol_node_header.flags.name_next then i = i + size (pascal_name_next);
	if bp -> pascal_symbol_node_header.flags.base_type_info then i = i + size (pascal_base_type_info);
	if bp -> pascal_symbol_node_header.flags.address then i = i + size (pascal_address);
	work = addrel (bp, i);
	if work -> pascal_father_brother.father = 0 then return (null);
	return (addrel (bp, work -> pascal_father_brother.father));
%page;
brother: entry (bp) returns (ptr);

	if bp -> pascal_symbol_node_header.flags.version_flag then
	     if bp -> runtime_symbol.brother = "0"b then return (null);
	     else return (addrel (bp, bp -> runtime_symbol.brother));

	if ^bp -> pascal_symbol_node_header.flags.father_brother then return (null ());

	i = size (pascal_symbol_node_header);
	if bp -> pascal_symbol_node_header.flags.name_next then i = i + size (pascal_name_next);
	if bp -> pascal_symbol_node_header.flags.base_type_info then i = i + size (pascal_base_type_info);
	if bp -> pascal_symbol_node_header.flags.address then i = i + size (pascal_address);
	work = addrel (bp, i);
	if work -> pascal_father_brother.brother = 0 then return (null);
	else
	     return (addrel (bp, work -> pascal_father_brother.brother));
%page;
name: entry (bp) returns (ptr);

	if bp -> pascal_symbol_node_header.flags.version_flag then
	     if bp -> runtime_symbol.name = "0"b then return (null);
	     else return (addrel (bp, bp -> runtime_symbol.name));

	if ^bp -> pascal_symbol_node_header.flags.name_next then return (null);

	work = addrel (bp, size (pascal_symbol_node_header));
	if work -> pascal_name_next.name = 0 then return (null);
	return (addrel (bp, work -> pascal_name_next.name));
%page;

next: entry (bp) returns (ptr);

	if bp -> pascal_symbol_node_header.flags.version_flag then do;
		if bp -> runtime_symbol.next = "0"b then return (null);
		return (addrel (bp, bin (bp -> runtime_symbol.next, 14) - 16384));
	     end;

	if ^bp -> pascal_symbol_node_header.flags.name_next then return (null);

	work = addrel (bp, size (pascal_symbol_node_header));
	if work -> pascal_name_next.next_token = 0 then return (null);
	return (addrel (bp, work -> pascal_name_next.next_token));
%page;
address: entry (bp, info_ptr, code);

	dcl     1 address_info	 like runtime_address_info based (info_ptr);

	if address_info.version ^= RUNTIME_ADDRESS_INFO_VERSION_1 then do;
		code = error_table_$unimplemented_version;
		return;
	     end;

	code = 0;

	if bp -> pascal_symbol_node_header.flags.version_flag then do;
		address_info.location = fixed (bp -> runtime_symbol.location, 18);
		address_info.class = fixed (bp -> runtime_symbol.class, 4);
		address_info.units = fixed (bp -> runtime_symbol.units, 2);
		address_info.use_digit = fixed (bp -> runtime_symbol.use_digit, 1);
		if bp -> runtime_symbol.bits.simple then do;
			address_info.offset_is_encoded = "0"b;
			address_info.offset = 0;
		     end;
		else do;
			address_info.offset = bp -> runtime_symbol.offset;
			address_info.offset_is_encoded = is_encoded (address_info.offset);
		     end;
		return;
	     end;

	if ^bp -> pascal_symbol_node_header.flags.address then do;
		address_info.class = 0;
		return;
	     end;

	i = size (pascal_symbol_node_header);
	if bp -> pascal_symbol_node_header.flags.name_next then i = i + size (pascal_name_next);
	if bp -> pascal_symbol_node_header.flags.base_type_info then i = i + size (pascal_base_type_info);
	work = addrel (bp, i);
	address_info.location = work -> pascal_address.location;
	address_info.class = work -> pascal_address.class;
	address_info.units = fixed (work -> pascal_address.units, 2);
	address_info.use_digit = fixed (work -> pascal_address.use_digit, 1);
	address_info.offset_is_encoded = work -> pascal_address.offset_is_encoded;

	if ^bp -> pascal_symbol_node_header.flags.offset then address_info.offset = 0;
	else do;
		i = i + size (pascal_address);
		if bp -> pascal_symbol_node_header.flags.father_brother then
		     i = i + size (pascal_father_brother);
		if bp -> pascal_symbol_node_header.flags.son_level then
		     i = i + size (pascal_son_level);
		if bp -> pascal_symbol_node_header.flags.father_type_successor then
		     i = i + size (pascal_father_type_successor);
		if bp -> pascal_symbol_node_header.flags.size then
		     i = i + size (pascal_size);
		address_info.offset = addrel (bp, i) -> pascal_offset;
	     end;
	return;
%page;
array_dims: entry (bp) returns (fixed bin);

	if bp -> pascal_symbol_node_header.version_flag then return (bp -> runtime_symbol.ndims);

	if ^bp -> pascal_symbol_node_header.array_info then return (0);

	i = size (pascal_symbol_node_header);
	if bp -> pascal_symbol_node_header.flags.name_next then i = i + size (pascal_name_next);
	if bp -> pascal_symbol_node_header.flags.base_type_info then i = i + size (pascal_base_type_info);
	if bp -> pascal_symbol_node_header.flags.address then i = i + size (pascal_address);
	if bp -> pascal_symbol_node_header.flags.father_brother then i = i + size (pascal_father_brother);
	if bp -> pascal_symbol_node_header.flags.son_level then i = i + size (pascal_son_level);
	if bp -> pascal_symbol_node_header.flags.father_type_successor then i = i + size (pascal_father_type_successor);
	if bp -> pascal_symbol_node_header.flags.size then i = i + size (pascal_size);
	if bp -> pascal_symbol_node_header.flags.offset then i = i + size (pascal_offset);
	if bp -> pascal_symbol_node_header.flags.subrange_limits then i = i + size (pascal_subrange_limits);
	return (addrel (bp, i) -> pascal_array_info.ndims);
%page;
array: entry (bp, info_ptr, code);

	dcl     1 array_info	 like runtime_array_info based (info_ptr);

	if array_info.version ^= RUNTIME_ARRAY_INFO_VERSION_1 then do;
		code = error_table_$unimplemented_version;
		return;
	     end;

	code = 0;

	if bp -> pascal_symbol_node_header.version_flag then do;
		n_dims = fixed (bp -> runtime_symbol.ndims, 6);
		unspec (array_info) = "0"b;
		array_info.ndims = n_dims;
		if n_dims > 0 then do;
			array_info.use_digit = fixed (bp -> runtime_symbol.use_digit, 1);
			array_info.array_units = fixed (bp -> runtime_symbol.array_units, 2);
			array_info.virtual_origin = bp -> runtime_symbol.virtual_org;
			array_info.virtual_origin_is_encoded = is_encoded (array_info.virtual_origin);
			do i = 1 to min (n_dims, 16);
			     array_info.bounds (i).lower = bp -> runtime_symbol.bounds (i).lower;
			     array_info.bounds (i).upper = bp -> runtime_symbol.bounds (i).upper;
			     array_info.bounds (i).multiplier = bp -> runtime_symbol.bounds (i).multiplier;
			     array_info.bounds (i).lower_is_encoded = is_encoded (array_info.bounds (i).lower);
			     array_info.bounds (i).upper_is_encoded = is_encoded (array_info.bounds (i).upper);
			     array_info.bounds (i).multiplier_is_encoded = is_encoded (array_info.bounds (i).multiplier);
			     array_info.bounds (i).subscript_type = 0;
			     array_info.bounds (i).subscript_type_addr = null;
			end;
		     end;
		return;
	     end;

	if ^bp -> pascal_symbol_node_header.array_info then return;

	i = size (pascal_symbol_node_header);
	if bp -> pascal_symbol_node_header.flags.name_next then i = i + size (pascal_name_next);
	if bp -> pascal_symbol_node_header.flags.base_type_info then i = i + size (pascal_base_type_info);
	if bp -> pascal_symbol_node_header.flags.address then i = i + size (pascal_address);
	if bp -> pascal_symbol_node_header.flags.father_brother then i = i + size (pascal_father_brother);
	if bp -> pascal_symbol_node_header.flags.son_level then i = i + size (pascal_son_level);
	if bp -> pascal_symbol_node_header.flags.father_type_successor then i = i + size (pascal_father_type_successor);
	if bp -> pascal_symbol_node_header.flags.size then i = i + size (pascal_size);
	if bp -> pascal_symbol_node_header.flags.offset then i = i + size (pascal_offset);
	if bp -> pascal_symbol_node_header.flags.subrange_limits then i = i + size (pascal_subrange_limits);
	work = addrel (bp, i);
	array_info.ndims, n_dims = work -> pascal_array_info.ndims;
	array_info.array_units = work -> pascal_array_info.array_units;
	array_info.virtual_origin_is_encoded = work -> pascal_array_info.virtual_origin_is_encoded;
	array_info.virtual_origin = work -> pascal_array_info.virtual_origin;
	array_info.use_digit = work -> pascal_array_info.use_digit;
	do i = 1 to min (n_dims, 16);
	     array_info.bounds (i).lower_is_encoded = work -> pascal_array_info.bounds (i).lower_is_encoded;
	     array_info.bounds (i).upper_is_encoded = work -> pascal_array_info.bounds (i).upper_is_encoded;
	     array_info.bounds (i).multiplier_is_encoded = work -> pascal_array_info.bounds (i).multiplier_is_encoded;
	     array_info.bounds (i).lower = work -> pascal_array_info.bounds (i).lower;
	     array_info.bounds (i).upper = work -> pascal_array_info.bounds (i).upper;
	     array_info.bounds (i).multiplier = work -> pascal_array_info.bounds (i).multiplier;
	     array_info.bounds (i).subscript_type = work -> pascal_array_info.bounds (i).subscript_type;
	     if work -> pascal_array_info.bounds (i).subscript_type_offset ^= 0 then
		array_info.bounds (i).subscript_type_addr =
		     addrel (bp, work -> pascal_array_info.bounds (i).subscript_type_offset);
	     else
		array_info.bounds (i).subscript_type_addr = null;
	end;
	return;
%page;
subrange: entry (bp, info_ptr, code);

	dcl     1 subrange_info	 like runtime_subrange_info based (info_ptr);

	if subrange_info.version ^= RUNTIME_SUBRANGE_INFO_VERSION_1 then do;
		code = error_table_$unimplemented_version;
		return;
	     end;

	code = 0;

	subrange_info.has_subrange_limits = "0"b;

	if bp -> pascal_symbol_node_header.version_flag then return;

	if ^bp -> pascal_symbol_node_header.subrange_limits then return;

	i = size (pascal_symbol_node_header);
	if bp -> pascal_symbol_node_header.flags.name_next then i = i + size (pascal_name_next);
	if bp -> pascal_symbol_node_header.flags.base_type_info then i = i + size (pascal_base_type_info);
	if bp -> pascal_symbol_node_header.flags.address then i = i + size (pascal_address);
	if bp -> pascal_symbol_node_header.flags.father_brother then i = i + size (pascal_father_brother);
	if bp -> pascal_symbol_node_header.flags.son_level then i = i + size (pascal_son_level);
	if bp -> pascal_symbol_node_header.flags.father_type_successor then i = i + size (pascal_father_type_successor);
	if bp -> pascal_symbol_node_header.flags.size then i = i + size (pascal_size);
	if bp -> pascal_symbol_node_header.flags.offset then i = i + size (pascal_offset);
	work = addrel (bp, i);
	subrange_info.has_subrange_limits = "1"b;
	subrange_info.upper_bound_is_encoded = work -> pascal_subrange_limits.upper_bound_is_encoded;
	subrange_info.lower_bound_is_encoded = work -> pascal_subrange_limits.lower_bound_is_encoded;
	subrange_info.subrange_lower_bound = work -> pascal_subrange_limits.subrange_lower_bound;
	subrange_info.subrange_upper_bound = work -> pascal_subrange_limits.subrange_upper_bound;
	return;
%page;
n_variants: entry (bp) returns (fixed bin);

	if bp -> pascal_symbol_node_header.version_flag then return (0);

	if ^bp -> pascal_symbol_node_header.variant_info then return (0);

	i = size (pascal_symbol_node_header);
	if bp -> pascal_symbol_node_header.flags.name_next then i = i + size (pascal_name_next);
	if bp -> pascal_symbol_node_header.flags.base_type_info then i = i + size (pascal_base_type_info);
	if bp -> pascal_symbol_node_header.flags.address then i = i + size (pascal_address);
	if bp -> pascal_symbol_node_header.flags.father_brother then i = i + size (pascal_father_brother);
	if bp -> pascal_symbol_node_header.flags.son_level then i = i + size (pascal_son_level);
	if bp -> pascal_symbol_node_header.flags.father_type_successor then i = i + size (pascal_father_type_successor);
	if bp -> pascal_symbol_node_header.flags.size then i = i + size (pascal_size);
	if bp -> pascal_symbol_node_header.flags.offset then i = i + size (pascal_offset);
	if bp -> pascal_symbol_node_header.flags.subrange_limits then i = i + size (pascal_subrange_limits);
	if bp -> pascal_symbol_node_header.array_info then do;
		nd = addrel (bp, i) -> pascal_array_info.ndims;
		i = i + size (addrel (bp, i) -> pascal_array_info);
	     end;

	return (addrel (bp, i) -> pascal_variant_info.number_of_variants);
%page;
variant: entry (bp, info_ptr, code);

	dcl     1 variant_info	 like runtime_variant_info based (info_ptr);

	if variant_info.version ^= RUNTIME_VARIANT_INFO_VERSION_1 then do;
		code = error_table_$unimplemented_version;
		return;
	     end;

	code = 0;

	if bp -> pascal_symbol_node_header.version_flag then do;
no_variants:
		return;
	     end;

	if ^bp -> pascal_symbol_node_header.variant_info then go to no_variants;

	i = size (pascal_symbol_node_header);
	if bp -> pascal_symbol_node_header.flags.name_next then i = i + size (pascal_name_next);
	if bp -> pascal_symbol_node_header.flags.base_type_info then i = i + size (pascal_base_type_info);
	if bp -> pascal_symbol_node_header.flags.address then i = i + size (pascal_address);
	if bp -> pascal_symbol_node_header.flags.father_brother then i = i + size (pascal_father_brother);
	if bp -> pascal_symbol_node_header.flags.son_level then i = i + size (pascal_son_level);
	if bp -> pascal_symbol_node_header.flags.father_type_successor then i = i + size (pascal_father_type_successor);
	if bp -> pascal_symbol_node_header.flags.size then i = i + size (pascal_size);
	if bp -> pascal_symbol_node_header.flags.offset then i = i + size (pascal_offset);
	if bp -> pascal_symbol_node_header.flags.subrange_limits then i = i + size (pascal_subrange_limits);
	if bp -> pascal_symbol_node_header.array_info then do;
		nd = addrel (bp, i) -> pascal_array_info.ndims;
		i = i + size (addrel (bp, i) -> pascal_array_info);
	     end;
	work = addrel (bp, i);
	n_variants,
	     variant_info.number_of_variants = work -> pascal_variant_info.number_of_variants;
	variant_info.first_value_in_set = work -> pascal_variant_info.first_value_in_set;
	do i = 1 to n_variants;
	     if work -> pascal_variant_info.case (i).set_offset ^= 0 then
		variant_info.case (i).set_addr = addrel (bp, work -> pascal_variant_info.case (i).set_offset);
	     else
		variant_info.case (i).set_addr = null;
	     if work -> pascal_variant_info.case (i).brother ^= 0 then
		variant_info.case (i).brother_addr = addrel (bp, work -> pascal_variant_info.case (i).brother);
	     else
		variant_info.case (i).brother_addr = null;
	end;
	return;
%page;
is_encoded: proc (value) returns (bit (1));

	dcl     value		 fixed bin (35);

	if addr (value) -> encoded_value.flag = "10"b then do;
		addr (value) -> encoded_value.flag = "00"b;
		return ("1"b);
	     end;
	else return ("0"b);

     end is_encoded;
%page;
%include runtime_symbol_info_;
%page;
%include runtime_symbol;
%page;
%include pascal_symbol_node;


     end runtime_symbol_info_;



		    stack_frame_exit_.pl1           11/05/86  1218.8r w 11/04/86  1033.8       51093


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

stack_frame_exit_:	proc(a_sp, mcptr, wcptr, co_flag, last_ptr, op_name, sitp);

/* This procedure  returns the address of the most recent location executed
   by the owner of the given stack frame.  The method is somewhat heuristic so a bit structure
   is returned indicating what the program thinks the situation is */
/* coded by M. Weaver 27 June 1973 */
/* modified by J.M. Broughton 26 June 1975 to handle being block entries */
/* Changed to copy stack_frame.return_ptr through RETURN_PTR_MASK 03/07/84 S. Herbst */


declare	(a_sp, mcptr, wcptr, last_ptr, callp, p, sitp) ptr;

declare	code fixed bin(35);

declare	op_name char(32) aligned;

declare	frame_flag bit(1) aligned;
declare	co_flag bit(1) unaligned;
declare	based_bit bit(36) aligned based;
declare	nsp pointer;
declare	i fixed bin;
declare	begin_block_entries (2) bit(36) aligned initial
	     (	"000000000110001100010111010001000000"b,  /* tsp2 pr0|614 */
		"000000001011111110010111010001000000"b   /* tsp2 pr0|1376 */   );

declare	(addr, addrel, bin, baseno, baseptr, fixed, hbound, null, ptr, rel, string, substr, unspec) builtin;
declare	interpret_op_ptr_ entry(ptr, ptr, ptr, char(32) aligned, bit(1) aligned);
declare	legal_f_ entry(ptr, fixed bin(35));
declare	compare_offsets_ entry(ptr, fixed bin(18), fixed bin(18), bit(1) aligned);

declare	1 situation aligned based(sitp),			/* describes what was found */
	  2 bad_frame bit(1) unal,
	  2 exists_ppr bit(1) unal,
	  2 ppr_is_owner bit(1) unal,
	  2 ppr_is_ops bit(1) unal,
	  2 caller_is_owner bit(1) unal,
	  2 entry_ptr_invalid bit(1) unal,
	  2 ret_ptr_is_ops bit(1) unal,
	  2 called_begin_block bit(1) unal,
	  2 pad bit(28) unal;

%include mc;

/**/
%include stack_frame;

%include stack_header;

/**/

%include its;
/**/
	last_ptr = null;
	op_name = " ";
	string (sitp -> situation) = (36)"0"b;			/* initialize all situation flags */

	/* see if we have a real stack frame */

	call legal_f_(a_sp, code);
	if code ^= 0 then do;			/* don't have a real frame */
	     bad_frame = "1"b;
	     return;
	end;

	sp = a_sp;

	/* find out if we have mc to look at */


	if (sp -> stack_frame.entry_ptr = null)
	| (addr(sp -> stack_frame.entry_ptr) -> its.its_mod ^= "100011"b)
	     then entry_ptr_invalid = "1"b;		/* want this to be set first */

	if co_flag then if wcptr ^= null then mcp = wcptr;	/* had left this ring with a fault */
		else mcp = null;			/* any mc for crawlout are for lower ring */
	else mcp = mcptr;
	if mcp = null then go to use_ret_ptr;		/* no mc to look at */
	else exists_ppr = "1"b;

	/* we do; see if ppr is pl1_operators_ */

	scup = addr(mcp -> mc.scu(0));

	p = ptr(baseptr(bin(bin(scup -> scu.ppr.psr, 15), 18)), scup -> scu.ilc);
						/* pick up ppr */

	call interpret_op_ptr_(mcp, sp, last_ptr, op_name, frame_flag);

	if last_ptr ^= null then do;			/* ppr was pl1 ops */
	     ppr_is_ops = "1"b;
	     if ^frame_flag then go to use_ret_ptr;	/* but it's not related to this frame */
	     caller_is_owner = "1"b;			/* ppr is related to this frame */
	     return;
	end;

	/* ppr ^= pl1_ops; see if it is owner of frame */

	if ^frame_flag then go to use_ret_ptr;		/* sp in mc doesn't match a_sp */

	if ^entry_ptr_invalid then do;
	     /* if we have an entry ptr, assume it points to owner */
	     if baseno(p) = baseno(sp -> stack_frame.entry_ptr)
	     then do;				/* same seg; see if same component */
		call compare_offsets_(ptr(p,0), bin(rel(p), 18), bin(rel(entry_ptr), 18),
		     frame_flag);
		if frame_flag then do;		/* is then same component */
		     ppr_is_owner = "1"b;
		     last_ptr = p;
		     return;
		end;
	     end;
	     go to use_ret_ptr;			/* ppr is not frame's owner */
	end;

	last_ptr = p;				/* can't tell; assume ppr is owner */
	return;


use_ret_ptr:	/* we're pretty sure that ret ptr accurately reflects the most recent use of the frame */


	/* When a begin block is entered, it does not set the return pointer. So if the
	   next frame belongs to a begin block, the return pointer will not reflect the
	   location at which the frame was exited. What we want is the last location
	   before the begin block. */

	nsp = ptr (sp, rel (sp -> stack_frame.next_sp));
	if (nsp -> stack_frame.entry_ptr ^= null) & (addr (nsp -> stack_frame.entry_ptr) -> its.its_mod = "100011"b)
	     then do i = 1 to hbound (begin_block_entries, 1);
		if addrel (nsp -> stack_frame.entry_ptr, 1) -> based_bit = begin_block_entries(i)
		     then do;
			called_begin_block = "1"b;
			ret_ptr_is_ops = "0"b;
			last_ptr = addrel (nsp -> stack_frame.entry_ptr, -1);
			return;
		     end;
	     end;

	call interpret_op_ptr_(null, sp, last_ptr, op_name, frame_flag);

	if last_ptr = null then do;				/* ptr can be used as id */
	     if addr(sp -> stack_frame.return_ptr) -> its.its_mod ^= "100011"b then do; /* not a ptr */
		if ^entry_ptr_invalid then last_ptr = sp -> stack_frame.entry_ptr;
		else last_ptr = null;			/* have no clue */
	     end;
	     else do;
		unspec (last_ptr) = unspec (sp -> stack_frame.return_ptr) & RETURN_PTR_MASK;
		if rel(last_ptr) ^= "0"b
		then last_ptr = addrel(last_ptr, -1);
	     end;
	end;

	else ret_ptr_is_ops = "1"b;			/* use caller of pl1 ops */


	return;

	end stack_frame_exit_;
   



		    valid_decimal_.pl1              11/11/86  1100.8rew 11/11/86  0909.7       51885


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

valid_decimal_: proc (P_dtype, P_dptr, P_prec) returns (bit (1));

/*  My contract: you give me the true dtype and precision of decimal data, and its address
   I will return true if  the data is completly valid for EIS use

   design and code by JRDavis Aug 78
   modified 12 Apr 79 to do 4bit decimal right, and use data_type_info_
   modified 31 Jan 84 by R. Gray to support generic types

*/

	dcl     (P_dtype		 fixed bin,	/* data type  of data */
	        P_dptr		 ptr,		/* to data to test */
	        P_prec		 fixed bin) parameter; /* declared precision of data */

	dcl     prec		 fixed bin init (P_prec), /* copy arg for efficiency */
	        dtype		 fixed bin init (P_dtype), /* ditto */
	        dptr		 ptr init (P_dptr), /* likewise */
	        sign_index		 fixed bin,	/* which char is sign char */
	        digit_index,			/* which is first of digits */
	        imag_index		 fixed bin,	/* where imag component begins */
	        data_char		 char (122) based (dptr), /* overlay for data */
	        (YES		 init ("1"b), NO init ("0"b)) bit (1) static options (constant);

	dcl     1 atr		 aligned like data_type_info_$info based (atrp); /* the atributes of our data type */
	dcl     atrp		 ptr;

	dcl     (abs, addr, lbound, hbound, substr, verify, index) builtin;

	dcl     validate_4bit_decimal_$sign entry (ptr, fixed bin) returns (bit (1) aligned),
	        validate_4bit_decimal_$digits entry (ptr, fixed bin, fixed bin) returns (bit (1) aligned);


	if prec < 0 | prec > data_type_info_$max_decimal_precision then return (NO);
	if dtype < 1 | dtype > hbound (data_type_info_$info, 1) then return (NO);

	atrp = addr (data_type_info_$info (dtype));	/* set up atr for convenience */

	if ^atr.computational | ^atr.arithmetic | ^atr.decimal /* not dec? yechh */
	then return (NO);

	if atr.packed_dec				/* 4bit decimal */
	then do;
		if atr.signed
		then do;
			if atr.trailing_sign
			then do;
				sign_index = prec;	/* is offset, not index per se */
				digit_index = 0;
			     end;
			else do;			/* leading sign, more familiar */
				sign_index = 0;
				digit_index = 1;
			     end;

			if ^validate_4bit_decimal_$sign (dptr, sign_index) then return (NO);
		     end;				/* signed */
		else digit_index = 0;

		if ^validate_4bit_decimal_$digits (dptr, digit_index, prec) then return (NO);

		if atr.complex then do;
			imag_index = prec + 1;
			if ^atr.fixed
			then imag_index = imag_index + 2; /* for exponent */
			if ^atr.digit_aligned	/* is byte aligned, may need pad */
			then if mod (imag_index, 2) = 1
			     then imag_index = imag_index + 1;

			if atr.overpunched
			then return (NO);		/* how did you get past the door? */
			else if ^validate_4bit_decimal_$sign (dptr, imag_index + sign_index) then return (NO);

			if ^validate_4bit_decimal_$digits (dptr, imag_index + digit_index, prec) then return (NO);
		     end;				/* testing imag part */


		return (YES);
	     end;					/* packed dec testing */

	else do;					/* 9bit decimal */

		if atr.signed
		then do;
			if atr.overpunched
			then do;
				if atr.trailing_sign
				then do;
					sign_index = prec;
					digit_index = 1;
				     end;
				else do;
					sign_index = 1;
					digit_index = 2;
				     end;

				if ^nine_bit_overpunched_sign_ok (substr (data_char, sign_index, 1)) then return (NO);
				if ^nine_bit_digit_ok (substr (data_char, digit_index, prec - 1)) then return (NO);

				if atr.complex	/* no idea how to validate this */
				then return (NO);
				return (YES);
			     end;			/* overpunched */
			else do;			/* regular signed 9 bit */
				if atr.generic
				then do;
					sign_index = 5;
					digit_index = 6;
				     end;
				else if atr.trailing_sign
				then do;
					sign_index = prec + 1;
					digit_index = 1;
				     end;
				else do;
					sign_index = 1;
					digit_index = 2;
				     end;

				if ^nine_bit_sign_ok (substr (data_char, sign_index, 1)) then return (NO);
			     end;			/* non-overpunched signed 9bit */
		     end;				/* signed */
		else digit_index = 1;		/* unsigned */

		if ^nine_bit_digit_ok (substr (data_char, digit_index, prec)) then return (NO);

		if atr.complex then do;
			imag_index = prec + 1;
			if atr.generic then imag_index = 4 * ceil(imag_index/4e0) +4; /* skip exponent word align */
			if ^atr.fixed then imag_index = imag_index + 1; /* skip exponent */
			if ^nine_bit_sign_ok (substr (data_char, imag_index + sign_index, 1)) then return (NO);

			if ^nine_bit_digit_ok (substr (data_char, imag_index + digit_index, prec)) then return (NO);
		     end;				/* checking imag part */

		return (YES);
	     end;					/* 9 bit decimal */

	return (NO);				/* should never get here */


nine_bit_sign_ok: proc (ch) returns (bit (1));
	dcl     ch		 char (1);
	return (index (data_type_info_$ninebit_sign_chars, ch) ^= 0); /* sign must be one of these */
     end nine_bit_sign_ok;

nine_bit_digit_ok: proc (chs) returns (bit (1));
	dcl     chs		 char (*);
	return (verify (chs, data_type_info_$ninebit_digit_chars) = 0); /* must all be valid digits */
     end nine_bit_digit_ok;

nine_bit_overpunched_sign_ok: proc (ch) returns (bit (1));
	dcl     ch		 char (1);
	return (index (data_type_info_$ninebit_overpunched_sign_chars, ch) ^= 0);
     end nine_bit_overpunched_sign_ok;
%include data_type_info_;

     end /* valid_decimal_ */;
   



		    validate_4bit_decimal_.alm      04/07/83  1606.7rew 04/07/83  1051.6       15669


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

" Program to assist valid_decimal_....
" Written 780815 by PG and JRD.
"
	name	validate_4bit_decimal_
	segdef	sign
	segdef	digits
"
	equ	value_ptr,2
	equ	sign_offset,4
	equ	sign_result,6
"
" Entry: validate_4bit_decimal_$sign (value_ptr, sign_offset) returns (bit (1) aligned);
"
sign:
	epp2	ap|value_ptr,*   		pr2 -> arg1
	epp2	pr2|0,*  			pr2 -> data
	lxl1	ap|sign_offset,*
	epp3	ap|sign_result,*    	pr3 -> place to return bit 
	cmpc	(pr,x1),(),fill(12)		first sign is 12(8)
	desc4a	pr2|0,1
	zero
	tnc	fail			char < 12, i.e. not a sign char
	cmpc 	(pr,x1),(),fill(17)		last sign is 17(8)
	desc4a	pr2|0,1
	zero
	tze	ok   			-17 is OK
	tnc	ok   			<17 is OK, too
"
fail:
	stz	pr3|0   			return ("0"b)
	short_return
"
ok:
	lda	=o400000,du
	sta	pr3|0   return ("1"b)
	short_return
"
" Entry: validate_4bit_decimal_$digits (value_ptr, digits_offset, digits_length) returns (bit (1) aligned);
"
	equ	digits_offset,4
	equ	digits_length,6
	equ	digits_result,8
"
digits:
	epp2	ap|value_ptr,*
	epp2	pr2|0,*
	lxl1	ap|digits_offset,*
	lxl2	ap|digits_length,*
	epp3	ap|digits_result,*
	tct	(pr,rl,x1)
	desc4a	pr2|0,x2
	arg	table
	arg	pr3|0			use return value as a temp!
	ttn	ok
	tra	fail
"
table:
	vfd	9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/1,9/1
	vfd	9/1,9/1,9/1,9/1
	end


		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved