



		    display_data_.pl1               11/11/88  1554.4rew 11/11/88  1541.2      764541



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(88-05-20,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Modified code in the internal procedure 'set_globals_for_probe' to allow
     more than one level of indirection to be printed. Modified the internal
     procedure 'get_symbol_name' to return a null string if the first character
     in the name is a !.  Modified the internal procedure 'do_symbol_and_sons'
     to print a single value if the 'son_ptr' is not null, the symbol type is
     pointer and the language is C.
  2) change(88-05-20,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Changed code in the internal proc 'set_globals_for_probe' to allow
     various levels of C_INDIRECTION to be printed. Changed code in the
     internal proc 'do_symbol_and_sons' to print only one symbol if:
       A) the 'son_ptr' is not null,
       B) the symbol type is pointer and
       C) the language is C.
     Modified the internal proc 'get_symbol_name' to strip off any leading
     underscores in the symbol name.
  3) change(88-05-27,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added code to test the reference node field 'subscript_ptr' for a
     null value. This pointer is set to null when the reference node
     represents the result of the & operator in C.
  4) change(88-06-01,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Changed 'get_string_info' to get the number of characters to be printed.
     The length is determined by the character offset of the first null
     character relative to the address supplied. If a null is not encountered
     within the first 256 characters, 256 is used.
  5) change(88-07-20,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Modified 'get_value_info' to compute the offset of a structure element
     and add it to the base address.
  6) change(88-07-20,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     The 'globals.calculate_address' value is always set to "0"b in
     'set_globals_for_probe'.
  7) change(88-08-15,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added code in 'get_value_info' to compute and add the offset of each array
     element for symbols occuring within structures or unions but being
     printed individually.
  8) change(88-08-26,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added enum type support by including the procedure 'display_c_enum'.
  9) change(88-08-26,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added support for subranges of aggregates.
 10) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
 11) change(88-10-28,WAAnderson), approve(88-10-28,MCR7952),
     audit(88-11-03,RWaters), install(88-11-11,MR12.2-1210):
     Added code to evaluate character pointers as decribed in the MTB.
     
     Consider the following declaration:
     
      char *ptr;
     
     The following are possilbe references to the pointer 'ptr' and the
     manner in which the reference is interpreted by probe:
     
     *ptr      - refers to a single character at the address specified
                 by the contents of 'ptr'.
      ptr      - refers to the address in 'ptr'.
      ptr[]    - refers to the contiguous series of characters beginning
                 with the character specified by the address in 'ptr'
                 and ending with the first occurence of a null.
      ptr[N]   - refers to the single character whose address is computed
                 by taking the contents of 'ptr' and adding N bytes to that
                 address.
      ptr[N:M] - refers to the characters from ptr+N to ptr+M where
                 N and M are byte offsets.
 12) change(88-10-28,WAAnderson), approve(88-10-28,MCR7952),
     audit(88-11-03,RWaters), install(88-11-11,MR12.2-1210):
     Took the code immediately following the 'for_probe' entrypoint and made it
     an internal procedure.  Now the 'for_azm' and 'for_probe' entrypoints both
     call this procedure. The 'for_azm' entrypoint passes a flag that indicates
     the only action to take is initialize the variables referenced throughout
     display_data_.  The new procedure is called 'common_c_setup'.
                                                   END HISTORY COMMENTS */

/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

display_data_:
  proc ();

  return;

  /* *	DISPLAY_DATA_ -- Display data according to runtime symbol table info.
   *	  $FOR_PROBE  -- Display all Multics language datatypes, for use by 
   *                       probe.
   *	  $FOR_AZM    -- Display PL/I datatypes, for use by analyze_multics,
   *		       providing specialized interpretations as 
   *                       appropriate.
   *
   *      Modification history:
   *	04 Mar 85, Steve Herbst: 
   *         Fixed some string-formatting bugs and reinstated printing fb>52 as
   *	   dtm for azm.
   *	27 Feb 85, Steve Herbst:
   *         Fixed to print null string as "".
   *	29 Nov 84, Steve Herbst:
   *	   Fixed to handle "size" by skipping to next structure element.
   *	16 Jul 84, S. Herbst: 
   *	   Fixed $for_azm to set global.azm_info_ptr from input arg
   *	   (ala azm_display_data_).
   *	24 Jun 84, B. Braun: 
   *	   Fixed bug incorrectly reporting the base addr of a substructure.
   *	21 May 84, S. Herbst: 
   *	   "modes truncate_strings", do truncation & trimming to all lang
   *	   strings.
   *	09 Feb 84, S. Herbst:
   *	   Changed to handle hexfp, extended, generic types.
   *	02 Nov 83, S. Herbst: 
   *	   Fixed bug that reversed array indices while printing.
   *	11 Oct 83, S. Herbst:
   *	   Changed algorithm for printing duplicate array elements -
   *	   "A (n) and/through A (m) = value"
   *	06 Oct 83, S. Herbst:
   *         Added version strings to runtime_symbol_info_ structures.
   *      14 Aug 83, WOS:
   *         Retrofitted Pascal changes into display_data_. Required fixing
   *	   all places where "constant" symbols might be referenced to check
   *	   for value_symbol_ptr = null.
   *      03 Aug 83, WOS:
   *	   Renamed entypoints to display_data_$for_probe, $for_azm.
   *      20 Jun 83, J. M. Athane: 
   *	   Modified for Pascal (as probe_print_value_).  Calls
   *	   probe_print_pascal_$value for typical Pascal values.  Uses
   *	   runtime_symbol_info_ subroutine instead of runtime_symbol 
   *	   structure.
   *	11 Jun 83, WOS: 
   *	   Added "apropos" feature (matching names)
   *      10 Jun 83, WOS: 
   *	   Added bit(1) summary output for azm, fixed integers to display
   *	   with full precision, added clock heuristic for azm and long
   *	   integers.
   *      09 Jun 83, WOS: 
   *	   Added compact output mode for azm.
   *	04 Jun 83, WOS: 
   *	   Added duplicate suppression for arrays.
   *      02 Jun 83, WOS: 
   *	   Merged constant printing back into main line so constants could
   *	   be printed using the usual heuristics.
   *	01 Jun 83, WOS: 
   *         Clever (octal/hex) bitstring printer.
   *	31 May 83, WOS: 
   *	   Converted to display_data_ for analyze_multics.
   *      01 Jan 83, S. Herbst: 
   *	   Limit string printout to 200 characters.
   * 	27 Jul 82, S. Herbst: 
   *	   Diagnose zero extent arrays.
   *	26 Apr 82, S. Herbst: 
   *	   Display strings properly for Fortran (using " or ').
   *	17 Dec 81, S. Herbst: 
   *	   Check for overlength (out of bounds) string lengths.
   * 	28 Sep 81, S. Herbst:
   *	   Diagnose invalid refer extents (<= 0).
   *      09 Sep 81, S. Herbst: 
   *	   Print formerly inhibited subscripts for non-top-level structure
   *	   references.
   * 	24 Aug 81, Steve Herbst:
   *	   Requote character strings, fix bugs.
   * 	31 Jul 81, Melanie B. Weaver:
   *	   Print names of algol68 data types.
   *      15 Sep 79, JRD:
   *	   Treat constants differently from symbols, COBOL fixes, allow
   *         negative scale factor.
   *	12 Jul 79, JRD: 
   *	   For 4.2 probe.
   *      01 Jun 79, JRD: 
   *	   Abbreviate [pd] for pointers.
   *      08 Mar 79, JRD: 
   *	   Remember that precision of strings may exceed 16383.
   * 	12 Jan 79, JRD: 
   *	   First real probe version.
   *      22 Sep 78, James R. Davis:
   *	   Initial coding.
   */

  dcl P_iocb_ptr		parameter pointer;
  dcl P_display_format	parameter bit (*) aligned;
  dcl P_match_names		(*) parameter char (*) varying;
  dcl P_match_name_count	parameter fixed bin;
  dcl P_amu_info_ptr	parameter pointer;
  dcl P_data_ptr		parameter pointer;
  dcl P_data_size		parameter fixed bin (18);
  dcl P_start_ptr		parameter pointer;
  dcl P_symbol_ptr		parameter pointer;
  dcl P_subscripts		(2, *) parameter fixed bin (24);
  dcl P_n_subscripts	parameter fixed bin;
  dcl P_code		parameter fixed bin (35);
  dcl P_probe_info_ptr	parameter pointer;
  dcl 1 P_reference		parameter aligned like reference_node;

  dcl STRING_LIMIT		fixed bin internal static
			options (constant) init (200);
  dcl MINIMUM_TRIM		fixed bin internal static
			options (constant) init (20);

  dcl 1 global		aligned automatic,
				/* Global info for internal procedures */
       2 output_info	aligned,	/* Info about output format */
        3 output_switch	pointer init (null ()),
				/* Switch for printing */
        3 line_length	fixed bin init (72),
				/* max length of output lines */
        3 short_names	bit (1) aligned init ("0"b),
				/* whether to print names in short form or long form */
        3 compress_output	bit (1) aligned init ("0"b),
				/* whether to collect bits, put multiple things on a line */
        3 use_match_names	bit (1) aligned init ("0"b),
				/* whether to pay attention to P_match_names */

       2 amu_info_ptr	pointer init (null ()),
				/* name/address translation info for $for_azm */
       2 orig_symbolp	pointer init (null ()),
				/* pointer to original symbol node */
       2 blockp		pointer init (null ()),
				/* block symbol was dcl 'd in */

       2 base_ptr		pointer init (null ()),
				/*  the original address of the data */
       2 max_offset		fixed bin (18) init (262143),
				/* Maximum offset allowed for data */
       2 start_ptr		pointer init (null ()),
				/* The alleged address where the display started */
       2 n_orig_indices	fixed bin,/* Number of original indices we were given */

       2 stackp		pointer init (null ()),
				/* to the stack frame for this variable */
       2 linkp		pointer init (null ()),
				/* to the Linkage section */

       2 probe_options	aligned,	/* Things used only by probe */
        3 language_type	fixed bin init (PL1_lang_type),
				/* language type for deciding how to print things */
        3 probe_sw		bit (1) aligned init ("0"b),
				/* "1"b => probe_print_value_ */
        3 octal_sw		bit (1) aligned init ("0"b),
				/* if we print in octal */
        3 invert_sw		bit (1) aligned init ("0"b),
				/* FORTRAN arrays are backwards */
        3 calculate_address	bit (1) aligned init ("0"b),
				/* used to decide to print name */
        3 truncate_strings	bit (1) aligned init ("0"b),
				/* probe "mode truncate_strings" */
        3 print_names	bit (1) aligned init ("0"b),
				/* whether to print symbol names */
        3 no_handle_faults_sw bit (1) aligned init ("0"b),
				/* whether to allow "size" to be signalled */

       2 variable_info	aligned,	/* Things which vary as we traverse structures and arrays */
        3 n_bounds		fixed bin,/* Number of total array bounds in use */
        3 bounds		(2, 16) fixed bin (24),
				/* Current array bounds */
        3 indices		(16) fixed bin (24),
				/* full subscripts needed to get address */

        3 father		(64) pointer;
				/* to symbol node for every level of a structure */

  dcl 1 output_info_template	aligned internal static options (constant),
				/* Information about output buffering */
       2 header		aligned,
        3 on_bits,			/* pointers to the lsits of bit names */
         4 first		pointer init (null ()),
				/* for printing when we've finished */
         4 last		pointer init (null ()),
        3 off_bits,
         4 first		pointer init (null ()),
         4 last		pointer init (null ()),

       2 buffer		char (300) varying init ("");
				/* The actual buffer */

  dcl dont_print_me_this_time bit (1);

  dcl 1 bit_buffer		aligned based,
				/* Structure used when accumulating bits */
       2 str		char (300) varying,
       2 next		pointer;

  dcl 1 global_output_info	aligned like output_info_template automatic;

  dcl error_code		fixed bin (35);
				/* global error code */
  dcl done_with_pascal	bit (1);	/* return value from probe_print_pascal_$value */
  dcl level_1_c_struct_ndims	fixed bin;
  dcl level_1_c_struct_dims_ptr
			ptr;
  dcl print_the_data	bit (1);
  dcl double_override	bit (1);

  dcl system_area_ptr	pointer;
  dcl system_area		area aligned based (system_area_ptr);

  dcl probe_et_$dim_limit	fixed bin (35) external static;
  dcl probe_et_$recorded_message
			fixed bin (35) external static;
  dcl probe_et_$no_address	fixed bin (35) external static;

  dcl iox_$user_output	pointer external static;
  dcl sys_info$max_seg_size	fixed bin (19) external static;

  dcl probe_error_$record	entry options (variable);
  dcl get_size_in_bits_	entry (fixed bin, fixed bin (35),
			bit (1) aligned) returns (fixed bin);
  dcl probe_increment_indices_
			entry (bit (1) aligned, (*) fixed bin (24),
			(2, *) fixed bin (24), fixed bin,
			bit (1) aligned, bit (1) aligned);
  dcl probe_modes_mgr_$excludep
			entry (pointer, pointer)
			returns (bit (1) aligned);
  dcl probe_print_pascal_$value
			entry (pointer, pointer, fixed bin (35),
			bit (1));

  dcl assign_$computational_	entry (ptr, ptr, fixed bin (35));
  dcl convert_status_code_	entry (fixed bin (35), char (8) aligned,
			char (100) aligned);
  dcl date_time_$format	entry (char (*), fixed bin (71), char (*),
			char (*)) returns (char (250) var);
  dcl display_file_value_	entry (pointer, file, fixed bin (35));
  dcl format_pointer_$its	entry (pointer, bit (1) aligned, pointer)
			returns (char (256) varying);
  dcl format_pointer_$packed	entry (unaligned pointer, bit (1) aligned,
			pointer) returns (char (256) varying);
  dcl get_line_length_$switch entry (pointer, fixed bin (35))
			returns (fixed bin);
  dcl get_system_free_area_	entry () returns (pointer);
  dcl ioa_$ioa_switch	entry options (variable);
  dcl ioa_$ioa_switch_nnl	entry options (variable);
  dcl ioa_$rsnnl		entry options (variable);
  dcl requote_string_	entry (char (*)) returns (char (*));
  dcl stu_$block_dcld_in	entry (pointer) returns (pointer);
  dcl stu_$decode_runtime_value_extended
			entry (fixed bin (35),
			pointer, pointer, pointer, pointer, pointer,
			pointer, fixed bin (35))
			returns (fixed bin (35));
  dcl stu_$get_runtime_address
			entry (pointer, pointer,
			pointer, pointer, pointer, pointer, pointer)
			returns (pointer);
  dcl stu_$offset_to_pointer	entry (pointer, pointer,
			pointer, pointer, pointer, pointer)
			returns (pointer);
  dcl stu_$find_runtime_symbol
			entry (ptr, char (*) aligned, ptr, fixed bin)
			returns (pointer);
  dcl valid_decimal_	entry (fixed bin, pointer, fixed bin (35))
			returns (bit (1) aligned);

  dcl TOP_LEVEL		bit (1) aligned internal static
			options (constant) init ("1"b);
  dcl NOT_TOP_LEVEL		bit (1) aligned internal static
			options (constant) init ("0"b);

  dcl (addr, addrel, binary, character, clock, convert, copy, divide, high)
			builtin;
  dcl (hbound, fixed, index, length, low, ltrim, max, maxlength, min, mod)
			builtin;
  dcl (null, nullo, pointer, rel, rtrim, substr, translate, unspec)
			builtin;

  dcl (conversion, overflow, sub_error_)
			condition;


%page;
common_c_setup:
  proc (azm_entry);

  dcl azm_entry		bit (1);
  dcl temp_stuff_ptr	ptr;

  double_override = "0"b;

  if P_code = 1 | P_reference.flags.c_sub_c_ptr then do;
      print_the_data = "1"b;
      double_override = "1"b;
      P_code = 0;
    end;
    else print_the_data = "0"b;

  level_1_c_struct_ndims = 0;
  level_1_c_struct_dims_ptr = null ();

  if (azm_entry | P_probe_info_ptr->probe_info.language_type ^= C_lang_type)
    then return;

  if (P_reference.symbol_ptr ^= null ()) then do;
      temp_stuff_ptr = P_reference.symbol_ptr;
      do while (fixed (temp_stuff_ptr -> runtime_symbol.type) = pointer_dtype
	 |
	 fixed (temp_stuff_ptr -> runtime_symbol.type) = c_typeref_dtype);
        temp_stuff_ptr =
	   addrel (temp_stuff_ptr,
	   fixed (temp_stuff_ptr -> runtime_symbol.son));
      end;
      if fixed (temp_stuff_ptr -> runtime_symbol.type) = structure_dtype |
	 fixed (temp_stuff_ptr -> runtime_symbol.type) = c_union_dtype
        then
	   double_override = "1"b;
      if ((fixed (P_reference.symbol_ptr -> runtime_symbol.type)
	 = structure_dtype |
	 fixed (P_reference.symbol_ptr -> runtime_symbol.type)
	 = c_union_dtype) &
	 P_probe_info_ptr -> probe_info.language_type = C_lang_type &
	 P_reference.n_subscripts = 0) then do;

	begin;

	  dcl nameptr		ptr;
	  dcl steps		fixed bin;
	  dcl found_ptr		ptr;
	  dcl t_ptr		ptr;

	  nameptr =
	       addrel (P_reference.symbol_ptr,
	       fixed (P_reference.symbol_ptr -> runtime_symbol.name));
	  if (P_reference.name
	       ^=
	       substr (nameptr -> acc.string, 1, nameptr -> acc.num_chars))
	    then do;
	      t_ptr =
		 stu_$find_runtime_symbol (P_reference.source_info_ptr
		 -> source_info.block_ptr, (P_reference.name), found_ptr,
		 steps);
	      if (t_ptr ^= null ())
	        then
		   if (^t_ptr -> runtime_symbol.bits.simple) then do;
		       level_1_c_struct_ndims =
			  convert (level_1_c_struct_ndims,
			  t_ptr -> runtime_symbol.ndims);
		       level_1_c_struct_dims_ptr = t_ptr;
		     end;
	    end;
	end;
        end;
    end;

  end common_c_setup;
%page;
display_data_$for_azm:
  entry (P_iocb_ptr, P_display_format, P_match_names, P_match_name_count,
       P_amu_info_ptr,
       P_data_ptr, P_data_size, P_start_ptr, P_symbol_ptr,
       P_subscripts, P_n_subscripts, P_code);

  call common_c_setup ("1"b);		/* "0"b for probe, "1"b for azm */
  call set_globals_for_azm ();
  goto COMMON;



display_data_$for_probe:
  entry (P_probe_info_ptr, P_reference, P_code);

  call common_c_setup ("0"b);		/* "0"b for probe, "1"b for azm */
  call set_globals_for_probe ();

  if (probe_info.language_type = PASCAL_lang_type) then do;
      call probe_print_pascal_$value (probe_info_ptr, addr (P_reference),
	 P_code, done_with_pascal);
      if done_with_pascal
        then return;		/* Otherwise, fall through and do our usual thing */
    end;

  goto COMMON;


COMMON:
  system_area_ptr = get_system_free_area_ ();

  global.line_length = get_line_length_$switch (global.output_switch, (0));

  global_output_info.header = output_info_template.header;
  global_output_info.buffer = copy (" ", 2);

  dont_print_me_this_time = "0"b;

  if (level_1_c_struct_ndims > 0) then do;
      begin;

        dcl inxs		      (level_1_c_struct_ndims) fixed bin;
        dcl (level_1_c_struct_inx0, level_1_c_struct_inx1,
	  level_1_c_struct_inx2)
			      fixed bin;
        dcl total_number_of_elements
			      fixed bin;

        inxs (*) = 0;
        total_number_of_elements = 0;
        do level_1_c_struct_inx0 = 1 to level_1_c_struct_ndims;
	total_number_of_elements =
	     total_number_of_elements
	     + level_1_c_struct_dims_ptr
	     -> runtime_symbol.bounds (level_1_c_struct_inx0).upper + 1;
        end;

        P_reference.address_ptr =
	   addrel (P_reference.address_ptr, -1 *
	   divide (level_1_c_struct_dims_ptr
	   -> runtime_symbol.bounds (1).multiplier,
	   36, 17, 0));

        do level_1_c_struct_inx0 = 1 to total_number_of_elements;
	call ioa_$ioa_switch_nnl (probe_info.output_switch, "^/^a ",
	     P_reference.name);
	do level_1_c_struct_inx1 = 1 to level_1_c_struct_ndims;
	  call ioa_$ioa_switch_nnl (probe_info.output_switch, "[^d]",
	       inxs (level_1_c_struct_inx1));
	end;
	P_reference.address_ptr =
	     addrel (P_reference.address_ptr,
	     divide (level_1_c_struct_dims_ptr
	     -> runtime_symbol.bounds (1).multiplier,
	     36, 17, 0));

	dont_print_me_this_time = "1"b;

	call print_symbol (global.orig_symbolp,
	     global.n_orig_indices, TOP_LEVEL, addr (global_output_info),
	     (P_reference.address_ptr));

	inxs (level_1_c_struct_ndims) = inxs (level_1_c_struct_ndims) + 1;
	level_1_c_struct_inx2 = level_1_c_struct_ndims;
	do while (level_1_c_struct_inx2 > 0);
	  if inxs (level_1_c_struct_inx2)
	       > level_1_c_struct_dims_ptr
	       -> runtime_symbol.bounds (level_1_c_struct_inx2).upper
	    then do;
	      inxs (level_1_c_struct_inx2) = 0;
	      if (level_1_c_struct_inx2 > 1)
	        then
		   inxs (level_1_c_struct_inx2 - 1) =
		        inxs (level_1_c_struct_inx2 - 1) + 1;
	    end;
	  level_1_c_struct_inx2 = level_1_c_struct_inx2 - 1;
	end;
        end;
      end;
    end;

    else call print_symbol (global.orig_symbolp,
	    global.n_orig_indices, TOP_LEVEL, addr (global_output_info),
	    (P_reference.address_ptr));

  P_code = 0;
  return;


FATAL_ERROR:
  P_code = error_code;
  return;
%page;
set_globals_for_azm:
  proc ();


  dcl idx			fixed bin;


  global.output_switch = P_iocb_ptr;
  if (global.output_switch = null ())
    then global.output_switch = iox_$user_output;

  global.amu_info_ptr = P_amu_info_ptr;
  global.probe_sw = "0"b;
  global.octal_sw = "0"b;		/* azm never uses silly probe octal hack */
  global.invert_sw = "0"b;		/* azm always uses PL/I subscripts */

  global.base_ptr = P_data_ptr;
  global.max_offset = binary (rel (P_data_ptr), 18) + P_data_size - 1;
  global.start_ptr = P_start_ptr;

  global.language_type = PL1_lang_type;
  global.stackp = null ();		/* Can't use these, 'cause stu_ can't hack with amu_ */
  global.linkp = null ();

  global.blockp = stu_$block_dcld_in (P_symbol_ptr);
  global.orig_symbolp = P_symbol_ptr;

  global.calculate_address = "1"b;	/* Since we're always doing structures */
  global.truncate_strings = "0"b;
  global.print_names = "1"b;		/* Actually, we mimic probe "short" mode */
  global.short_names = "1"b;

  global.no_handle_faults_sw = "0"b;

  global.n_bounds = P_n_subscripts;
  global.n_orig_indices = P_n_subscripts;

  do idx = 1 to global.n_bounds;
    global.bounds (*, idx) = P_subscripts (*, idx);
    global.indices (idx) = global.bounds (1, idx);
  end;

  call set_display_format (1, global.compress_output);

  global.use_match_names = "0"b;
  if (hbound (P_match_names, 1) > 0) & (P_match_name_count > 0)
    then
         if (P_match_names (1) ^= "") then do;
	   global.use_match_names = "1"b;
	   global.short_names = "0"b;
	 end;
  return;

  end set_globals_for_azm;
%page;
set_display_format:
  proc (P_bit_idx, P_bit);


  dcl P_bit_idx		fixed bin parameter;
  dcl P_bit		bit (1) aligned parameter;

  if (P_bit_idx <= length (P_display_format))
    then
         P_bit = substr (P_display_format, P_bit_idx, 1);
    else P_bit = "0"b;
  return;

  end set_display_format;
%page;
set_globals_for_probe:
  proc ();


  dcl idx			fixed bin;

  dcl 1 ref_subscripts	aligned based (P_reference.subscript_ptr)
			like reference_subscripts;


  probe_info_ptr = P_probe_info_ptr;

  global.output_switch = probe_info.output_switch;

  global.probe_sw = "1"b;
  global.octal_sw = P_reference.flags.octal;
  global.blockp = P_reference.source_info_ptr -> source_info.block_ptr;

  if global.blockp ^= null
    then
         global.invert_sw = global.blockp -> runtime_block.fortran;
    else global.invert_sw = "0"b;	/* we wont have arrays, anyway, but be safe */

  global.stackp = P_reference.source_info_ptr -> source_info.stack_ptr;
  global.linkp =
       P_reference.source_info_ptr -> source_info.seg_info_ptr
       -> seg_info.linkage_ptr;

  global.base_ptr = P_reference.base_addr;
  global.max_offset = 262143;		/* We don't get told where it ends */
  global.start_ptr = global.base_ptr;
  global.orig_symbolp = P_reference.symbol_ptr;
  global.language_type = probe_info.language_type;

  if (global.orig_symbolp = null ())
    then /* For probe builtins, etc. */
         global.calculate_address = "0"b;
  else if P_reference.cross_section & probe_info.language_type ^= C_lang_type
    then
         global.calculate_address = "1"b;
  else if (P_reference.type = structure_dtype
       & probe_info.language_type ^= C_lang_type)
    then
         global.calculate_address = "1"b;
  else if ((P_reference.type = structure_dtype |
       P_reference.type = c_union_dtype) /* union */ &
       probe_info.language_type = C_lang_type)
    then
         global.calculate_address = "0"b;
  else if (runtime_symbol_info_$son (global.orig_symbolp) ^= null ()) &
       (probe_info.language_type ^= PASCAL_lang_type) &
       (probe_info.language_type ^= C_lang_type)
    then
         /* Don't chase the sons of pointers in C */
         global.calculate_address = "1"b;
				/* COBOL structure, probably */
  else global.calculate_address = "0"b;
  if P_reference.symbol_ptr = null ()
    then /* No symbol? Won't work, nohow */
         global.print_names = "0"b;
  else if P_reference.flags.constant
    then /* constants have no names */
         global.print_names = "0"b;
  else if (probe_modes.value_print = LONG_mode_type)
    then
         global.print_names = "1"b;	/* ALWAYS */
  else if (probe_modes.value_print = SHORT_mode_type)
    then
         global.print_names = global.calculate_address;
  else global.print_names = "0"b;	/* NEVER (brief mode) */

  global.truncate_strings = probe_modes.truncate_strings;
  if (probe_modes.qualification = BRIEF_mode_type)
    then
         global.short_names = "1"b;
  else if (probe_modes.qualification = SHORT_mode_type)
    then
         global.short_names = "1"b;
  else if (probe_info.language_type = COBOL_lang_type)
    then
         global.short_names = "1"b;	/* Always short for COBOL, though I have no idea why */
  else global.short_names = "0"b;

  global.use_match_names = "0"b;

  global.no_handle_faults_sw =
       probe_info.static_info_ptr -> probe_static_info.no_handle_faults_sw;

  if probe_info.language_type ^= PASCAL_lang_type
       & P_reference.subscript_ptr ^= null ()
    then
      do idx = 1 to ref_subscripts.number;
      if (P_reference.n_subscripts = 0)
	 & (ref_subscripts.value (2, idx) < ref_subscripts.value (1, idx))
        then
	   call ioa_$ioa_switch (global.output_switch,
	        "Warning: extent ^d is zero.", idx);
      global.indices (idx) = ref_subscripts.value (1, idx);
      global.bounds (1, idx) = ref_subscripts.value (1, idx);
      if ^P_reference.cross_section
        then /* Since only first subscript will be set in this case */
	   global.bounds (2, idx) = ref_subscripts.value (1, idx);
        else global.bounds (2, idx) = ref_subscripts.value (2, idx);
    end;

  if (P_reference.subscript_ptr ^= null ()) then do;
      global.n_bounds = ref_subscripts.number;
      global.n_orig_indices = ref_subscripts.number;
    end;
    else do;
      global.n_bounds = 0;
      global.n_orig_indices = 0;
    end;
  return;

  end set_globals_for_probe;
%page;
ref_node_not_struct_or_union:
  proc () returns (bit (1));
  dcl t_ptr		ptr;

  if (probe_info.language_type ^= C_lang_type)
    then return ("0"b);

  t_ptr = P_reference.symbol_ptr;
  if t_ptr = null
    then return ("0"b);

  do while (fixed (t_ptr -> runtime_symbol.type) = pointer_dtype |
       fixed (t_ptr -> runtime_symbol.type) = c_typeref_dtype);
    t_ptr = addrel (t_ptr, fixed (t_ptr -> runtime_symbol.son));
  end;
  if (fixed (t_ptr -> runtime_symbol.type) = structure_dtype)
    then return ("0"b);
  else if (fixed (t_ptr -> runtime_symbol.type) = c_union_dtype)
    then return ("0"b);
  return ("1"b);

  end ref_node_not_struct_or_union;
%page;
print_symbol:
  proc (P_value_symbol_ptr, P_inherited_dims, P_top_level_sw,
       P_output_info_ptr, inherited_addr);


  /* This is the interface to the actual data display routine.  We may be 
   printing a structure, in which case the necessary recursive tree walking 
   is here-in implemented.  This involves printing full cross-sections of
   any arrays we run into. */

  dcl P_value_symbol_ptr	pointer parameter;
				/* to runtime_symbol node */
  dcl P_inherited_dims	fixed bin parameter;
  dcl P_top_level_sw	bit (1) aligned parameter;
  dcl P_output_info_ptr	pointer parameter;
  dcl inherited_addr	pointer parameter;
  dcl 1 parent_output_info	aligned like output_info_template
			based (P_output_info_ptr);

  /* This is all global information about the value we're going to print; mostly,
   it gets inherited by display_single_value. */

  dcl (value_symbol_ptr, previous_value_symbol_ptr, this_value_symbol_ptr)
			pointer;
  dcl (value_ptr, previous_value_ptr, this_value_ptr)
			pointer;
  dcl 1 (value_info, previous_value_info, this_value_info)
			like runtime_type_info;
				/* NOTE: This must be dcld without explicit alignment */
  dcl 1 (value_data_info, previous_value_data_info, this_value_data_info)
			aligned like data_type_info_$info;
  dcl (previous_value_indices, this_value_indices)
			(16) fixed bin (24);
				/* copies of global.indices */
  dcl value_name		char (256) varying;
  dcl (previous_value_name, this_value_name, starting_name)
			char (256);
  dcl (previous_real_value_ptr, real_value_ptr)
			pointer;	/* If we're working on a copy, this is the real address */

  dcl ndims		fixed bin;/* total number of dims we have */
  dcl my_dims		fixed bin;/* how many dims we have originated */
  dcl first_dim		fixed bin;
  dcl my_bounds		(2, 16) fixed bin (24);
  dcl (ele_num, levels_of_pointer_indir)
			fixed bin;
  dcl my_father_is_a_typeref	bit (1);
  dcl override		bit (1);
  dcl my_real_name_ptr	ptr;

  /* This is a general-purpose buffer for collecting output. It's dcld here
   only in order to avoid having multiple copies of it in loads of internal 
   procedures. It should always be filled and written immediately. */

  dcl value_str		char (500) varying;
  dcl old_value_symbol_ptr	ptr;
  dcl fixed		builtin;

  ele_num = 0;
  my_father_is_a_typeref = "0"b;
  my_real_name_ptr = null ();
  value_symbol_ptr = P_value_symbol_ptr;

  /* First, check for probe constants. A probe constant is a value constructed
   by probe as the result of an expression. It has no symbol node associated
   with it (which is how we tell what it is), never has dimensions, and only
   uses a restricted set of datatypes. Thus, we catch it the first time here
   and just return. This is done here because display_single_value is quick, 
   and internal to print_symbol. This check is only made when the entrypoint
   for probe is called; otherwise, it is an error. */

  if global.probe_sw & (value_symbol_ptr = null ()) then do;
				/* Probe constant */
      call display_probe_constant ();
      return;			/* All done */
    end;

  if ^global.no_handle_faults_sw
    then
         on size
	 begin;			/* if "size" occurs, skip to next element */
	 call ioa_$ioa_switch (global.output_switch,
	      "Size condition occurred evaluating ^a",
	      get_unsubscripted_name ());
	 go to PRINT_SYMBOL_RETURN;
         end;

  call setup_subscripts ();

  levels_of_pointer_indir = 0;
  my_father_is_a_typeref = "0"b;
  my_real_name_ptr = null ();
  old_value_symbol_ptr = value_symbol_ptr;
  override = "0"b;
  do while ((fixed (value_symbol_ptr -> runtime_symbol.type) = pointer_dtype |
       fixed (value_symbol_ptr -> runtime_symbol.type) = c_typeref_dtype) &
       probe_info.language_type = C_lang_type);
    if (my_real_name_ptr = null ()) then do;
        my_real_name_ptr = value_symbol_ptr;
        my_father_is_a_typeref = "1"b;
      end;
    if (fixed (value_symbol_ptr -> runtime_symbol.type) = pointer_dtype)
      then
	 levels_of_pointer_indir = levels_of_pointer_indir + 1;
    value_symbol_ptr =
         addrel (value_symbol_ptr,
         fixed (value_symbol_ptr -> runtime_symbol.son));
    if (fixed (value_symbol_ptr -> runtime_symbol.type) = char_dtype
         & ^P_reference.flags.c_sub_c_ptr & ^double_override)
      then
	 override = "1"b;
  end;
  if (levels_of_pointer_indir > 0 & (^print_the_data | override)
       & probe_info.language_type = C_lang_type) then do;
      value_symbol_ptr = old_value_symbol_ptr;
      levels_of_pointer_indir = 0;
    end;

  override = "0"b;
  call print_cross_section ();

  if P_top_level_sw
    then /* If this is the end, finish it */
         call finish_output (addr (parent_output_info), "1"b);

PRINT_SYMBOL_RETURN:
  return;
%page;
setup_subscripts:
  proc ();


  dcl idx			fixed bin;/* do loop index only */
  dcl symbol_ptr		ptr;	/* pointer to symbol node */
  dcl my_idx		fixed bin;
  dcl symbol_level		fixed bin;
  dcl first_level		fixed bin;



  ndims = runtime_symbol_info_$array_dims (value_symbol_ptr);

  if (probe_info.language_type = C_lang_type & ndims = 0) then do;
      my_dims = 0;
      return;
    end;

  if (ndims > hbound (global.indices, 1)) then do;
				/* Too many dimensions to print successfully */
      error_code = probe_et_$dim_limit;
      goto FATAL_ERROR;
    end;

  if P_top_level_sw
    then /* Use any that we got from our caller */
         my_dims = ndims;		/* without disturbing those parts of global.bounds */
    else my_dims = ndims - P_inherited_dims;
				/* how many do we contribute */

  first_dim = ndims - my_dims + 1;	/* First one we manipulate */

  /* What follows here is a gross kludge, because runtime_array_info does not use refer extents properly,
   or even have its variable extent named reasonably. Instead, it is called n_dims, no doubt to the
   great confusion of all concerned. */

  n_dims = ndims;			/* Hope that scope-of-names works */

  begin;

    dcl 1 value_array_info	  like runtime_array_info;
				/* ADJUSTABLE AUTOMATIC */
				/* NOTE: This must be dcld without explicit alignment */

    value_array_info.version = RUNTIME_ARRAY_INFO_VERSION_1;

    call runtime_symbol_info_$array (value_symbol_ptr,
         addr (value_array_info), error_code);
    if error_code ^= 0
      then call cannot_get_address ();

    do idx = (P_inherited_dims + 1) to ndims;
				/* Fill in our own bounds */
      global.bounds (1, idx) = decode (value_array_info.bounds (idx).lower,
	 value_array_info.bounds (idx).lower_is_encoded);
      global.bounds (2, idx) = decode (value_array_info.bounds (idx).upper,
	 value_array_info.bounds (idx).upper_is_encoded);
      global.indices (idx) = global.bounds (1, idx);
    end;

  end;				/* Kludge begin block */

  my_idx = 1;			/* Copy the appropriate part of the global bounds */
  do idx = first_dim to ndims;	/* and index info into our local copies */
    my_bounds (*, my_idx) = global.bounds (*, idx);

    if (my_bounds (2, my_idx) < my_bounds (1, my_idx))
      then
	 call ioa_$ioa_switch (global.output_switch,
	      "Warning: extent ^d of ^a is zero.",
	      idx, get_unsubscripted_name ());
    my_idx = my_idx + 1;
  end;

  if P_top_level_sw
    then first_level = 1;
    else first_level = runtime_symbol_info_$level (value_symbol_ptr);
  symbol_level = max (1, runtime_symbol_info_$level (value_symbol_ptr));

  symbol_ptr = value_symbol_ptr;

  do idx = symbol_level to first_level by -1;
    global.father (idx) = symbol_ptr;
    symbol_ptr = runtime_symbol_info_$father (symbol_ptr);
  end;
  return;

  end setup_subscripts;
%page;
decode:
  proc (encoded_val, is_encoded) returns (fixed bin (35));


  dcl encoded_val		fixed bin (35) parameter;
  dcl is_encoded		bit (1) unaligned parameter;

  dcl result		fixed bin (35);


  if ^is_encoded
    then
         return (encoded_val);

  result = stu_$decode_runtime_value_extended (encoded_val,
       global.blockp, global.stackp, global.linkp,
       pointer (global.blockp, 0), global.base_ptr, value_symbol_ptr,
       error_code);

  if (error_code ^= 0) & ^global.probe_sw then do;
      call ioa_$ioa_switch (global.output_switch,
	 "^5x^vxerror: Cannot decode size/bounds of ^a.",
	 indentation (), get_unsubscripted_name ());
      error_code = 0;		/* There's no sensible code here; let our caller */
      goto FATAL_ERROR;		/* think it worked, since there's nothing to do */
    end;

  else if (error_code ^= 0)
    then goto FATAL_ERROR;		/* Let probe figure it out */
  return (result);

  end decode;
%page;
display_probe_constant:
  proc ();


  /* This procedure sets the usual global variables, fakes up a symbol 
   node and calls display_single_value. Since probe constants are never
   arrays or structures, no attention is paid to subscripts or recursion
   for structure elements here */

  dcl 1 ep		like encoded_precision;

  value_ptr = P_reference.address_ptr;
  unspec (value_info) = ""b;

  value_info.type = P_reference.type;
  value_info.base_type = value_info.type;
  value_data_info = data_type_info_$info (value_info.type);

  value_info.packed = P_reference.flags.packed;
  unspec (ep) = unspec (P_reference.precision);
				/* Unpack arithmetic precision and scale, if need be */
  value_info.scale = ep.scale;
  if (value_info.scale ^= 0)
    then value_info.size = ep.prec;
    else value_info.size = P_reference.precision;


  value_info.type_addr = null ();	/* I don't know what these are, but they look like they */
  value_info.base_type_addr = null ();	/* will work better as null pointers than as zeros */

  value_symbol_ptr = null ();

  call display_single_value ();
  return;

  end display_probe_constant;
%page;
print_cross_section:
  proc ();


  /* This procedure prints the contents of the current array cross-section.
   It also implements the recursing for printing the immediate sons of a
   structure element.  For reasons I don't understand, it only increments
   subscripts PL/I-style, even if it's printing for Fortran. It used to 
   check in MR9.1, but this was removed in MR10.1.  */

  dcl done		bit (1) aligned;
  dcl first_time_sw		bit (1) aligned;
				/* First time for cross-section */
  dcl same_count		fixed bin;
  dcl dont_print		bit (1) aligned;

  dcl value_size		fixed bin (24);
  dcl this_value		bit (value_size) based (this_value_ptr);
  dcl previous_value	bit (value_size) based (previous_value_ptr);

  /* This array is used to increment a subset of the indices in the global
   subscript array. It uses based(addr) due to a PL/I bug preventing
   the use of the defined attribute in this context. */

  dcl my_indices		(my_dims) fixed bin (24)
			based (addr (global.indices (first_dim)));


  this_value_symbol_ptr = value_symbol_ptr;

  call get_value_info ();		/* get info for first time */

  if ignore_this_element (dont_print) then do;
				/* If anything in the cross-section is ignored, */
      return;			/* it's always ignored. */
    end;

  first_time_sw = "1"b;
  value_size = 0;
  done = "0"b;

  do while (^done);

    if first_time_sw then do;
        first_time_sw = "0"b;
        starting_name = this_value_name;
        same_count = 1;
      end;

      else do;
        if value_size = 0
	then /* set this once for the loop */
	     value_size =
		bitno (this_value_ptr) - bitno (previous_value_ptr);
        if this_value ^= previous_value then do;
				/* time to print something */

	  call use_previous_value ();

	  call do_symbol_and_sons (starting_name, previous_value_name,
	       same_count, dont_print);

	  starting_name = this_value_name;
	  same_count = 0;
	end;

	else same_count = same_count + 1;
      end;

    previous_value_name = this_value_name;
    previous_value_ptr = this_value_ptr;
    previous_value_symbol_ptr = this_value_symbol_ptr;
    previous_real_value_ptr = real_value_ptr;
    unspec (previous_value_info) = unspec (this_value_info);
    unspec (previous_value_data_info) = unspec (this_value_data_info);
    previous_value_indices = this_value_indices;

    if (my_dims = 0)
      then done = "1"b;		/* Not a cross-section */
      else call probe_increment_indices_ ("0"b,
				/* Always PL/I */
	      my_indices, my_bounds, my_dims, done, ("0"b));
    ele_num = ele_num + 1;

    if ^done
      then call get_value_info ();

  end;

  call use_previous_value ();

  call do_symbol_and_sons (starting_name, previous_value_name, same_count,
       dont_print);
  return;

  end print_cross_section;
%page;
get_value_info:
  proc ();

  dcl offset_bits		fixed bin (6) unsigned;
  dcl offset_words		fixed bin (18) unsigned;
  dcl fixed		builtin;
  dcl i			fixed bin;
  dcl based_ptr		ptr based;
  dcl temp_ptr		ptr;

  /* Get information about the value to be printed. The address calculation
   stuff here is purely an efficiency hack; we could always recalculate
   it, but if probe already gave us the address (which it can for scalars
   only), we may as well use that, instead. */

  this_value_info.version = RUNTIME_TYPE_INFO_VERSION_1;

  call runtime_symbol_info_$type (this_value_symbol_ptr,
       addr (this_value_info), error_code);
  if error_code ^= 0 then do;
      call use_this_value ();
      call cannot_get_address ();
    end;

  this_value_data_info = data_type_info_$info (this_value_info.type);

  if global.calculate_address
    then /* must recalculate address */
         this_value_ptr = stu_$get_runtime_address (global.blockp,
	    this_value_symbol_ptr, global.stackp, global.linkp,
	    global.blockp, global.base_ptr, addr (global.indices));

    else this_value_ptr = inherited_addr;
  if (my_father_is_a_typeref)
    then
         temp_ptr = my_real_name_ptr;
    else temp_ptr = this_value_symbol_ptr;

  if (^ref_node_not_struct_or_union () &
       probe_info.language_type = C_lang_type) then do;
      if (temp_ptr ^= null ()) then do;
	if (^temp_ptr -> runtime_symbol.bits.simple) then do;
	    offset_bits = 0;
	    if (temp_ptr -> runtime_symbol.offset ^= 0
	         & my_real_name_ptr ^= P_reference.symbol_ptr)
	      then
		 offset_bits =
		      convert (offset_bits,
		      temp_ptr -> runtime_symbol.offset);
	    if (fixed (temp_ptr -> runtime_symbol.ndims) > 0) then do;
	        offset_bits =
		   offset_bits
		   + ele_num
		   *
		   get_size_in_bits_ (
		   fixed (temp_ptr -> runtime_symbol.type),
		   temp_ptr -> runtime_symbol.size,
		   (temp_ptr -> runtime_symbol.bits.packed));
	      end;
	    offset_words =
	         convert (offset_words, divide (offset_bits, 36, 17, 0));
	    offset_bits = convert (offset_bits, mod (offset_bits, 36));
	    addr (this_value_ptr) -> its_unsigned.offset =
	         addr (this_value_ptr) -> its_unsigned.offset
	         + offset_words;
	    addr (this_value_ptr) -> its_unsigned.bit_offset =
	         addr (this_value_ptr) -> its_unsigned.bit_offset
	         + offset_bits;


	  end;
        end;
    end;
  else if my_dims > 0 & probe_info.language_type = C_lang_type then do;
      if (temp_ptr ^= null ()) then do;
	if (^temp_ptr -> runtime_symbol.bits.simple) then do;
	    offset_bits = 0;
	    if (fixed (temp_ptr -> runtime_symbol.ndims) > 0) then do;
	        offset_bits =
		   offset_bits
		   + ele_num
		   *
		   get_size_in_bits_ (
		   fixed (temp_ptr -> runtime_symbol.type),
		   temp_ptr -> runtime_symbol.size,
		   (temp_ptr -> runtime_symbol.bits.packed));
	      end;
	    offset_words =
	         convert (offset_words, divide (offset_bits, 36, 17, 0));
	    offset_bits = convert (offset_bits, mod (offset_bits, 36));
	    addr (this_value_ptr) -> its_unsigned.offset =
	         addr (this_value_ptr) -> its_unsigned.offset
	         + offset_words;
	    addr (this_value_ptr) -> its_unsigned.bit_offset =
	         addr (this_value_ptr) -> its_unsigned.bit_offset
	         + offset_bits;


	  end;
        end;
    end;

  if (probe_info.language_type = C_lang_type)
    then
      do i = 1 to levels_of_pointer_indir;
      this_value_ptr = this_value_ptr -> based_ptr;
    end;

  real_value_ptr = addbitoffset (global.start_ptr,
       (bitno (this_value_ptr) - bitno (global.base_ptr)));

  this_value_indices = global.indices;

  call use_this_value ();

  this_value_name = get_symbol_name ();
  value_name = rtrim (this_value_name);

  if (this_value_ptr = null ()) & (this_value_info.type ^= structure_dtype)
    then
         call cannot_get_address ();	/* for instance, when a thunk cannot be evaluated */
  return;

  end get_value_info;
%page;
ignore_this_element:
  proc (P_dont_print) returns (bit (1) aligned);


  dcl P_dont_print		bit (1) aligned parameter;
				/* Set to suppress printing of extra structure levels */

  dcl 1 element_name	aligned
			based (
			runtime_symbol_info_$name (
			this_value_symbol_ptr)),
       2 len		fixed bin (9) unsigned unaligned,
       2 str		char (0 refer (element_name.len)) unaligned;
  dcl idx			fixed bin;
  dcl fixed		builtin;


  P_dont_print = "0"b;		/* This is only important when using match names */

  if global.probe_sw then do;
      if ^probe_modes.use_exclude_names
        then return ("0"b);
        else return (
	        probe_modes_mgr_$excludep (probe_info_ptr,
	        addr (element_name)));
    end;

  if global.use_match_names then do;
      do idx = 1 to P_match_name_count;
        if (index (this_value_name, P_match_names (idx)) ^= 0) then do;
	  return ("0"b);
	end;
      end;

      if (runtime_symbol_info_$son (this_value_symbol_ptr) ^= null ()
	 & (fixed (this_value_symbol_ptr -> runtime_symbol.type)
	 ^= pointer_dtype |
	 fixed (this_value_symbol_ptr -> runtime_symbol.type)
	 ^= c_typeref_dtype))
        then do;			/* Keep looking, but quietly */
	P_dont_print = "1"b;
	return ("0"b);
        end;
      return ("1"b);		/* No matches, so ignore it */
    end;

  /* Otherwise, azm uses a fixed heuristic */
  if (element_name.len < 3)
    then return ("0"b);
  if (substr (element_name.str, 1, 3) = "pad")
    then return ("1"b);
  if (substr (element_name.str, 1, 3) = "mbz")
    then return ("1"b);
  if (element_name.len < 6)
    then return ("0"b);
  if (substr (element_name.str, 1, 6) = "unused")
    then return ("1"b);
  if (element_name.len < 8)
    then return ("0"b);
  if (substr (element_name.str, 1, 8) = "unusable")
    then return ("1"b);
  return ("0"b);

  end ignore_this_element;
%page;
cannot_get_address:
  proc ();



  /* This is called when it turns out that the current symbol cannot be located
   for some reason; the usual one is that a thunk cannot be evaluated because
   the necessary pointers are not available (this is always the case for 
   display_data_, and sometimes the case for probe). In any case, when this 
   happens, we've done all we can, and we just punt. */

  if global.probe_sw then do;
      call probe_error_$record (probe_info_ptr,
	 probe_et_$no_address, get_symbol_name ());
      error_code = probe_et_$recorded_message;
    end;

    else do;

      call finish_output (addr (parent_output_info), "1"b);
				/* Finish anything waiting at this level */
      call ioa_$ioa_switch (global.output_switch,
	 "^5xerror: Cannot get address of ^a.", get_symbol_name ());
      error_code = 0;		/* There's no sensible code here; let our caller */
    end;				/* think it worked, since there's nothing to do */

  goto FATAL_ERROR;

  end cannot_get_address;
%page;
use_previous_value:
  proc ();


  value_symbol_ptr = previous_value_symbol_ptr;
  unspec (value_info) = unspec (previous_value_info);
  unspec (value_data_info) = unspec (previous_value_data_info);
  value_ptr = previous_value_ptr;
  real_value_ptr = previous_real_value_ptr;
  global.indices = previous_value_indices;
  ele_num = ele_num - 1;
  end use_previous_value;




use_this_value:
  proc ();


  value_symbol_ptr = this_value_symbol_ptr;
  unspec (value_info) = unspec (this_value_info);
  unspec (value_data_info) = unspec (this_value_data_info);
  value_ptr = this_value_ptr;
  global.indices = this_value_indices;
  end use_this_value;
%page;
do_symbol_and_sons:
  proc (P_first_name, P_last_name, P_count, P_dont_print);


  dcl (P_first_name, P_last_name)
			char (*);
  dcl P_count		fixed bin;
  dcl P_dont_print		bit (1) aligned parameter;

  dcl symbol_ptr		pointer;
  dcl fixed		builtin;


  dcl 1 my_output_info	aligned like output_info_template automatic;

dummy_node:
  proc (s_ptr) returns (bit (1));

  dcl s_ptr		parameter ptr;
  dcl name_ptr		ptr;

  name_ptr = addrel (s_ptr, fixed (s_ptr -> runtime_symbol.name));

  if (substr (name_ptr -> acc.string, 1, 1) = "!")
    then return ("1"b);
    else return ("0"b);

  end dummy_node;

  /* The P_dont_print flag is intended to suppress output for substructures which
   don't match the substring selections, but should be traversed anyway in 
   order to find interesting elements. */

  if P_count = 1
    then value_name = rtrim (P_first_name);
    else call ioa_$rsnnl ("^a ^[and^;through^] ^a", value_name,
	    length (value_name),
	    P_first_name, P_count = 2, P_last_name);

  if ^P_dont_print
    then call display_single_value ();

  /* We have a 'son' but the value my not be a structure. It may be a C
   indirect value. If the value is a pointer or typeref, ignore the son. */

  if (runtime_symbol_info_$son (value_symbol_ptr) = null () |
       fixed (value_symbol_ptr -> runtime_symbol.type) = pointer_dtype |
       fixed (value_symbol_ptr -> runtime_symbol.type) = c_typeref_dtype |
       fixed (value_symbol_ptr -> runtime_symbol.type) = c_enum_dtype)
    then do;
      return;			/* not a structure */
    end;

  /* This symbol may have 0 to N sons.  The first son is found by an 18 bit 
   offset (son), and the others are linked by 18 bit offsets from previous 
   son (brother).  Let symbol_offset take on, first the offset of my son, 
   then the offset of each brother of that son.  0 means end of chain */

  my_output_info.header = output_info_template.header;
  my_output_info.buffer = copy (" ", next_indentation ());


  do symbol_ptr = runtime_symbol_info_$son (value_symbol_ptr)
       repeat (runtime_symbol_info_$brother (symbol_ptr))
       while (symbol_ptr ^= null ());

    if (^dummy_node (symbol_ptr))
      then
	 call print_symbol (symbol_ptr, ndims, NOT_TOP_LEVEL,
	      addr (my_output_info), (value_ptr));
  end;

  call finish_output (addr (my_output_info), "1"b);
  return;

  end do_symbol_and_sons;
%page;
display_single_value:
  proc ();


  /* All knowledge about the internal representation of data is here, as is all
   knowledge of the formats that data are printed in. This procedure works
   entirely on values inherited from print_symbol */


  if (binary (rel (value_ptr), 18) > global.max_offset) then do;
      call finish_output (addr (parent_output_info), "1"b);
      call ioa_$ioa_switch (global.output_switch,
	 "^5xerror: ^a is outside the supplied data.",
	 get_symbol_name ());

      error_code = 0;		/* There's no sensible code here; let our caller */
      goto FATAL_ERROR;		/* think it worked, since there's nothing to do */
    end;

  if value_data_info.arithmetic
    then call display_arithmetic ();
  else if value_data_info.char_string
    then call display_char_string ();
  else if value_data_info.bit_string
    then call display_bit_string ();
  else if (value_info.type = picture_runtime_dtype)
    then call display_picture ();
  else if (value_info.type = pointer_dtype)
    then call display_pointer ();
  else if (value_info.type = offset_dtype)
    then call display_offset ();
  else if (value_info.type = label_constant_runtime_dtype)
    then call display_label_constant ();
  else if (value_info.type = label_dtype) | (value_info.type = entry_dtype)
    then
         call display_label_or_entry ();
  else if (value_info.type = file_dtype)
    then call display_file ();
  else if (value_info.type = int_entry_runtime_dtype)
       | (value_info.type = ext_procedure_runtime_dtype)
       | (value_info.type = ext_entry_runtime_dtype)
    then
         call display_entry_constant ();
  else if (value_info.type = structure_dtype)
    then call display_structure ();
  else if (value_info.type = c_union_dtype)
    then call display_structure ();
  else if (value_info.type = c_enum_dtype)
    then
         call display_c_enum ();
  else if (value_info.type = c_enum_const_dtype)
    then
         call display_arithmetic ();
  else call display_undisplayable ();

NONFATAL_ERROR:
  return;
%page;
display_arithmetic:
  proc ();


  dcl TEN_YEARS		fixed bin (71) int static
			options (constant) init (315360000000000);
  dcl 1 (source, target)	aligned like computational_data;
  dcl precision		fixed bin;
  dcl invalid_decimal_data	bit (9 * precision) based (value_ptr);
  dcl long_message		char (100) aligned;
  dcl short_message		char (8) aligned;
  dcl (fb71, hexfp_space)	fixed bin (71);
  dcl code		fixed bin (35);


  precision = decode (value_info.size, value_info.size_is_encoded);

  if value_data_info.decimal
    then
         if ^valid_decimal_ ((value_info.type), value_ptr, (precision))
	 then do;
	   call ioa_$rsnnl ("[invalid decimal data @ ^p] ""^.3b""b3",
	        value_str, (0), real_value_ptr, invalid_decimal_data);

	   call write_value_str ();
	   return;
	 end;

  unspec (source) = "0"b;
  source.address = value_ptr;
  source.data_type = value_info.type;
  source.packed = value_info.packed;
  source.prec_or_length = precision;
  source.scale = value_info.scale;
  source.picture_image_ptr = null;

  if source.data_type = real_flt_dec_generic_dtype
       | source.data_type = cplx_flt_dec_generic_dtype then do;
				/* don't print generic's tremendous precision */
      unspec (target) = "0"b;
      target.address = addr (hexfp_space);
      if source.data_type = real_flt_dec_generic_dtype
        then target.data_type = real_flt_hex_1_dtype;
        else target.data_type = cplx_flt_hex_1_dtype;
      target.prec_or_length = 27;	/* use a constant? */
      target.picture_image_ptr = null;

      call assign_$computational_ (addr (target), addr (source), code);
      if code = 0
        then source = target;		/* print hex instead if conversion worked */
    end;

  unspec (target) = "0"b;
  target.address = addr (value_str);
  target.data_type = varying_char_dtype;
  target.prec_or_length = maxlength (value_str);
  target.picture_image_ptr = null;

  on conversion go to CONVERSION_ERROR;
  on overflow go to CONVERSION_ERROR;
  on size go to CONVERSION_ERROR;

  call assign_$computational_ (addr (target), addr (source), code);
  if code ^= 0 then do;
CONVERSION_ERROR:
      call write_value_name ();

      call convert_status_code_ (code, short_message, long_message);
      call ioa_$ioa_switch (global.output_switch, "^a", long_message);
    end;
    else do;
      value_str = ltrim (value_str);

      if ^global.probe_sw & value_data_info.fixed & ^value_data_info.complex &
	 value_info.scale = 0 & precision >= 52 then do;

	unspec (target) = "0"b;
	target.address = addr (fb71);
	target.data_type = real_fix_bin_2_dtype;
	target.prec_or_length = 71;
	target.picture_image_ptr = null;

	call assign_$computational_ (addr (target), addr (source), 0);

	if fb71 > (clock () - TEN_YEARS) & fb71 < (clock () + TEN_YEARS)
	  then do;
				/* might be a date-time; is within 10 yr of now */
	    on sub_error_ go to SKIP_DTM;
	    value_str =
	         value_str || "   "
	         || date_time_$format ("iso_long_date_time", fb71, "", "");
	  end;
        end;
SKIP_DTM:
      call write_value_str ();
    end;
  return;

  end display_arithmetic;
%page;
display_c_enum:
  proc ();

  dcl (sym_addr, t_ptr, name_ptr)
			ptr;
  dcl not_found		bit (1);
  dcl based_int		fixed bin (35) based;

  t_ptr = value_symbol_ptr;
  not_found = "1"b;
  do while (not_found & t_ptr ^= null ());
    if (fixed (t_ptr -> runtime_symbol.type) = c_enum_const_dtype) then do;
        sym_addr = stu_$get_runtime_address (global.blockp,
	   t_ptr, global.stackp, global.linkp,
	   global.blockp, global.base_ptr, addr (global.indices));
        if sym_addr -> based_int = P_reference.address_ptr -> based_int
	then do;
	  name_ptr = addrel (t_ptr, fixed (t_ptr -> runtime_symbol.name));
	  call ioa_$ioa_switch (probe_info.output_switch, "^a",
	       substr (name_ptr -> acc.string, 1, name_ptr -> acc.num_chars)
	       );
	  not_found = "0"b;
	end;
	else do;
	  if (fixed (t_ptr -> runtime_symbol.brother) = 0)
	    then t_ptr = null ();
	    else t_ptr =
		    addrel (t_ptr,
		    fixed (t_ptr -> runtime_symbol.brother));
	end;
      end;
      else do;
        if (fixed (t_ptr -> runtime_symbol.son) = 0)
	then t_ptr = null ();
	else t_ptr = addrel (t_ptr, fixed (t_ptr -> runtime_symbol.son));
      end;
  end;
  if not_found then do;
      call ioa_$ioa_switch (probe_info.output_switch,
	 "Warning: The value for this enumerated value is out of range.");
      value_info.type = real_fix_bin_1_dtype;
      value_info.size = 35;
      value_info.scale = 0;
      call display_arithmetic ();
    end;
  end display_c_enum;
%page;
display_picture:
  proc ();


  dcl picture_ptr		pointer;
  dcl picture_len		fixed bin (35);
  dcl picture_string	char (picture_len) based (picture_ptr);


  call get_string_info (9, picture_ptr, picture_len);

  value_str = """" || picture_string || """";
  call write_value_str ();
  return;

  end display_picture;
%page;
display_char_string:
  proc ();


  dcl (amount_trimmed, str_len, trimmed_len)
			fixed bin (35);
  dcl str_ptr		pointer;
  dcl based_string		char (str_len) based (str_ptr);
  dcl trim_str		char (32) varying;
  dcl truncated_sw		bit (1);
  dcl quote_char		char (1);

  if language (COBOL_lang_type)
    then
         if (value_symbol_ptr ^= null ())
	 then /* In case it's a constant */
	      if (runtime_symbol_info_$son (value_symbol_ptr) ^= null ())
	        then do;
		call display_structure ();
				/* COBOL structures are strings;ase */
		return;
	        end;

  call get_string_info (9, str_ptr, str_len);

  if str_len > MINIMUM_TRIM then do;	/* "foo" || (165)" ", etc. */
      if substr (based_string, str_len, 1) = " "
        then
	   trimmed_len = length (rtrim (based_string, " "));
      else if substr (based_string, str_len, 1) = low (1)
        then
	   trimmed_len = length (rtrim (based_string, low (1)));
      else if substr (based_string, str_len, 1) = high (1)
        then
	   trimmed_len = length (rtrim (based_string, high (1)));
      else trimmed_len = str_len;

      if str_len - trimmed_len < MINIMUM_TRIM
        then trimmed_len = str_len;
    end;
    else trimmed_len = str_len;

  amount_trimmed = str_len - trimmed_len;

  if trimmed_len > STRING_LIMIT & global.truncate_strings then do;
				/* "mode truncate_strings" */
      truncated_sw = "1"b;
      trimmed_len = STRING_LIMIT;
    end;
    else truncated_sw = "0"b;

  quote_char = """";
  if language (FORTRAN_lang_type) | language (PASCAL_lang_type)
    then
         if index (substr (based_string, 1, trimmed_len), "'") = 0
	 then quote_char = "'";

  if amount_trimmed > 0 then do;
      if trimmed_len > 0
        then trim_str = " || ";
        else trim_str = "";
      trim_str = trim_str || "(";
      trim_str = trim_str || ltrim (character (amount_trimmed));
      trim_str = trim_str || ")";
      trim_str = trim_str || quote_char;
      trim_str = trim_str || substr (based_string, str_len, 1);
      trim_str = trim_str || quote_char;
    end;
    else trim_str = "";

  call write_value_name ();

  if trimmed_len = 0
    then
         call ioa_$ioa_switch (global.output_switch, "^[^a^;""""^]",
	    trim_str ^= "", trim_str);

  else if quote_char = """"
    then
         call ioa_$ioa_switch (global.output_switch, "^a^[ <MORE>^]^a",
	    requote_string_ (substr (based_string, 1, trimmed_len)),
	    truncated_sw, trim_str);

  else call ioa_$ioa_switch (global.output_switch, "'^a'^[ <MORE>^]^a",
	  substr (based_string, 1, trimmed_len), truncated_sw, trim_str);
  return;

  end display_char_string;
%page;
display_bit_string:
  proc ();


  dcl str_len		fixed bin (35);
  dcl str_ptr		pointer;
  dcl bit_string		bit (str_len) based (str_ptr);

  dcl FORTRAN_LOGICAL	(0:1) char (8) internal static
			options (constant) init
			(".FALSE.", ".TRUE.");
  dcl BIT_IOA_STRING	(4) char (12) varying internal static
			options (constant) init
			("""^.b""b", "^.3b", """^.3b""b3", """^.4b""b4")
			;

  dcl bit_radix		fixed bin;
  dcl truncated_sw		bit (1);


  call get_string_info (1, str_ptr, str_len);

  if language (FORTRAN_lang_type) & (str_len = 1) then do;
      value_str = FORTRAN_LOGICAL (binary (bit_string, 1));
      call write_value_str ();
      return;
    end;

  if str_len > STRING_LIMIT & global.truncate_strings then do;
      truncated_sw = "1"b;
      str_len = STRING_LIMIT;
    end;
    else truncated_sw = "0"b;

  /* In compressed output format, if we're given a single bit, we save it up for 
   later and print out all the flags in two groups ("ON" and "OFF"). */

  if global.compress_output & (str_len = 1) & (value_info.type = bit_dtype)
    then do;
      call add_bit (bit_string, value_name);
      return;
    end;

  /* For PL/I, we try to be clever, and display bitstrings in a useful format:
   octal, if appropriate, try hexadecimal next, and, all else failing, as bits.
   NOTE: This is sort of a crock, in that it uses 2 to mean "raw octal", 
   instead of "b2". This is done so that the "does-it-fit-in-the-buffer"
   test will work without further hacking. */

  if global.octal_sw
    then bit_radix = 2;
  else if (mod (str_len, 3) = 0)
    then bit_radix = 3;
  else if (mod (str_len, 4) = 0) & (str_len <= 64) & (str_len > 4)
    then bit_radix = 4;
  else bit_radix = 1;

  if divide (str_len, bit_radix, 24, 0) < maxlength (value_str) - 20 then do;
      call ioa_$rsnnl (BIT_IOA_STRING (bit_radix) || "^[ <MORE>^]", value_str,
	 (0),
	 bit_string, truncated_sw);
      call write_value_str ();
    end;
    else do;
      call write_value_name ();
      call ioa_$ioa_switch (global.output_switch,
	 BIT_IOA_STRING (bit_radix) || "^[ <MORE>^]",
	 bit_string, truncated_sw);
    end;
  return;
%page;
add_bit:
  proc (P_bits, P_name);


  dcl P_bits		bit (*) unaligned;
  dcl P_name		char (*) varying;

  dcl bitbufp		pointer;
  dcl 1 bitbuf		aligned like bit_buffer based (bitbufp);
  dcl this_bit		bit (1) aligned;
  dcl max_len		fixed bin;
  dcl new_len		fixed bin;


  this_bit = substr (P_bits, 1, 1);

  bitbufp = get_bitbuf (this_bit, "0"b);

  if (length (bitbuf.str) > 0) then do;
      max_len = global.line_length - (indentation () + 5);
      new_len = length (bitbuf.str) + length (value_name) + 2;
      if (new_len > max_len) then do;
	bitbuf.str = bitbuf.str || ",";
				/* End the last one with a comma */
	bitbufp = get_bitbuf (this_bit, "1"b);
				/* See if it can fit, get a new buffer if not */
        end;
    end;

  if (length (bitbuf.str) > 0)
    then
         bitbuf.str = bitbuf.str || ", ";
  bitbuf.str = bitbuf.str || value_name;
  return;
%page;
get_bitbuf:
  proc (P_bit, P_create_sw) returns (pointer);



  dcl a_temp_pointer	pointer;
  dcl P_bit		bit (1) aligned parameter;
  dcl P_create_sw		bit (1) aligned parameter;

  /* This is just an interface to find_or_create_bitbuf, passing the appropriate
   pointers from parent_output_info. */

  if (P_bit = "1"b)
    then
         a_temp_pointer = find_or_create_bitbuf (P_create_sw,
	    parent_output_info.on_bits.first,
	    parent_output_info.on_bits.last);

    else a_temp_pointer = find_or_create_bitbuf (P_create_sw,
	    parent_output_info.off_bits.first,
	    parent_output_info.off_bits.last);

  return (a_temp_pointer);


find_or_create_bitbuf:
  proc (P_create_sw, P_first, P_last) returns (pointer);

  dcl P_create_sw		bit (1) aligned parameter;
  dcl P_first		pointer parameter;
  dcl P_last		pointer parameter;

  dcl bufp		pointer;

  /* This procedure either finds the last bit buffer, or creates one and threads
   it into the list. One is always created if the list is empty; otherwise, 
   one is created if P_create_sw specifies it. */


  if P_create_sw | (P_first = null ()) then do;
      allocate bit_buffer in (system_area) set (bufp);
      bufp -> bit_buffer.str = "";
      bufp -> bit_buffer.next = null ();
      if (P_first = null ())
        then P_first = bufp;
        else P_last -> bit_buffer.next = bufp;
      P_last = bufp;
    end;

    else bufp = P_last;
  return (bufp);
  end find_or_create_bitbuf;


  end get_bitbuf;


  end add_bit;


  end display_bit_string;
%page;
get_string_info:
  proc (bits_per_char, str_ptr, str_len);


  dcl bits_per_char		float bin parameter;
  dcl str_ptr		pointer parameter;
  dcl str_len		fixed bin (35) parameter;

  dcl max_len		fixed bin (35);
  dcl chars_per_word	float bin;
  dcl based_varying_len	fixed bin (35) based (value_ptr);

  if value_data_info.varying
    then str_ptr = addrel (value_ptr, 1);
    else str_ptr = value_ptr;

  chars_per_word = 36 / bits_per_char;
  value_str = "";			/* If there is a problem, we will put an error message here */

  if (value_info.type = picture_runtime_dtype)
    then
         str_len =
	    pointer (value_symbol_ptr,
	    decode (value_info.size, value_info.size_is_encoded))
	    -> picture_image.varlength;

  else if value_data_info.varying then do;
      max_len = decode (value_info.size, value_info.size_is_encoded);
      str_len = based_varying_len;	/* get length word */
      if (str_len > max_len)
        then
	   call ioa_$rsnnl ("[varying length ^d is > dcld maximum ^d.]",
	        value_str, (0), str_len, max_len);
    end;

  else str_len = decode (value_info.size, value_info.size_is_encoded);

  if (language (C_lang_type) & P_reference.type = pointer_dtype
       & P_reference.precision > 0) then do;
      str_len = P_reference.precision;
    end;
  else if language (C_lang_type)
       & (value_info.size > 1 | my_real_name_ptr ^= null ()) then do;
      begin;
        dcl end_not_found	      bit (1) init ("1"b);
        dcl based_ints	      (0:255) fixed bin (9) unsigned
			      unaligned based (str_ptr);
        dcl max_len		      fixed bin (24);

        if (my_real_name_ptr ^= null ())
	then max_len = 256;
	else max_len = value_info.size - 1;
        do str_len = 0 to max_len while (end_not_found);
	if based_ints (str_len) = 0 then do;
	    end_not_found = "0"b;
	    str_len = str_len - 1;
	  end;
        end;
      end;
    end;
  if (str_len < 0)
    then
         call ioa_$rsnnl ("[length ^d is less than zero.]",
	    value_str, (0), str_len);

  else if ((binary (rel (str_ptr), 18) + (str_len / chars_per_word))
       > sys_info$max_seg_size)
    then
         call ioa_$rsnnl ("[length ^d is past end of the segment.]",
	    value_str, (0), str_len);

  else if ((binary (rel (str_ptr), 18) + (str_len / chars_per_word))
       > global.max_offset)
    then
         call ioa_$rsnnl ("[length ^d is past end of available data.]",
	    value_str, (0), str_len);

  if (value_str ^= "") then do;
      call write_value_str ();
      goto NONFATAL_ERROR;
    end;
  return;

  end get_string_info;
%page;
display_pointer:
  proc ();


  dcl based_ptr		pointer based (value_ptr);
  dcl based_packed_ptr	pointer unaligned based (value_ptr);


  if value_info.packed
    then
         value_str = format_pointer_$packed
	    (based_packed_ptr, "1"b, global.amu_info_ptr);

    else value_str =
	    format_pointer_$its (based_ptr, "1"b, global.amu_info_ptr);

  call write_value_str ();
  return;

  end display_pointer;

display_offset:
  proc ();


  dcl offset_ptr		pointer;
  dcl based_offset		offset based (value_ptr);
  dcl 1 offset_overlay,
       2 word		fixed bin (18) unsigned unaligned,
       2 bit		fixed bin (18) unsigned unaligned;


  offset_ptr = stu_$offset_to_pointer (global.blockp, value_symbol_ptr,
       value_ptr, global.stackp, global.linkp, global.blockp);

  if (offset_ptr ^= null ())
    then
         value_str =
	    format_pointer_$its (offset_ptr, "1"b, global.amu_info_ptr);

  else if (based_offset = nullo ())
    then
         value_str = "null offset";

  else do;
    unspec (offset_overlay) = unspec (based_offset);
    call ioa_$rsnnl ("word offset: ^o bit offset: ^d",
         value_str, (0), offset_overlay.word, offset_overlay.bit);
  end;

  call write_value_str ();
  return;

  end display_offset;
%page;
display_label_constant:
  proc ();


  call ioa_$rsnnl ("^a|^o", value_str, (0),
       format_pointer_$its (value_ptr, "1"b, global.amu_info_ptr),
       binary (rel (value_ptr), 18));
  call write_value_str ();
  return;

  end display_label_constant;



display_entry_constant:
  proc ();


  value_str = format_pointer_$its (value_ptr, "1"b, global.amu_info_ptr);
  call write_value_str ();
  return;

  end display_entry_constant;
%page;
display_label_or_entry:
  proc ();


  dcl based_label		label variable based (value_ptr);
  dcl 1 label		aligned,
       2 place		pointer,
       2 frame		pointer;


  unspec (label) = unspec (based_label);
  call ioa_$rsnnl ("^a :: ^p", value_str, (0),
       format_pointer_$its (label.place, "1"b, global.amu_info_ptr),
       label.frame);
  call write_value_str ();
  return;

  end display_label_or_entry;


display_file:
  proc ();


  dcl based_file		file variable based (value_ptr);


  call display_file_value_ (global.output_switch, based_file, (0));
  return;

  end display_file;
%page;
display_structure:
  proc ();


  /* To display a structure, we always give the structure name a line of its
   own before the recursing starts to print out the next level.  This is 
   only really important for compressed output mode, since otherwise, every
   value gets a line of its own anyway.  This does its own printing because
   it's far easier to do that than to make write_value_str any hairier. */

  /* It is a side-effect of this next call that the last line of output (say, 
   for level 3) before a substructure (say, level 4) is printed will not end
   in a comma, even if there are more scalar elements yet to be printed (at
   level 3).  I happen to think this is reasonably aesthetic, and better than
   including that lonesome comma, but it would be easy to change by adding
   another parameter to the finish_output call. */


  call finish_output (addr (parent_output_info), "0"b);

  call ioa_$ioa_switch (global.output_switch,
       "^vx^a^[^31t@ ^p", indentation (),
       value_name, ^global.probe_sw, real_value_ptr);
  return;

  end display_structure;
%page;
display_undisplayable:
  proc ();


  dcl message		char (40);


  if (value_info.type = area_dtype)
    then message = "an area";
  else if (value_info.type = algol68_straight_dtype)
    then message = "an algol68 straight";
  else if (value_info.type = algol68_format_dtype)
    then message = "an algol68 format";
  else if (value_info.type = algol68_array_descriptor_dtype)
    then
         message = "an algol68 array descriptor";
  else if (value_info.type = algol68_union_dtype)
    then message = "an algol68 union";
  else message = "data type " || ltrim (character (value_info.type));

  call ioa_$rsnnl ("[can't display value of ^a @ ^p]",
       value_str, (0), message, real_value_ptr);
  call write_value_str ();

  end display_undisplayable;

  end display_single_value;
%page;
language:
  proc (lang_type) returns (bit (1) aligned);


  dcl lang_type		fixed bin parameter;

  /* This procedure appears in two places in order for it to be quick in both of
   them. Clearly, it's not very complicated. */
  return (global.language_type = lang_type);

  end language;
%page;
get_symbol_name:
  proc () returns (char (256) varying);


  dcl name_string		char (256) varying;
  dcl father_idx		fixed bin;
  dcl start_level		fixed bin;
  dcl sym_dim		fixed bin;/* number of dims a symbol owns */
  dcl running_dims		fixed bin;/* total dims of all fathers */
  dcl my_level		fixed bin;
  dcl total_dims		fixed bin;/* total number of subscripts on this identifier */

  dcl father_dims		fixed bin;
  dcl element_symbol_ptr	pointer;
  dcl 1 element_name	aligned
			based (
			runtime_symbol_info_$name (element_symbol_ptr)),
       2 len		fixed bin (9) unsigned unaligned,
       2 str		char (0 refer (element_name.len)) unaligned;


  sym_dim = runtime_symbol_info_$array_dims (value_symbol_ptr);
  name_string = "";

  if (language (C_lang_type) & dont_print_me_this_time) then do;
      dont_print_me_this_time = "0"b;
      return (name_string);
    end;

  if language (FORTRAN_lang_type) then do;
      element_symbol_ptr = value_symbol_ptr;
      name_string = element_name.str;
      call add_dims (sym_dim, 1, -1);	/* FORTRAN is backwards */
    end;				/*  FORTRAN name */

  else if global.short_names then do;
      element_symbol_ptr = value_symbol_ptr;

      if my_real_name_ptr ^= null ()
        then
	   element_symbol_ptr = my_real_name_ptr;

      /* Without this test for null, big headaches. */

      if (runtime_symbol_info_$name (element_symbol_ptr) ^= null ())
        then do;
	if (P_reference.type ^= structure_dtype &
	     P_reference.type ^= c_union_dtype &
	     my_real_name_ptr = null ()
	     & probe_info.language_type = C_lang_type)
	  then
	       name_string = name_string || P_reference.name;
	  else
	       name_string = name_string || element_name.str;
        end;
        else name_string = P_reference.name;

      if language (COBOL_lang_type)
        then name_string = translate (name_string, "-", "_");

      my_level = runtime_symbol_info_$level (element_symbol_ptr);
      total_dims = runtime_symbol_info_$array_dims (element_symbol_ptr);
      if P_top_level_sw
        then father_dims = 0;

      /* This global.father array is a mess. C seems to reference values
         in this array that have not been initialized.   */

      else if (my_level > 1 & probe_info.language_type ^= C_lang_type)
        then do;			/* we are in structure, there is a global.father */
	if global.father (my_level - 1) ^= null ()
	  then
	       father_dims =
		  runtime_symbol_info_$array_dims (global
		  .father (my_level - 1));
        end;
      else father_dims = 0;
      call add_dims ((father_dims + 1), total_dims, 1);
    end;				/* COBOL or BRIEF or SHORT */

  else do;
    start_level = max (1, runtime_symbol_info_$level (value_symbol_ptr));
				/* for level 0 symbol, name stored in first */
    running_dims = 0;
    do father_idx = 1 to start_level;
      element_symbol_ptr = global.father (father_idx);

      name_string = name_string || element_name.str;
      sym_dim =
	 runtime_symbol_info_$array_dims (element_symbol_ptr)
	 - running_dims;
      call add_dims ((running_dims + 1),
	 (running_dims + sym_dim), 1);
      running_dims = running_dims + sym_dim;
      if (father_idx < start_level)
        then /* there are more names ahead */
	   name_string = name_string || ".";
    end;
  end;				/* end long naming */

  if (probe_info.language_type = C_lang_type
       & substr (name_string, 1, 1) = "!")
    then
         name_string = "";


  return (name_string);
%page;
  /* This entry just returns a name which can be used in messages */

get_unsubscripted_name:
  entry () returns (char (256) varying);

  name_string = "";

  start_level = max (1, runtime_symbol_info_$level (value_symbol_ptr));
				/* for level 0 symbol, name stored in first */

  do father_idx = 1 to start_level;
    element_symbol_ptr = global.father (father_idx);
    name_string = name_string || element_name.str;
    name_string = name_string || ".";
  end;

  element_symbol_ptr = value_symbol_ptr;
  name_string = name_string || element_name.str;
  return (name_string);



add_dims:
  proc (first, last, increment);


  dcl first		fixed bin parameter;
  dcl last		fixed bin parameter;
  dcl increment		fixed bin parameter;

  dcl dim_idx		fixed bin;

  /* Add dimension string to name_string if need be. The test sees whether there
   are any dimensions in the range to be added */


  if ((increment * (last - first)) < 0) then do;
      return;
    end;

  if (probe_info.language_type ^= C_lang_type) then do;
      name_string = name_string || " (";
      do dim_idx = first to last by increment;
        name_string = name_string ||
	   ltrim (rtrim (character (global.indices (dim_idx))));
        if (dim_idx ^= last)
	then name_string = name_string || ",";
      end;

      name_string = name_string || ")";
    end;
    else do;
      name_string = name_string || "[";
      do dim_idx = first to last by increment;
        name_string = name_string ||
	   ltrim (rtrim (character (global.indices (dim_idx))));
        if (dim_idx ^= last)
	then name_string = name_string || "][";
      end;

      name_string = name_string || "]";
    end;
  return;

  end add_dims;

  end get_symbol_name;
%page;
write_value_str:
  proc ();


  dcl delimiter		char (32) varying;
  dcl value_len		fixed bin;
  dcl max_len		fixed bin;
  dcl buf_len		fixed bin;
  dcl ind_len		fixed bin;
  dcl include_value		bit (1) aligned;


  include_value = "1"b;

  if ^global.print_names then do;	/* Get scalars out of the way quickly */
      call ioa_$ioa_switch (global.output_switch, "^a", value_str);
      return;
    end;

  goto COMMON;


write_value_name:
  entry ();


  include_value = "0"b;

  if ^global.print_names then do;
      return;
    end;

  goto COMMON;


COMMON:
  if global.probe_sw
    then delimiter = probe_modes.value_separator;
    else delimiter = " = ";

  value_len = length (value_name) + length (delimiter);
  if include_value
    then value_len = value_len + length (value_str);

  ind_len = indentation ();		/* For efficiency only */

  if ^global.compress_output then do;
      call ioa_$ioa_switch_nnl (global.output_switch,
	 "^vx^va^va^[^/^5x^vx^;^s^]^[^a^/^]", ind_len,
	 length (value_name), value_name,
	 length (delimiter), delimiter,
	 ((value_len > 72) & include_value), ind_len,
	 include_value, value_str);
      return;
    end;

  buf_len = length (parent_output_info.buffer);
  max_len = global.line_length;

  if ^include_value then do;

      /* In this case, we've been asked not to include the value, on the presumption
   that it is a rather long string. So, we just print out the current buffer
   contents, possibly inserting a newline if the value name itself is too
   long for the current line. */

      call ioa_$ioa_switch_nnl (global.output_switch,
	 "^va^[, ^]^[^/^vx^;^s^]^va^va",
	 buf_len, parent_output_info.buffer, (buf_len > 0),
	 ((buf_len + value_len + 2) > max_len), ind_len,
	 length (value_name), value_name,
	 length (delimiter), delimiter);

      parent_output_info.buffer = copy (" ", indentation ());
      return;			/* Empty the buffer */
    end;

  if ((buf_len + value_len + 2) < max_len) then do;

      /* In this case, the whole thing is small enough to fit in the current buffer,
   so we just append it and return, knowing that it will get printed later */

      if (parent_output_info.buffer ^= "")
        then /* Something there already */
	   parent_output_info.buffer = parent_output_info.buffer || ", ";
      parent_output_info.buffer = parent_output_info.buffer || value_name;
      parent_output_info.buffer = parent_output_info.buffer || delimiter;
      parent_output_info.buffer = parent_output_info.buffer || value_str;
      return;
    end;

  /* If it didn't fit, then we'll just go to the next line and print the stuff */

  if (buf_len > 0)
    then /* Print the current buffer if it has any contents */
         call ioa_$ioa_switch (global.output_switch, "^va,",
	    buf_len, parent_output_info.buffer);

  parent_output_info.buffer = copy (" ", ind_len);
				/* Empty the buffer */

  if ((value_len + 2) < max_len) then do;
				/* If it will fit, put it in */
      parent_output_info.buffer = parent_output_info.buffer || value_name;
      parent_output_info.buffer = parent_output_info.buffer || delimiter;
      parent_output_info.buffer = parent_output_info.buffer || value_str;
      return;
    end;

  /* Otherwise, write it out now, and leave the buffer empty */

  call ioa_$ioa_switch (global.output_switch,
       "^vx^va^va^[^/^5x^vx^;^s^]^a",
       ind_len, length (value_name), value_name,
       length (delimiter), delimiter,
       ((value_len + 2) > max_len), ind_len,
       value_str);
  return;

  end write_value_str;
%page;
indentation:
  proc () returns (fixed bin);

  dcl a_temp_value		fixed bin;
  a_temp_value =
       get_indentation (runtime_symbol_info_$level (value_symbol_ptr));
  return (a_temp_value);
  end indentation;


next_indentation:
  proc () returns (fixed bin);

  dcl a_temp_value		fixed bin;
  a_temp_value =
       get_indentation (1 + runtime_symbol_info_$level (value_symbol_ptr));
  return (a_temp_value);
  end next_indentation;


get_indentation:
  proc (P_level) returns (fixed bin);


  dcl P_level		fixed bin (6) parameter;

  dcl amount		fixed bin;
  dcl MAX_INDENT		fixed bin internal static
			options (constant) init (12);


  if ^global.short_names | language (C_lang_type) then do;
      return (0);
    end;

  amount = binary (P_level, 6) - 1;
  amount = max (amount, 0) * 2;
  amount = min (amount, MAX_INDENT);
  return (amount);

  end get_indentation;
%page;
finish_output:
  proc (P_output_info_ptr, P_finish_bits);


  dcl P_output_info_ptr	pointer parameter;
  dcl 1 finish_output_info	aligned like output_info_template
			based (P_output_info_ptr);
  dcl P_finish_bits		bit (1) aligned parameter;


  if ^global.compress_output then do;
      return;			/* nothing to do */
    end;

  if (finish_output_info.buffer ^= "")
    then
         call ioa_$ioa_switch (global.output_switch,
	    "^a", finish_output_info.buffer);

  if P_finish_bits
    then call finish_bits ();

  finish_output_info.buffer = copy (" ", indentation ());
				/* for safety's sake */
  return;
%page;
finish_bits:
  proc ();


  /* This procedure writes out the contents of any of the bit flag buffers we
   may have allocated, and frees them as it does so. */


  call write_bitbufs ("ON:",
       finish_output_info.on_bits.first,
       finish_output_info.on_bits.last);

  call write_bitbufs ("OFF:",
       finish_output_info.off_bits.first,
       finish_output_info.off_bits.last);
  return;



write_bitbufs:
  proc (P_name, P_first, P_last);


  dcl P_name		char (4) parameter;
  dcl P_first		pointer parameter;
  dcl P_last		pointer parameter;

  dcl bitbufp		pointer;
  dcl 1 bitbuf		aligned like bit_buffer based (bitbufp);
  dcl lastp		pointer;


  lastp = null ();
  do bitbufp = P_first repeat (bitbuf.next) while (bitbufp ^= null ());
    if (lastp ^= null ())
      then free lastp -> bitbuf;
    call ioa_$ioa_switch (global.output_switch,
         "^vx^[^5a^;^5x^s^]^a", next_indentation (),
         (bitbufp = P_first), P_name, bitbuf.str);
    lastp = bitbufp;
  end;

  if (lastp ^= null ())
    then free lastp -> bitbuf;
  P_first = null ();
  P_last = null ();
  return;

  end write_bitbufs;

  end finish_bits;

  end finish_output;

  end print_symbol;
%page;
bitno:
  proc (p) returns (fixed bin (24));


  dcl p			pointer parameter;
  dcl o			fixed bin (24) parameter;
  dcl 1 itsp		aligned like its_unsigned;
  dcl bito		fixed bin (24);
  dcl bitp		pointer;
  dcl mod			builtin;
%include its;

  /* This procedure can be flushed when this gets back to MIT */

  unspec (itsp) = unspec (p);
  return (36 * itsp.offset + itsp.bit_offset);


addbitoffset:
  entry (p, o) returns (pointer);


  unspec (itsp) = unspec (p);
  bito = 36 * itsp.offset + itsp.bit_offset;
  bito = bito + o;
  itsp.offset = divide (bito, 36, 18, 0);
  itsp.bit_offset = mod (bito, 36);
  unspec (bitp) = unspec (itsp);
  return (bitp);

  end bitno;

%page;
%include probe_info;
%page;
%include probe_static_info;
%page;
%include probe_references;
%page;
%include probe_source_info;
%page;
%include probe_seg_info;
%page;
%include probe_data_type_names;
%page;
%include probe_modes;
%page;
%include probe_lang_types;
%page;
%include acc;
%page;
%include computational_data;
%page;
%include data_type_info_;
%page;
%include encoded_precision;
%page;
%include picture_image;
%page;
%include runtime_symbol;
%page;
%include runtime_symbol_info_;
%page;
%include std_descriptor_types;
%page;
%include its;
  end display_data_;




		    format_pointer_.pl1             10/24/88  1612.2rew 10/24/88  1340.2      119952



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */



/****^  HISTORY COMMENTS:
  1) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

format_pointer_:
  procedure ();

  /* *	FORMAT_POINTER_ 
   * 
   *	Converts a pointer value to a printable representation.
   *
   *	After probe_check_ptr_, sort of.
   * 
   *      12 Sep 83, B. Braun:
   *         Changed to call amu_$get_name_for_structure when used by 
   *	   analyze_multics.
   *	03 Jun 83, W. Olin Sibert:
   */

  declare P_its_ptr		    pointer parameter;
  declare P_packed_ptr	    unaligned pointer parameter;
  declare P_name_sw		    bit (1) aligned parameter;
  declare P_amu_info_ptr	    pointer parameter;

  declare packed_sw		    bit (1) aligned;
  declare pointer_rep	    char (256) varying;
  declare valid		    bit (1) aligned;
  declare real_segment	    bit (1) aligned;
  declare seg_ptr		    pointer;

  declare 1 alias		    aligned internal static,
	 2 count		    fixed bin init (0),
	 2 array		    (25),
	  3 short_name	    char (32) varying,
	  3 long_name	    char (60) varying;

  declare error_table_$invalidsegno
			    fixed bin (35) external static;

  declare amu_$get_name_for_structure
			    entry (ptr, char (*) varying)
			    returns (char (*) varying),
	convert_status_code_    entry (fixed bin (35),
			    char (8) aligned, char (100) aligned);
  declare expand_pathname_	    entry (char (*), char (*), char (*),
			    fixed bin (35));
  declare get_pdir_		    entry () returns (char (168));
  declare hcs_$fs_get_path_name   entry (pointer,
			    char (*), fixed bin, char (*),
			    fixed bin (35));
  declare hcs_$high_low_seg_count entry (fixed bin, fixed bin);
  declare hcs_$status_long	    entry (char (*), char (*),
			    fixed bin (1), pointer, pointer,
			    fixed bin (35));
  declare ioa_$rsnnl	    entry options (variable);
  declare ring0_get_$name	    entry (char (*), char (*), pointer,
			    fixed bin (35));

  declare (stringsize, error)	    condition;

  declare (addr, after, baseno, binary, char, index, max, null, rtrim,
	unspec)		    builtin;

  /*  */

format_pointer_$its:
  entry (P_its_ptr, P_name_sw, P_amu_info_ptr)
       returns (char (256) varying);

  packed_sw = "0"b;
  call edit_its_pointer (P_its_ptr, pointer_rep, valid, real_segment);
  goto CONVERT_POINTER_COMMON;



format_pointer_$packed:
  entry (P_packed_ptr, P_name_sw, P_amu_info_ptr)
       returns (char (256) varying);

  packed_sw = "1"b;
  call edit_packed_pointer (P_packed_ptr, pointer_rep, valid, real_segment);
  goto CONVERT_POINTER_COMMON;


CONVERT_POINTER_COMMON:
  if ^valid then do;
      pointer_rep = pointer_rep || " [invalid]";
      return (pointer_rep);
    end;

  if ^real_segment
    then
         return (pointer_rep);

  if ^P_name_sw
    then
         return (pointer_rep);

  /* This should, by rights, use the amu_ name resolution facility, but there
   isn't one yet, so instead it just gives up if there's an amu_info_ptr. */

  if P_amu_info_ptr ^= null then do;	/* used by analyze_multics */
      pointer_rep = amu_$get_name_for_structure (P_amu_info_ptr, pointer_rep);
      return (pointer_rep);
    end;
				/* Otherwise, we determine the name in the current address space and add it */

  if packed_sw
    then /* Sinc we know it's valid now, */
         seg_ptr = P_packed_ptr;	/* this avoids taking a fault on the pointer */
    else seg_ptr = P_its_ptr;

  call add_segment_name (seg_ptr, pointer_rep);
  return (pointer_rep);

  /*  */

edit_its_pointer:
  procedure (P_its_ptr, P_rep, P_valid, P_real_segment);


  declare P_its_ptr		    pointer parameter;
  declare P_rep		    char (256) varying parameter;
  declare P_valid		    bit (1) aligned parameter;
  declare P_real_segment	    bit (1) aligned parameter;

  declare 1 its_ptr		    aligned like its_unsigned;
  declare 1 itp_ptr		    aligned like itp_unsigned;
  declare 1 ge_ptr		    aligned,
	 2 offset		    bit (18) unaligned,
	 2 tally		    bit (12) unaligned,
	 2 mod		    fixed bin (6) unsigned unaligned;
  ;

  /* format: off */
declare   MODIFIERS (0 : 63) char (3) aligned internal static options (constant) initial
         ("   ", "au ", "qu ", "du ", "ic ", "al ", "ql ", "dl ",
          "x0 ", "x1 ", "x2 ", "x3 ", "x4 ", "x5 ", "x6 ", "x7 ",
	"n* ", "au*", "qu*", "23 ", "ic*", "al*", "ql*", "27 ",
	"x0*", "x1*", "x2*", "x3*", "x4*", "x5*", "x6*", "x7*",
	"f1 ", "itp", "42 ", "its", "sd ", "scr", "f2 ", "f3 ",
	"ci ", "i  ", "sc ", "ad ", "di ", "dic", "id ", "idc",
	"*n ", "*au", "*qu", "*du", "*ic", "*al", "*ql", "*dl",
	"*x0", "*x1", "*x2", "*x3", "*x4", "*x5", "*x6", "*x7");
/* format: on */


  unspec (its_ptr) = unspec (P_its_ptr);
  unspec (itp_ptr) = unspec (P_its_ptr);
  unspec (ge_ptr) = unspec (P_its_ptr);

  P_real_segment = "0"b;
  P_rep = "";

  P_valid = "0"b;

  if (its_ptr.its_mod = ITS_MODIFIER) then do;
      if (its_ptr.segno = 32767) & (its_ptr.mod = ""b)
        then
	   call ioa_$rsnnl ("null^[(^o^[^o^;^s^])^]",
	        P_rep, (0), (its_ptr.offset ^= 1), its_ptr.offset,
	        (its_ptr.bit_offset ^= 0), its_ptr.bit_offset);

        else do;
	call ioa_$rsnnl ("^o|^o^[(^d)^;^s^]^[[^d]^;^s^]^[,^a^]",
	     P_rep, (0), its_ptr.segno, its_ptr.offset,
	     (its_ptr.bit_offset ^= 0), its_ptr.bit_offset,
	     ((its_ptr.ringno ^= 0) & (its_ptr.ringno ^= 4)),
	     its_ptr.ringno, (its_ptr.mod ^= ""b),
	     MODIFIERS (binary (its_ptr.mod, 6)));
	if (its_ptr.segno < 4093)
	  then P_real_segment = "1"b;
        end;

      if (its_ptr.segno < 4095) | (its_ptr.segno = 32767)
        then
	   if (its_ptr.bit_offset < 36)
	     then
		P_valid = "1"b;
    end;

  else if (its_ptr.its_mod = ITP_MODIFIER) then do;
      call ioa_$rsnnl ("pr^o|^o^[(^d^;^s)^]^[,^a^] (ITP)",
	 P_rep, (0), itp_ptr.pr_no, itp_ptr.offset,
	 (itp_ptr.bit_offset ^= 0), itp_ptr.bit_offset,
	 (itp_ptr.mod ^= ""b), MODIFIERS (binary (itp_ptr.mod, 6)));

      if (itp_ptr.bit_offset < 36)
        then P_valid = "1"b;
    end;

  else do;
    call ioa_$rsnnl ("^o(^o)^[,^a^]",
         P_rep, (0), ge_ptr.offset, ge_ptr.tally,
         (ge_ptr.mod ^= 0), MODIFIERS (ge_ptr.mod));
  end;
  return;
  end edit_its_pointer;

  /*  */

edit_packed_pointer:
  procedure (P_packed_ptr, P_rep, P_valid, P_real_segment);


  declare P_packed_ptr	    unaligned pointer parameter;
  declare P_rep		    char (256) varying parameter;
  declare P_valid		    bit (1) aligned parameter;
  declare P_real_segment	    bit (1) aligned parameter;

  declare fault_type	    fixed bin;

  declare 1 packed_ptr	    aligned,
	 2 bit_offset	    fixed bin (6) unsigned unaligned,
	 2 segno		    fixed bin (12) unsigned unaligned,
	 2 offset		    fixed bin (18) unsigned unaligned;

  declare 1 packed_ptr_fault	    aligned,
	 2 pad		    bit (9) unaligned,
	 2 type		    fixed bin (9) unaligned unsigned,
	 2 offset		    fixed bin (18) unsigned unaligned;


  unspec (packed_ptr) = unspec (P_packed_ptr);
  unspec (packed_ptr_fault) = unspec (P_packed_ptr);

  P_valid = (packed_ptr.bit_offset < 36);
				/* Not much else to check here */
  P_real_segment = "0"b;
  P_rep = "";

  if (packed_ptr.bit_offset < 48)
    then
         fault_type = 0;
    else fault_type = 1 + max (3, packed_ptr_fault.type);

  if P_valid & (packed_ptr.segno = 4095)
    then
         call ioa_$rsnnl ("null^[(^o^[^o^;^s^])^]",
	    P_rep, (0), (packed_ptr.offset ^= 1), packed_ptr.offset,
	    (packed_ptr.bit_offset ^= 0), packed_ptr.bit_offset);

    else do;
      call ioa_$rsnnl (
	 "^o|^o^[(^d)^;^s^]^[ (^[LOT fault^;ISOT fault^;System fault^;faulted^])^]",
	 P_rep, (0), packed_ptr.segno, packed_ptr.offset,
	 (packed_ptr.bit_offset ^= 0), packed_ptr.bit_offset,
	 (fault_type ^= 0), fault_type);
      if (fault_type = 0)
        then
	   if (packed_ptr.segno < 4093)
	     then P_real_segment = "1"b;
    end;
  return;
  end edit_packed_pointer;

  /*  */

add_segment_name:
  procedure (P_seg_ptr, P_rep);


  declare P_seg_ptr		    pointer;
  declare P_rep		    char (256) varying;

  declare dname		    char (168);
  declare ename		    char (32);
  declare long_info		    char (100) aligned;
  declare idx		    fixed bin;
  declare code		    fixed bin (35);
  declare first_stack	    fixed bin;
  declare last_seg		    fixed bin;


  call initialize_aliases ();

  call hcs_$high_low_seg_count (last_seg, first_stack);
  last_seg = last_seg + first_stack;

  if (binary (baseno (P_seg_ptr)) < first_stack)
    then /* hardcore segment */
         call ring0_get_$name (dname, ename, P_seg_ptr, code);
    else call hcs_$fs_get_path_name (P_seg_ptr, dname, (0), ename, code);

  if (code = error_table_$invalidsegno) then do;
      P_rep = P_rep || " (Invalid segment number)";
      return;
    end;

  if (code ^= 0) then do;		/* get a string describing error */
      call convert_status_code_ (code, (""), long_info);
      P_rep = P_rep || " (Error: ";
      P_rep = P_rep || rtrim (long_info);
      P_rep = P_rep || ")";
      return;
    end;

  P_rep = P_rep || "   ";		/* append the pathname */

  if (dname = "") then do;		/* ring zero segment */
      P_rep = P_rep || rtrim (ename);
      P_rep = P_rep || " (ring 0)";
      return;
    end;

  do idx = 1 to alias.count;		/* Interpret aliases */
    if (dname = alias.long_name (idx)) then do;
        P_rep = P_rep || alias.short_name (idx);
        P_rep = P_rep || ">";
        P_rep = P_rep || rtrim (ename);
        return;
      end;
  end;

  P_rep = P_rep || rtrim (dname);	/* If no alias found, then just add the path */
  P_rep = P_rep || ">";		/* The alias hack takes care of the ROOT */
  P_rep = P_rep || rtrim (ename);
  return;
  end add_segment_name;

  /*  */

initialize_aliases:
  procedure ();


  declare pdir_name		    char (168);


  if (alias.count > 0)
    then
         return;			/* We've already been here */

  call add_alias (">", "");		/* So the ROOT doesn't come out with ">>" */

  pdir_name = get_pdir_ ();
  call add_alias (pdir_name, "[pd]");
  if (index (pdir_name, ">process_dir_dir>") = 1) then do;
      pdir_name = ">pdd>" || after (pdir_name, ">process_dir_dir>");
      call add_alias (pdir_name, "[pd]");
    end;

  call add_alias (">process_dir_dir>!zzzzzzzbBBBBBB", "[Inzr PD]");

  call add_alias (">system_control_1", ">sc1");
  call add_alias (">system_library_1", ">sl1");
  call add_alias (">system_library_standard", ">sss");
  call add_alias (">system_library_unbundled", ">unb");
  call add_alias (">system_library_tools", ">tools");
  call add_alias (">system_library_auth_maint", ">am");
  call add_alias (">user_dir_dir", ">udd");
  call add_alias (">process_dir_dir", ">pdd");
  call add_alias (">library_dir_dir", ">ldd");
  call add_alias (">daemon_dir_dir", ">ddd");
  return;
  end initialize_aliases;

  /*  */

add_alias:
  procedure (P_long, P_short) options (non_quick);
				/* Non-quick because it's used only once */

  declare P_long		    char (*) parameter;
  declare P_short		    char (*) parameter;

  declare 1 dir_status	    aligned like status_branch;

  declare dname		    char (168);
  declare ename		    char (32);
  declare idx		    fixed bin;
  declare code		    fixed bin (35);
  declare short_uid		    bit (36) aligned;
  declare long_uid		    bit (36) aligned;


  idx = alias.count + 1;		/* Next entry */

(subscriptrange):			/* To detect overflows of the array */
(stringsize):
  begin;
    on condition (stringsize) signal error;
				/* Braindamaged default handler */

    alias.short_name (idx) = rtrim (P_short);
    alias.long_name (idx) = rtrim (P_long);
  end;

  if (char (P_short, 1) ^= ">") then do;/* don't check aliases that are not directories */
      alias.count = idx;		/* update the count */
      return;			/* all done */
    end;

  call expand_pathname_ (P_long, dname, ename, code);
  if (code ^= 0)
    then
         return;			/* Just punt on any errors */

  call hcs_$status_long (dname, ename, (0), addr (dir_status), (null ()),
       code);
  if (code ^= 0)
    then
         return;

  long_uid = dir_status.uid;

  call expand_pathname_ (P_short, dname, ename, code);
  if (code ^= 0)
    then
         return;

  call hcs_$status_long (dname, ename, (0), addr (dir_status), (null ()),
       code);
  if (code ^= 0)
    then
         return;

  short_uid = dir_status.uid;

  if (short_uid ^= long_uid)
    then
         return;

  alias.count = idx;
  return;

  end add_alias;

%page;
%include its;
%page;
%include status_structures;

  end format_pointer_;




		    get_size_in_bits_.pl1           11/11/88  1554.4r w 11/11/88  1545.0      113517



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



/****^  HISTORY COMMENTS:
  1) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

get_size_in_bits_:
  proc (P_type, P_prec, P_packedp) returns (fixed bin);

  /* returns number of bits that data of specified type, etc. occupies,
   or -1 for unhandleable types.

   James R. Davis 20 Sept 78
   modified 20 May 79 JRD to know COBOL, and use data_type_info_
   modified June 83 JMAthane to know ALGOL and PASCAL  */
  /* Added $structure to allow unspec and let to work on arrays and structures 08/24/83 S. Herbst */
  /* Fixed $structure to reject refer extents 08/25/83 S. Herbst */
  /* Added hex (47-50), extended (81-82), and generic (83-86) types 02/14/84 S. Herbst */
  /* Fixed $structure to handle encoded array bounds, now takes ref_ptr not symbol_ptr 06/05/84 S. Herbst */


  dcl (
      P_type		fixed bin,/* data type */
      P_prec		fixed bin (35),
				/* declared precision */
      P_packedp		bit (1) aligned
			/* 1 if packed else 0 */
      )			parameter;

  dcl TOP_LEVEL		fixed bin int static options (constant)
			init (1);
  dcl BASED_CLASS		bit (4) unaligned int static
			options (constant) init ("0011"b);

  dcl t			fixed bin;

  dcl type		fixed bin;
  dcl prec		fixed bin (35);
  dcl packedp		bit (1) aligned;

  dcl 1 an_encoded_prec	aligned like encoded_precision;

  dcl get_size_in_bits_	entry (fixed bin, fixed bin (35),
			bit (1) aligned) returns (fixed bin);
  dcl probe_error_$warning	entry options (variable);
  dcl runtime_symbol_info_$brother
			entry (ptr) returns (ptr);
  dcl runtime_symbol_info_$son
			entry (ptr) returns (ptr);
  dcl stu_$decode_runtime_value
			entry (fixed bin (35), ptr, ptr, ptr, ptr, ptr,
			fixed bin (35)) returns (fixed bin (35));
  dcl stu_$get_implicit_qualifier
			entry (ptr, ptr, ptr, ptr, ptr) returns (ptr);

  dcl (divide, fixed, hbound, lbound, mod, null, substr, unspec)
			builtin;

  type = P_type;
  if type < lbound (sizer, 1) | type > hbound (sizer, 1)
    then
         return (-1);		/* type we cant handle */
  if data_type_info_$info (type).fixed
    then do;
      unspec (an_encoded_prec) = unspec (P_prec);
      prec = an_encoded_prec.prec;
    end;
    else prec = P_prec;
  packedp = P_packedp;

  goto sizer (type);

sizer (1):
sizer (2):
  t = prec + 1;
  if ^packedp
    then if t <= 36
	 then return (36);
	 else return (72);
    else return (t);

sizer (3):
sizer (4):
float_bin:
  t = prec + 1 + 8;			/* sign and exponent */
  if ^packedp
    then if t <= 36
	 then return (36);
	 else return (72);
    else return (t);

sizer (5):
sizer (6):
  t = prec + 1;
  if ^packedp
    then if t <= 36
	 then t = 36;
	 else t = 72;
  return (t * 2);

sizer (7):
sizer (8):
complex_float_bin:
  t = prec + 1 + 8;			/* float complx bin */
  if ^packedp
    then if t <= 36
	 then t = 36;
	 else t = 72;
  return (2 * t);

sizer (9):
  return ((prec + 1) * 9);		/* fixed dec */

sizer (10):
float_dec_9bit:
  return ((prec + 1) * 9 + 9);	/* float dec */

sizer (11):
  return ((((prec + 1) * 9) * 2));	/* cplx fixed dec */

sizer (12):			/* cplx float dec */
complex_float_dec_9bit:
  return (((((prec + 1) * 9) + 9) * 2));

sizer (13):			/* pointer */
  if packedp
    then return (36);
    else return (72);

sizer (14):
  return (36);			/* offset */

sizer (15):
  return (144);			/* label -two pts */


sizer (16):
  return (144);			/* entry - two ptrs */

sizer (17):
  return (-1);			/* structure */

sizer (18):
  return (-1);			/* area */

sizer (19):
  return (prec);			/* bit */

sizer (20):			/* varying bit */
  return (prec + 36);

sizer (21):
  return (prec * 9);		/* char */

sizer (22):
  return ((prec * 9) + 36);		/* char varying */

sizer (23):			/* file */
  return (144);

sizer (24):			/* label constant */
sizer (25):			/* entries of three flavors */
sizer (26):
sizer (27):
sizer (28):			/* not used */
  return (-1);

sizer (29):
sizer (30):
  return (prec * 9);		/* real fixed dec 9bit overpunched */

sizer (31):			/* not used */
sizer (32):			/* not used */
  return (-1);

sizer (33):			/* unsigned binary short */
  if packedp
    then return (prec);
    else return (36);
sizer (34):			/* unsigned binary long */
  if packedp
    then return (prec);
    else return (72);

sizer (35):
  return (prec * 9);		/* unsigned dec 9 bit */

sizer (36):
  return ((prec + 1) * 9);		/* TS dec 9 bit */

sizer (37):			/* not used */
  return (-1);

sizer (38):			/* fixed unsigned 4bit digit aligned COBOL */
  return (prec * 4.5e0);

sizer (39):			/* fixed TS 4bit digit */
  return ((prec + 1) * 4.5e0);

sizer (40):			/* RFU */
  return (-1);

sizer (41):			/* fixed LS 4bit digit aligned COBOL */
  return ((prec + 1) * 4.5e0);

sizer (42):			/* float unsigned 4bit digit aligned COBOL */
  return ((prec + 1) * 4.5e0 + 9);

sizer (43):			/* real fixed 4bit LS byte aligned */
  return (prec * 4.5e0);

sizer (44):
  return ((prec + mod (prec, 2)) * 4.5e0 + 9);
				/* float 4bit byte al */

sizer (45):
  return ((prec + mod (prec, 2)) * 4.5e0 * 2);
				/* cmlx fixed LS 4bit byte al */

sizer (46):			/* cplx flt 4bit byte aligned */
  return (((prec + mod (prec, 2)) * 4.5e0 + 9) * 2);

sizer (47):			/* real flt hex */
sizer (48):
  go to float_bin;

sizer (49):			/* cplx flt hex */
sizer (50):
  go to complex_float_bin;

sizer (51):
sizer (52):
sizer (53):
sizer (54):
sizer (55):
sizer (56):
sizer (57):
sizer (58):
sizer (59):			/* algol68 straight */
sizer (60):			/* algol68 format */
sizer (61):			/* algol68 array descriptor */
sizer (62):			/* algol68 union */
sizer (63):
  return (-1);

sizer (64):			/* pascal typed pointer */
sizer (65):			/* pascal char */
sizer (66):			/* pascal boolean */
  return (prec);

sizer (67):			/* pascal record file */
sizer (68):			/* pascal record */
sizer (69):			/* pascal set */
sizer (70):			/* pascal enumerated type */
  return (-1);

sizer (71):			/* pascal enumerated type element */
sizer (72):			/* pascal enumerated type instance */
  return (prec);

sizer (73):			/* pascal user defined type */
  return (-1);

sizer (74):			/* pascal user defined type instance */
sizer (75):			/* pascal text file */
  return (prec);

sizer (76):
sizer (77):
sizer (78):
sizer (79):
sizer (80):
  return (-1);

sizer (81):			/* real flt dec extended */
  go to float_dec_9bit;

sizer (82):			/* cplx flt dec extended */
  go to complex_float_dec_9bit;

sizer (83):			/* real flt dec generic */
  return ((prec + 1) * 9 + 36);

sizer (84):			/* cplx flt dec generic */
  return (((prec + 1) * 9 + 36) * 2 + mod (prec + 1, 4) * 9);

sizer (85):			/* real flt bin generic */
  return (108);

sizer (86):			/* cplx flt bin generic */
  return (108 * 2 + 36);
%page;

structure:
  entry (A_ref_ptr) returns (fixed bin);

  /* Returns size given a pointer to a reference node. Works on scalars, arrays, structures */

  dcl A_ref_ptr		ptr;
  dcl a_temp_val		fixed bin;



  a_temp_val = size_of_structure (A_ref_ptr -> reference_node.symbol_ptr,
       A_ref_ptr -> reference_node.source_info_ptr,
       (A_ref_ptr -> reference_node.subscript_ptr),
       A_ref_ptr -> reference_node.address_ptr,
       (A_ref_ptr -> reference_node.cross_section), TOP_LEVEL);
  return (a_temp_val);
%page;
size_of_structure:
  proc (P_symbol_ptr, P_source_info_ptr, P_subscript_ptr, P_address_ptr,
       P_cross_section_sw, P_level) returns (fixed bin);

  /* Returns the bit size of most kinds of (PL/1 anyway) variable, including
   structures and arrays. Returns -1 as does get_size_in_bits_ if it can't */

  dcl (P_symbol_ptr, P_source_info_ptr, P_subscript_ptr, P_address_ptr)
			ptr;
  dcl (P_level, round_factor, var_type)
			fixed bin;
  dcl (address_ptr, p)	ptr;
  dcl (P_cross_section_sw, packed_sw)
			bit (1) aligned;
  dcl (i, total_size)	fixed bin (21);
  dcl (code, high, low)	fixed bin (35);
  dcl 1 si		aligned like source_info
			based (P_source_info_ptr);
  dcl 1 ref_subs		aligned based (P_subscript_ptr)
			like reference_subscripts;

  if fixed (P_symbol_ptr -> runtime_symbol.type) = structure_dtype then do;

      total_size = 0;

      do p = runtime_symbol_info_$son (P_symbol_ptr)
	 repeat (runtime_symbol_info_$brother (p))
	 while (p ^= null);

        i = size_of_structure ((p), P_source_info_ptr, null, P_address_ptr,
	   P_cross_section_sw, P_level + 1);
        if i = -1
	then return (-1);
	else total_size = total_size + i;
      end;
    end;

    else do;
      if substr (unspec (P_symbol_ptr -> runtime_symbol.size), 1, 2) = "10"b
        then
	   return (-1);
				/* encoded size field: variable or refer extent */
      var_type = fixed (P_symbol_ptr -> runtime_symbol.type, 17, 0);
      packed_sw = P_symbol_ptr -> runtime_symbol.packed;
      total_size =
	 get_size_in_bits_ (var_type, P_symbol_ptr -> runtime_symbol.size,
	 packed_sw);

      if total_size > 0 & ^packed_sw & P_level > 1
        then /* in structure, round off to whole word */
	   if var_type = pointer_dtype then do;
				/* aligned pointer always starts at even word */
	       if mod (P_symbol_ptr -> runtime_symbol.offset, 2) ^= 0
	         then
		    total_size = total_size + 36;
	     end;
	     else do;
	       if var_type = cplx_fix_bin_1_dtype
		  | var_type = cplx_flt_bin_1_dtype
	         then
		    round_factor = 72;
	       else if var_type = cplx_fix_bin_2_dtype
		  | var_type = cplx_flt_bin_2_dtype
	         then
		    round_factor = 144;
	       else round_factor = 36;

	       total_size =
		  round_factor
		  *
		  divide (total_size + round_factor - 1, round_factor, 17,
		  0);
	     end;
    end;

  if total_size = -1 | P_symbol_ptr -> runtime_symbol.ndims = "0"b
    then
         return (total_size);

  address_ptr = P_address_ptr;
  if address_ptr = null
    then
         if P_symbol_ptr -> runtime_symbol.class = BASED_CLASS
	 then
	      address_ptr =
		 stu_$get_implicit_qualifier (si.block_ptr, P_symbol_ptr,
		 si.stack_ptr,
		 (si.seg_info_ptr -> seg_info.linkage_ptr), si.block_ptr);

  /* Compute array extents, if any */

  do i = 1 to fixed (P_symbol_ptr -> runtime_symbol.ndims);

    if P_subscript_ptr ^= null
      then
	 if ref_subs.number >= i then do;
				/* use specified subscript */
	     low = ref_subs.value (1, i);
	     if P_cross_section_sw
	       then high = ref_subs.value (2, i);
	       else high = low;
	     go to HAVE_BOUNDS;
	   end;

    low = P_symbol_ptr -> runtime_symbol.bounds.lower (i);
    if low < 0 then do;
        low = stu_$decode_runtime_value (low, si.block_ptr, si.stack_ptr,
	   (si.seg_info_ptr -> seg_info.linkage_ptr), si.block_ptr,
	   address_ptr, code);
        if code ^= 0
	then
	     return (-1);
      end;
    high = P_symbol_ptr -> runtime_symbol.bounds.upper (i);
    if high < 0 then do;
        high = stu_$decode_runtime_value (high, si.block_ptr, si.stack_ptr,
	   (si.seg_info_ptr -> seg_info.linkage_ptr), si.block_ptr,
	   address_ptr, code);
        if code ^= 0
	then
	     return (-1);
      end;
HAVE_BOUNDS:
    if low <= 0
      then
	 call probe_error_$warning (null, 0, "Lower bound <= 0.");
    if high <= 0
      then
	 call probe_error_$warning (null, 0, "Upper bound <= 0.");
    if low <= 0 | high <= 0
      then
	 return (-1);
    total_size = total_size * (high - low + 1);
  end;
  return (total_size);

  end size_of_structure;

%include data_type_info_;
%page;
%include encoded_precision;
%page;
%include probe_references;
%page;
%include probe_seg_info;
%page;
%include probe_source_info;
%page;
%include runtime_symbol;
%page;
%include std_descriptor_types;


  end get_size_in_bits_;




		    inst_length_.pl1                10/24/88  1612.2rew 10/24/88  1342.0       26703



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



/****^  HISTORY COMMENTS:
  1) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

inst_length_:
  procedure (ip, special) returns (fixed bin);

  /* given a ptr to an instruction (ip) - return the number of words that must be
   moved to relocate the instruction.  Note special handling of an "xec" off
   pl1_operators

   Issue Unresolved - Seems to assume that all "xec" are xec7s of pl1_operators
   This may not be true for COBOL and for sure its false for ALM.  Does it need
   a "language_type" parameter?

*/

  dcl (
      ip			pointer,	/* to instruction */
      special		fixed bin
      )			parameter;/* if non-EIS, nonzero means special modifiers;
						   if EIS, then number of EIS-type descriptors */
  dcl pop			pointer;	/* to instruction in pl1 operators */
  dcl op_index		fixed bin;/* op code, used as index into op_mnemonic */

  dcl 1 instruction_overlay	based aligned,
				/* for picking out op code */
       2 tag		bit (3) unaligned,
       2 offset		fixed bin (14) unaligned,
       2 opcode		bit (10) unaligned;

  dcl pl1_operators_$operator_table
			external;


  dcl (addr, addrel, fixed)	builtin;
				/* find out length of the instruction */
  op_index = fixed (ip -> instruction_overlay.opcode, 10, 0);
				/* get instruction_overlay.opcode */

  /* There is one degenerate case:  that of an xec of an eis instruction in the operators.
   The descriptors follow the xec, so its lenght must be adjusted.  */

  if op_mnemonic_$op_mnemonic (op_index).opcode = "xec " then do;
      pop = addrel (addr (pl1_operators_$operator_table), ip -> offset);
      op_index = fixed (pop -> instruction_overlay.opcode, 10, 0);
    end;

  special = op_mnemonic_$op_mnemonic (op_index).num_desc;
  return (op_mnemonic_$op_mnemonic (op_index).num_words);

%include op_mnemonic_format;

  end inst_length_;







		    ioa_util_.pl1                   10/24/88  1612.2rew 10/24/88  1340.3       86391



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



/****^  HISTORY COMMENTS:
  1) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

ioa_util_:
  proc (P_code);

  return;

  /* *	This procedure includes a small handful of entries for calling ioa_ in ways that ioa_
   *	itself doesn't support. In particular, it provides an equivalent to ioa_$ioa_switch
   *	which operates on a supplied string and IOCB pointer, and also part of an arglist,
   *	much like ioa_$general_rs. */

  dcl (
      P_string_ptr		pointer,
      P_string_lth		fixed bin (21),
      P_arg_list_ptr	pointer,
      P_first_arg		fixed bin,
      P_output_switch	pointer,
      P_output_str		char (*) varying,
      P_code
      )			parameter;

  dcl (new_arg_list_ptr, old_arg_list_ptr)
			pointer;
  dcl (new_argno, new_arg_count)
			fixed bin;
  dcl (old_argno, old_arg_count)
			fixed bin;
  dcl output_lth		fixed bin (21);
  dcl output_switch		pointer;
  dcl ioa_entry		entry variable options (variable);
  dcl ioa_str_ptr		pointer;
  dcl (pad_sw, nl_sw, iocb_sw)
			bit (1) aligned;
  dcl code		fixed bin (35);
  dcl based_fb35		fixed bin (35) based;
  dcl based_string_ptr	pointer;
  dcl based_string_lth	fixed bin (21);
  dcl based_string		char (based_string_lth)
			based (based_string_ptr);

  dcl 1 new_arg_list	aligned based (new_arg_list_ptr),
       2 header,
       (
        3 twice_nargs,
        3 code,
        3 twice_ndescs,
        3 pad1
        )			fixed bin (17) unaligned,
       2 arg_ptr		(new_arg_count) pointer aligned,
       2 desc_ptr		(new_arg_count) pointer aligned;

  dcl 1 old_arg_list	aligned based (old_arg_list_ptr),
       2 header,
       (
        3 twice_nargs,
        3 code,
        3 twice_ndescs,
        3 pad1
        )			fixed bin (17) unaligned,
       2 arg_ptr		(old_arg_count) pointer aligned,
       2 desc_ptr		(old_arg_count) pointer aligned;

  dcl 1 descriptor		aligned based,
       2 version_2		bit (1) unaligned,
				/* should be "1"b */
       2 type		fixed bin (6) unsigned unaligned,
				/* see std_descriptor_types.incl.pl1 for a list */
       2 packed		bit (1) unaligned,
       2 dimensions		fixed bin (4) unsigned unaligned,
       2 size		fixed bin (24) unsigned unaligned;

  dcl 1 arith_descriptor	aligned based,
       2 version_2		bit (1) unaligned,
       2 type		fixed bin (6) unsigned unaligned,
       2 packed		bit (1) unaligned,
       2 dimensions		fixed bin (4) unsigned unaligned,
       2 scale		fixed bin (11) unaligned,
       2 precision		fixed bin (11) unaligned;

  dcl 1 ptr_desc		aligned like arith_descriptor;
  dcl 1 ioa_str_desc	aligned like descriptor;

  dcl ioa_$ioa_switch	entry options (variable);
  dcl ioa_$ioa_switch_nnl	entry options (variable);
  dcl ioa_$general_rs	entry (pointer, fixed bin, fixed bin, char (*),
			fixed bin (21), bit (1) aligned,
			bit (1) aligned);
  dcl cu_$generate_call	entry (entry, pointer);
  dcl cu_$grow_stack_frame	entry (fixed bin (18), ptr, fixed bin (35));

  dcl iox_$user_output	pointer external static;

  dcl ioa_error		condition;

  dcl (addr, currentsize, divide, maxlength, null, substr, unspec)
			builtin;

  /*  */

ioa_util_$switch_with_string:
  entry (P_string_ptr, P_string_lth, P_arg_list_ptr, P_first_arg,
       P_output_switch);

  pad_sw = "0"b;
  nl_sw = "0"b;
  iocb_sw = "1"b;
  goto COMMON;


ioa_util_$switch_nnl_with_string:
  entry (P_string_ptr, P_string_lth, P_arg_list_ptr, P_first_arg,
       P_output_switch);

  pad_sw = "0"b;
  nl_sw = "1"b;
  iocb_sw = "1"b;
  goto COMMON;


ioa_util_$rs_with_string:
  entry (P_string_ptr, P_string_lth, P_arg_list_ptr, P_first_arg,
       P_output_str);

  pad_sw = "0"b;
  nl_sw = "0"b;
  iocb_sw = "0"b;
  goto COMMON;


ioa_util_$rsnnl_with_string:
  entry (P_string_ptr, P_string_lth, P_arg_list_ptr, P_first_arg,
       P_output_str);

  pad_sw = "0"b;
  nl_sw = "1"b;
  iocb_sw = "0"b;
  goto COMMON;


  /* *	First, figure out how big the new arg list will be, make room
   *	for it, and fill in the header */


COMMON:
  old_arg_list_ptr = P_arg_list_ptr;	/* find out about arg list we've been given */
  old_arg_count = divide (old_arg_list.twice_nargs, 2, 17, 0);

  new_arg_count = old_arg_count - P_first_arg + 1;
				/* new_arg_count is now exactly number of args as */
				/* are in desired portion of old_arg_list */

  if iocb_sw
    then /* if we have to put an IOCB pointer at the beginning, */
         new_arg_count = new_arg_count + 1;
				/* make room for one more argument */
  new_arg_count = new_arg_count + 1;	/* also increment it to make room for the ioa_ string */

  call cu_$grow_stack_frame (currentsize (new_arg_list), new_arg_list_ptr,
       code);
  if code ^= 0
    then /* make room for the new arg list, then fill it in */
         signal ioa_error;		/* a reasonablke thing to do, I think */

  new_arg_list.twice_nargs = 2 * new_arg_count;
				/* fill in new arg list header */
  new_arg_list.twice_ndescs = 2 * new_arg_count;
  new_arg_list.code = 4;		/* Intersegment, external call type */
  new_arg_list.pad1 = 0;


  /* *	This next section of code constructs descriptors and sets various pointers
   *	which will be inserted into the newly created argument list */


  unspec (ioa_str_desc) = ""b;	/* construct descriptor for ioa_ control string */
  ioa_str_desc.version_2 = "1"b;
  ioa_str_desc.type = char_dtype;
  ioa_str_desc.packed = "0"b;
  ioa_str_desc.dimensions = 0;
  ioa_str_desc.size = P_string_lth;	/* length of ioa_ control string */

  ioa_str_ptr = P_string_ptr;		/* pointer to input string */

  if iocb_sw then do;		/* construct various stuff to describe the output IOCB */
      if P_output_switch ^= null ()
        then /* null IOCB pointer means user_output, of course */
	   output_switch = P_output_switch;
        else output_switch = iox_$user_output;

      unspec (ptr_desc) = ""b;
      ptr_desc.version_2 = "1"b;	/* construct the descriptor for the IOCB pointer */
      ptr_desc.type = pointer_dtype;
      ptr_desc.packed = "0"b;
      ptr_desc.dimensions = 0;
      ptr_desc.scale = 0;		/* I don't know what scale and precision should be for */
      ptr_desc.precision = 72;	/* a pointer, but hopefully my callee won't, either. */
    end;


  /* *	Now, fill in the argument pointers and descriptors in the new argument
   *	list -- for the entries which are designed to do output, an IOCB pointer
   *	must be inserted at the beginning */


  new_argno = 1;			/* the current argno in the new arg list */

  if iocb_sw then do;
      new_arg_list.arg_ptr (new_argno) = addr (output_switch);
      new_arg_list.desc_ptr (new_argno) = addr (ptr_desc);
      new_argno = new_argno + 1;	/* so we'll start packing it at the right arg */
    end;

  new_arg_list.arg_ptr (new_argno) = ioa_str_ptr;
  new_arg_list.desc_ptr (new_argno) = addr (ioa_str_desc);
  new_argno = new_argno + 1;		/* now it's the index of the first arg to be copied into */

  old_argno = P_first_arg;		/* now copy useful part of old arg list */

  do new_argno = new_argno to new_arg_count;
				/* now go through all the ones that are left */
    new_arg_list.arg_ptr (new_argno) = old_arg_list.arg_ptr (old_argno);
    new_arg_list.desc_ptr (new_argno) = old_arg_list.desc_ptr (old_argno);
    old_argno = old_argno + 1;	/* point at the next arg, and loop again */
  end;


  /* *	Now, we can finally call ioa_. We call ioa_$general_rs if we can, otherwise
   *	we have to call ioa_$ioa_switch or ioa_$ioa_switch_nnl */


  if iocb_sw then do;		/* must call ioa_$ioa_switch directly, since there is nothing */
      if nl_sw
        then /* like ioa_$general_rs for doing output */
	   ioa_entry = ioa_$ioa_switch;
        else ioa_entry = ioa_$ioa_switch_nnl;
      call cu_$generate_call (ioa_entry, new_arg_list_ptr);
				/* DO IT */
    end;

    else do;			/* for this, we perform complicated machinations */
      based_string_ptr = addr (substr (P_output_str, 1, 1));
				/* must fake a char (*) argument for ioa_$general_rs */
      based_string_lth = maxlength (P_output_str);

      call ioa_$general_rs (new_arg_list_ptr,
	 1,			/* note that control string is always first arg in new arglist */
	 2,			/* and that first ioa_ arg is always number 2 */
	 based_string, output_lth, pad_sw, nl_sw);

      addr (P_output_str) -> based_fb35 = output_lth;
				/* KLUDGE to stick length back into varying string */
    end;

  return;				/* Goddamn, am I glad this is finally over */

  /*  */

%include std_descriptor_types;

  end;				/* ioa_util_ external procedure */




		    print_instructions_.pl1         10/24/88  1612.3rew 10/24/88  1340.3      156087



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



/****^  HISTORY COMMENTS:
  1) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

print_instructions_:
  proc (P_data_ptr, P_count, P_switch);

  /* prints P_count instructions starting at P_data_ptr on switch P_switch

   an instruction may be several words long

   James R. Davis 20 May 79
   Modified 21 Sept 79 to print address and raw words, too. JRD

   FEATURES that it would be nice to put in someday:
   decoding the special tags (used by puls1, puls2 s9bd, s6bd, s4bd,
   sbd,stba,stbq,stca and stcq)

   showing either the address of the operand (for a tra, or pl1_operators_ ref) or i$
   the contents of the word addressed - one or two words, depending
*/
  /* Fixed not to print more than P_count words despite multi-word instructions 09/01/83 S. Herbst */

  dcl P_data_ptr		ptr parameter;
				/* input: to probe_info structure */
  dcl P_count		fixed bin parameter;
				/* input: number of instructions to print */
  dcl P_switch		ptr aligned parameter;
				/* input: to switch */

  /* the following variables are used globally throughout - but not altered */
  dcl ip			ptr;	/* to current instruction's first word */
  dcl oswitch		ptr;	/* copy of P_switch */
  dcl op_index		fixed bin;/* the op code, an index into instruction info tables */
  dcl op_code		char (6) aligned;
				/* mnemonic name of op_index */
  dcl number_of_words	fixed bin;/* number of words in current instruction */
  dcl COLUMN_SPACING	fixed bin internal static
			options (constant) init (8);
				/* bewteen op_code and address */

  dcl (addrel, char, divide, fixed, hbound, lbound, rel)
			builtin;
  dcl instruction_count	fixed bin;/*  number of the current instruction */

  dcl (
      ioa_$rsnnl,
      ioa_$ioa_switch,
      ioa_$ioa_switch_nnl
      )			entry options (variable);


  dcl 1 instr_pr		aligned based (ip),
       2 address		unal,
        3 pr		fixed bin (3) unsigned unal,
        3 offset		fixed bin (14) unal,
       2 opcode		fixed bin (10) unsigned unal,
       2 inhibit		bit (1) unal,
       2 use_pr		bit (1) unal,
       2 tag		fixed bin (6) unsigned unal;

  dcl 1 instr		aligned based (ip),
       2 address		unal,
        3 offset		fixed bin (17),
       2 opcode		fixed bin (10) unsigned unal,
       2 inhibit		bit (1) unal,
       2 use_pr		bit (1) unal,
       2 tag		fixed bin (6) unsigned unal;

%include op_mnemonic_format;

  ip = P_data_ptr;
  oswitch = P_switch;

  do instruction_count = 1 to P_count;

    op_index = ip -> instr.opcode;
    op_code = op_mnemonic_$op_mnemonic (op_index).opcode;
    number_of_words = op_mnemonic_$op_mnemonic (op_index).num_words;

    if number_of_words > 1		/* must be EIS */
      then call disassemble_eis;
    else if is_repeat_instr (op_code)
      then call disassemble_repeat;
    else call disassemble_normal;

    ip = addrel (ip, number_of_words);

    instruction_count = instruction_count + number_of_words - 1;
  end;				/*  loop over N instructions */
  return;


disassemble_normal:
  proc;

  call print_addr_and_raw (ip);
  call ioa_$ioa_switch (oswitch, "   ^a^vt^a^[,^a^]",
       op_code,
       COLUMN_SPACING,
       address_field (ip, (ip -> instr.use_pr)),
       instr.tag ^= 0, tag_field ((instr.tag)));

  /* add code to print what is pointed to */
  end disassemble_normal;




disassemble_repeat:
  proc;


  call print_addr_and_raw (ip);
  call ioa_$ioa_switch (oswitch,
       "   ^a^[a^]^[b^]^[^vt^d^;x^vt^s^],^d^[,tze^]^,tmi^]^[,tpl^]^[,trc^]^[tnc^]",
       op_code,
       ip -> repeat_instr.a,
       ip -> repeat_instr.b,
       ip -> repeat_instr.use_tally, COLUMN_SPACING, ip -> repeat_instr.tally,
       ip -> repeat_instr.delta,
       ip -> repeat_instr.zero_on,
       ip -> repeat_instr.zero_off,
       ip -> repeat_instr.neg_on,
       ip -> repeat_instr.neg_off,
       ip -> repeat_instr.carry_on,	/* CSNY ? */
       ip -> repeat_instr.carry_off);

  dcl 1 repeat_instr	aligned based,
       2 tally		fixed bin (8) unsigned unal,
       2 a		bit (1) unal,
       2 b		bit (1) unal,
       2 use_tally		bit (1) unal,
       2 term_conditions	unal,
        3 zero_on		bit (1) unal,
        3 zero_off		bit (1) unal,
        3 neg_on		bit (1) unal,
        3 neg_off		bit (1) unal,
        3 carry_on		bit (1) unal,
        3 carry_off		bit (1) unal,
       2 process_overflow	bit (1) unal,
       2 opcode		fixed bin (10) unsigned unal,
       2 pad		bit (2) unal,
       2 delta		fixed bin (6) unsigned unal;

  end disassemble_repeat;

disassemble_eis:
  proc;

  dcl data_type		fixed bin;
  dcl ndesc		fixed bin;/* how many descriptors  it has */
  dcl (
      ALPHA_TYPE		init (0),
      BIT_TYPE		init (1),
      OTHER_TYPE		init (2)
      )			fixed bin internal static options (constant);
  dcl dp			ptr;	/* to a descriptor */
  dcl descx		fixed bin;/* index as we step over descriptors */

  dcl 1 eis_instr_all_descs	aligned based (ip),
       2 pad1		bit (2) unal,
       2 mf3		unal like mod_factor,
       2 enablefault	bit (1) unal,
       2 pad2		bit (1) unal,
       2 mf2		unal like mod_factor,
       2 pad3		bit (11) unal,
       2 mf1		unal like mod_factor;

  dcl 1 mod_factor		aligned based,
       2 ext_base		bit (1) unal,
				/* there is a pr number in address */
       2 length_in_reg	bit (1) unal,
				/* the length of the operand is in a reg */
       2 indirect_descriptor	bit (1) unal,
				/* the descriptor is an indirect ptr */
       2 tag		fixed bin (4) unsigned unal;

  dcl 1 eis_args_info	(3) aligned like mod_factor;

  ndesc = op_mnemonic_$op_mnemonic (op_index).num_desc;
  data_type = op_mnemonic_$op_mnemonic (op_index).dtype;
  if data_type > OTHER_TYPE
    then data_type = OTHER_TYPE;

  eis_args_info (1) = eis_instr_all_descs.mf1;
  eis_args_info (2) = eis_instr_all_descs.mf2;
  eis_args_info (3) = eis_instr_all_descs.mf3;

  call print_addr_and_raw (ip);
  call print_instr_word;

  dp = ip;
  do descx = 1 to number_of_words - 1;
    dp = addrel (dp, 1);
    call print_addr_and_raw (dp);

    /* CASE on what kind of descriptor we have */

    if descx > ndesc		/* it is an arg, not a desc */
      then call print_ind_desc (dp, eis_args_info (descx));
    else if eis_args_info (descx).indirect_descriptor
      then call print_ind_desc (dp, eis_args_info (descx));
    else if desc_is_obscure (op_code, descx)
				/* abnormal type, such as MOP ptr of mvne */
      then call print_obscure_desc (dp, eis_args_info (descx));
    else if data_type = ALPHA_TYPE
      then call print_alpha_desc (dp, eis_args_info (descx));
    else if data_type = BIT_TYPE
      then call print_bit_desc (dp, eis_args_info (descx));
    else call print_numeric_desc (dp, eis_args_info (descx));
  end;				/* of loop over all descriptors */


print_instr_word:
  proc;

  dcl descx		fixed bin;
  dcl need_comma		bit (1) aligned;
  dcl line		char (256) varying;
				/* holds output as built */
  dcl HT			char (1) internal static options (constant)
			init ("	");

  dcl 1 eis_alpha_fill	based (ip),
       2 field		bit (9) unal,
       2 pad		bit (27) unal;

  dcl 1 eis_bit_fill	based (ip),
       2 field		bit (1) unal,
       2 pad		bit (4) unal,
       2 bolr		fixed bin (4) unsigned unal,
       2 pad1		bit (27) unal;

  dcl 1 eis_numeric_fill	aligned based (dp),
       2 pad		bit (10) unal,
       2 round		bit (1) unal,
       2 pad2		bit (25) unal;

  dcl bool_word		(0:15) char (6) internal static
			options (constant) init
			("clear", "and", "02", "03", "04", "05", "xor",
			"or",
			"10", "11", "12", "13", "invert", "15", "nand",
			"set");

  line = op_code;
  line = line || HT;

  do descx = 1 to ndesc;
    line = line || "(";
    need_comma = "0"b;

    if eis_args_info (descx).ext_base
      then call add_option ("pr");
    if eis_args_info (descx).length_in_reg
      then call add_option ("rl");
    if eis_args_info (descx).indirect_descriptor
      then call add_option ("id");
    if eis_args_info (descx).tag ^= 0
      then call add_option (tag_field ((eis_args_info (descx).tag)));
    line = line || ")";

    if descx < ndesc		/* more to come */
      then line = line || ",";
  end;				/* of loop over all MFs */

  if eis_instr_all_descs.enablefault
    then line = line || ",enablefault";

  if data_type = ALPHA_TYPE
    then do;
      if has_fill (op_code)
        then do;
	line = line || ",fill(";
	line = line || octalize (eis_alpha_fill.field);
	line = line || ")";
        end;
      else if has_mask (op_code)
        then do;
	line = line || ",mask(";
	line = line || octalize (eis_alpha_fill.field);
	line = line || ")";
        end;			/* mask */
    end;				/* ALPHA type */
  else if data_type = BIT_TYPE
    then do;
      line = line || ", fill (";
      line = line || char (eis_bit_fill.field);
      line = line || ")";

      if has_boolean (op_code) then do;
	line = line || ", bool (";
	line = line || bool_word (eis_bit_fill.bolr);
	line = line || ")";
        end;			/* bolr hacking */
    end;				/* BIT type */
  else do;
    if eis_numeric_fill.round
      then line = line || ", round";
  end;				/* NUMERIC */

  call ioa_$ioa_switch (oswitch, "   ^a", line);
  return;

add_option:
  proc (c2);


  dcl c2			char (2) aligned parameter;

  if need_comma			/* we have previously written in this MF, need a separator */
    then line = line || ",";
  need_comma = "1"b;
  line = line || c2;
  end add_option;


octalize:
  proc (b9) returns (char (3) aligned);


  dcl c3			char (3) aligned;
  dcl b9			bit (9) parameter;

  call ioa_$rsnnl ("^.3b", c3, (0), b9);
  return (c3);
  end octalize;


  end print_instr_word;


  /* here are internal procedures to print the various kinds of descriptors-
   obscure (which isn't nearly as clever as it ought to be)
   indirect
   alphanumeric
   bit
   numeric

*/

print_obscure_desc:
  proc (descp, mf);

  dcl descp		ptr parameter;
  dcl 1 mf		aligned parameter like mod_factor;

  call ioa_$ioa_switch (oswitch, "   too obscure a descriptor too decode");
  end print_obscure_desc;


print_ind_desc:
  proc (descp, mf);


  dcl descp		ptr aligned parameter;
  dcl 1 mf		aligned parameter like mod_factor;

  call ioa_$ioa_switch (oswitch, "   arg^vt^a^[,^a^]",
       COLUMN_SPACING,
       address_field (descp, (mf.ext_base)),
       descp -> instr.tag ^= 0, tag_field ((descp -> instr.tag)));
  end print_ind_desc;

print_alpha_desc:
  proc (descp, mf);


  dcl descp		ptr aligned parameter;
  dcl 1 mf		aligned parameter like mod_factor;

  dcl alpha_types		(0:3) char (1) internal static
			options (constant) init ("9", "6", "4", "?");
  dcl NINE_BIT		fixed bin internal static
			options (constant) init (0);

  dcl 1 alpha_desc		aligned based (descp),
       2 y		bit (18) unal,
       2 char_no		fixed bin (3) unsigned unal,
       2 type_code		fixed bin (2) unsigned unal,
       2 pad		bit (1) unal,
       2 length		fixed bin (12) unsigned unal;

  call ioa_$ioa_switch (oswitch,
       "   desc^aa^vt^a(^[^d^s^;^s^d^]),^[^a^s^;^s^d^]",
       alpha_types (type_code),
       COLUMN_SPACING,
       address_field (descp, (mf.ext_base)),
       alpha_desc.type_code = NINE_BIT, divide (char_no, 2, 17, 0), char_no,
       mf.length_in_reg, tag_field ((alpha_desc.length)), alpha_desc.length);
  end print_alpha_desc;


print_bit_desc:
  proc (descp, mf);


  dcl descp		ptr aligned parameter;
  dcl 1 mf		aligned parameter like mod_factor;

  dcl 1 bit_desc		aligned based (descp),
       2 y		bit (18) unal,
       2 char_no		fixed bin (2) unsigned unal,
       2 bit_no		fixed bin (4) unsigned unal,
       2 length		fixed bin (12) unsigned unal;

  call ioa_$ioa_switch (oswitch, "   descb^vt^a(^d),^[^a^s^;^s^d^]",
       COLUMN_SPACING,
       address_field (descp, (mf.ext_base)),
       char_no * 9 + bit_no,
       mf.length_in_reg,
       tag_field ((bit_desc.length)),
       bit_desc.length);
  end print_bit_desc;


print_numeric_desc:
  proc (descp, mf);


  dcl descp		ptr aligned parameter;
				/* aren't you getting bored? */
  dcl 1 mf		aligned parameter like mod_factor;

  dcl sign_name		(0:3) char (2) aligned internal static
			options (constant)
			init ("fl", "ls", "ts", "ns");

  dcl 1 numeric_desc	aligned based (descp),
       2 y		bit (18) unal,
       2 char_no		fixed bin (3) unsigned unal,
       2 type4		bit (1) unal,
       2 sign_type		fixed bin (2) unsigned unal,
       2 scale_factor	fixed bin (5) unal,
       2 length		fixed bin (6) unsigned unal;

  call ioa_$ioa_switch (oswitch,
       "   desc^[4^;9^]^a^vt^a(^[^d^s^;^s^d^]),^[^a^s^;^s^d^]^[,^d^]",
       numeric_desc.type4,		/* which type ? */
       sign_name (numeric_desc.sign_type),
       COLUMN_SPACING,
       address_field (descp, (mf.ext_base)),
       type4, numeric_desc.length, divide (numeric_desc.length, 2, 17, 0),
       mf.length_in_reg, tag_field ((numeric_desc.length)),
       numeric_desc.length,
       scale_factor ^= 0, scale_factor);
  end print_numeric_desc;


desc_is_obscure:
  proc (op_name, desc_no) returns (bit (1) aligned);


  /* for certain ops, one of the descriptors will not be of the expected type */

  dcl op_name		char (6) aligned parameter;
  dcl desc_no		fixed bin parameter;
				/* input, which desc */

  return (
       (op_name = "btd" & desc_no = 1) |
       (op_name = "dtb" & desc_no = 2) |
       (op_name = "mvne" & desc_no = 2)
       );
  end desc_is_obscure;
  end disassemble_eis;


  /* miscellaneous useful things */


print_addr_and_raw:
  proc (p);


  dcl p			ptr parameter;
  dcl based_word		bit (36) aligned based (p);
  call ioa_$ioa_switch_nnl (oswitch, "    ^6o ^w",
       fixed (rel (p), 18, 0), based_word);
  end print_addr_and_raw;

address_field:
  proc (p, use_pr) returns (char (10) aligned);


  dcl p			ptr aligned parameter;
				/* to instruction */
  dcl use_pr		bit (1) aligned parameter;
				/* which format is it ? */
  dcl rs			char (9) aligned;
  call ioa_$rsnnl ("^[pr^d|^d^s^;^s^s^d^]", rs, (0),
       use_pr, p -> instr_pr.address.pr, p -> instr_pr.address.offset,
       p -> instr.address.offset);
  return (rs);

  end address_field;



tag_field:
  proc (tag) returns (char (3) aligned);


  /* this proc exists to isolate references to the modifier data base -
   hope to make it part of op_mnemonic some day */

  dcl tag			fixed bin parameter;

  if tag < lbound (modifier, 1) | tag > hbound (modifier, 1)
    then return ("bad");
    else return (modifier (tag));
  end tag_field;


  /* predicates on instruction types */

is_repeat_instr:
  proc (op_name) returns (bit (1) aligned);


  dcl op_name		char (6) aligned parameter;

  return (op_name = "rpd" | op_name = "rpl" | op_name = "rpt");

is_tra_instr:
  entry (op_name) returns (bit (1) aligned);

  return (
       op_name = "teo" | op_name = "teu" | op_name = "tmi"
       | op_name = "tmoz" | op_name = "tnc" |
       op_name = "tnz" | op_name = "tov" | op_name = "tpl"
       | op_name = "tpnz" | op_name = "tra" |
       op_name = "trc" | op_name = "trtf" | op_name = "trtm"
       | op_name = "tsp0" | op_name = "tsp1" |
       op_name = "tsp2" | op_name = "tsp3" | op_name = "tsp4"
       | op_name = "tsp5" | op_name = "tsp6" |
       op_name = "tsp7" | op_name = "tss" | op_name = "tsx0"
       | op_name = "tsx1" | op_name = "tsx2" |
       op_name = "tsx3" | op_name = "tsx4" | op_name = "tsx5"
       | op_name = "tsx6" | op_name = "tsx7" |
       op_name = "ttf" | op_name = "ttm" | op_name = "tze");

is_double_instr:
  entry (op_name) returns (bit (1) aligned);

  return (op_name = "adaq" | op_name = "adlaq" | op_name = "anaq"
       | op_name = "canaq" |
       op_name = "cmpaq" | op_name = "cnaaq" |

  /* need all the df?? ops */

       op_name = "eaq" | op_name = "epaq" | op_name = "eraq"
       | op_name = "lcaq" | op_name = "ldaq" |
       op_name = "oraq" | op_name = "sbaq" | op_name = "sblaq"
       | op_name = "staq");


has_fill:
  entry (op_name) returns (bit (1) aligned);

  return (op_name = "cmpc" | op_name = "mlr" | op_name = "mvt");

has_boolean:
  entry (op_name) returns (bit (1) aligned);

  return (op_name = "csl" | op_name = "csr" | op_name = "sztl"
       | op_name = "sztr");

has_mask:
  entry (op_name) returns (bit (1) aligned);

  return (op_name = "scm");


  end;				/* is_XXXXX_instr */


  end print_instructions_;




		    probe.alm                       10/24/88  1612.3rew 10/24/88  1354.0       12519



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

" HISTORY COMMENTS:
"  1) change(88-10-18,WAAnderson), approve(88-10-18,MCR7952),
"     audit(88-10-18,JRGray), install(88-10-24,MR12.2-1184):
"     Probe source archive split. Part of C-Probe support.
"                                                      END HISTORY COMMENTS


"
"	This is a transfer vector whose purpose in life is to redirect calls
"	to entries in "probe" to their prober destinations. This is done because
"	the probe command and the probe breakpoint handler are now substantually
"	different, even though they are still both entrypoints in probe.
"
"	07/13/79 W. Olin Sibert
"

	entry	probe
	entry	pb
	entry	break

probe:	tra	probe_command_$probe_command_

pb:	tra	probe_command_$probe_command_

break:	tra	probe_break_handler_$break_type_1

	end




		    probe_announce_entry_.pl1       10/27/88  1244.0r w 10/27/88  1225.3       52290



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



/****^  HISTORY COMMENTS:
  1) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

probe_announce_entry_:
  proc (P_probe_info_ptr);

  /* *	This procedure is used by the probe command and the breakpoint halt request
   *	to announce why probe was entered, and what it all means. */

  /* Fixed halt message for already reset pause break 01/06/81 S. Herbst */
  /* Changed invocation banner to print full pathname 08/26/83 S. Herbst */

  dcl P_probe_info_ptr	pointer;

  dcl ilevel		fixed bin;
  dcl level_info		char (64) varying;
  dcl after_before_string	char (8);
  dcl block_name		char (256);
  dcl cond_name		char (32);

  dcl ioa_$ioa_switch	entry options (variable);
  dcl probe_block_name_	entry (ptr, ptr, bit (1) aligned)
			returns (char (256) varying);
  dcl probe_error_$malfunction
			entry options (variable);
  dcl probe_line_number_	entry (pointer, 1 aligned like source_info)
			returns (char (64));
  dcl probe_stack_trace_$condition_raised
			entry (ptr, ptr, char (32));
  dcl probe_stack_trace_$where_source_info
			entry (ptr, ptr, fixed bin, char (*));

  dcl BREAK_PLACE		(0:1) char (8) varying internal static
			options (constant) init ("after", "before");

  dcl (character, fixed, ltrim, rel, rtrim)
			builtin;
				/*  */
  probe_info_ptr = P_probe_info_ptr;

  call probe_stack_trace_$where_source_info (probe_info_ptr,
       probe_info.ptr_to_initial_source,
       ilevel, block_name);

  if ilevel >= 0 then do;		/* make a description of our frame, if any */
      level_info = "(level ";
      level_info = level_info || ltrim (rtrim (character (ilevel)));
      level_info = level_info || ")";
    end;

    else level_info = "(no active frame)";

  if probe_info.return_method = RETURN_TO_FRAME then do;
      if ^probe_static_info.brief_sw then do;
	if current_source.stmnt_map_entry_index >= 0
	  then
	       call ioa_$ioa_switch (probe_info.output_switch,
		  "^a exited at ^a ^a.",
		  block_name,
		  probe_line_number_ (probe_info_ptr, current_source),
		  level_info);
	  else call ioa_$ioa_switch (probe_info.output_switch,
		  "^a exited at offset ^o ^a.",
		  block_name,
		  fixed (rel (initial_source.instruction_ptr), 35, 0),
		  level_info);
        end;
    end;

  else if probe_info.return_method = RETURN_TO_CONDITION then do;
      call probe_stack_trace_$condition_raised (probe_info_ptr,
	 probe_info.ptr_to_initial_source, cond_name);
      if cond_name = ""
        then cond_name = "<<UNKNOWN>>";

      if current_source.stmnt_map_entry_index >= 0
        then
	   call ioa_$ioa_switch (probe_info.output_switch,
	        "Condition ^a raised at ^a of ^a ^a.",
	        cond_name,
	        probe_line_number_ (probe_info_ptr, current_source),
	        block_name,
	        level_info);
        else call ioa_$ioa_switch (probe_info.output_switch,
	        "Condition ^a raised at ^a|^o ^a.",
	        cond_name,
	        block_name,
	        fixed (rel (initial_source.instruction_ptr), 35, 0),
	        level_info);
    end;

  else if probe_info.return_method = RETURN_TO_CALLER then do;
      if ^probe_static_info.brief_sw then do;
	block_name =
	     probe_block_name_ (probe_info_ptr,
	     probe_info.ptr_to_initial_source,
	     "1"b /* long: full pathname */);
	call ioa_$ioa_switch (probe_info.output_switch, "Using ^a ^a.",
	     block_name,
	     level_info);
        end;
    end;

  else if probe_info.return_method = RETURN_TO_BREAK then do;

      if probe_info.break_slot_ptr -> break_slot.location = "0"b
        then /* pause, already reset */
	   after_before_string = "before";
        else after_before_string =
	        BREAK_PLACE (probe_info.break_slot_ptr -> break_slot.type);

      if probe_static_info.brief_sw
        then call ioa_$ioa_switch (probe_info.output_switch,
	        "^[<<^;>>^]^a ^a",
	        after_before_string = "before",
	        block_name,
	        probe_line_number_ (probe_info_ptr, initial_source));
        else call ioa_$ioa_switch (probe_info.output_switch,
	        "Stopped ^a ^a of ^a. ^a",
	        after_before_string,
	        probe_line_number_ (probe_info_ptr, initial_source),
	        block_name,
	        level_info);
    end;

  else call probe_error_$malfunction (probe_info_ptr, 0,
	  "Unusual return method ^d", probe_info.return_method);
  return;

  /*  */

  /*	INCLUDE FILES	*/

%include probe_info;

  /* ;;;;;;; */

%include probe_static_info;

  /* ;;;;;;; */

%include probe_source_info;

  /* ;;;;;;; */

%include probe_seg_info;

  /* ;;;;;;; */

%include probe_info_constants;

  /* ;;;;;;; */

%include probe_break_slot;

  /* ;;;;;;; */

%include stack_frame;

  end;				/* external procedure probe_announce_entry_ */




		    probe_array_bounds_.pl1         11/11/88  1554.4r w 11/11/88  1545.0       50580



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



/****^  HISTORY COMMENTS:
  1) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

probe_array_bounds_:
  proc
       (P_probe_info_ptr, P_symbolp, P_reference, P_source_info, P_address,
       P_code) returns ((2, 16) fixed bin (24));

  /* given all the inputs abouta reference, return an array filled
   with the upper and lower bounds of all its subscripts - so we
   ca do subscriptrange checking and fill in star extents

   Initially Coded by James R. Davis 22 Sept 78
   Modified: JRD 31 Oct 78 to return FORTRAN arrays reversed
   */

  dcl (
      P_probe_info_ptr	pointer,
      P_symbolp		ptr,	/* (input) to runtime_symbol node */
      P_address		ptr,	/* (input) for stu_, where symbols storage is */
      P_code		fixed bin (35)
      )			parameter;/* error code */
  dcl 1 P_reference		aligned like reference_node parameter;
				/* (input) info about reference */
  dcl 1 P_source_info	aligned like source_info parameter;
				/* (input) where declared; etc */

  dcl array_bounds		(2, 16) fixed bin (24);
				/* what we fill in for caller */
  dcl (low, high)		fixed bin (35);
  dcl code		fixed bin (35);
  dcl dims		fixed bin;/* how many dims ref has */
  dcl reverse		bit (1);	/* set to reverse bounds */
  dcl father_ptr		ptr;	/* to the runtime_block containing the symbol */
  dcl level		fixed bin;/* nesting of this variable */
  dcl array_bounds_x	fixed bin;

  dcl probe_et_$bad_value	fixed bin (35) external static;
  dcl probe_et_$recorded_message
			fixed bin (35) external static;

  dcl stu_$decode_runtime_value
			entry (fixed bin (35), ptr, ptr, ptr, ptr, ptr,
			fixed bin (35)) returns (fixed bin (35));
  dcl probe_error_$record	entry options (variable);
  dcl probe_error_$malfunction
			entry options (variable);

  dcl (
      LOW			init (1),
      HIGH		init (2)
      )			fixed bin internal static options (constant);

  dcl (addrel, fixed, hbound) builtin;
				/*  */

  probe_info_ptr = P_probe_info_ptr;
  P_code = 0;			/* until we find otherwise */

  dims = fixed (P_symbolp -> runtime_symbol.ndims, 6);
  if dims > hbound (array_bounds, 2)	/* PL/I  allows >15 dims, but we dont */
    then call probe_error_$malfunction ();

  /* get pointer to the runtime_block that symbol is part of, see if we are FORTRAN */

  level = fixed (P_symbolp -> runtime_symbol.level, 6, 0);
  if level <= 1
    then father_ptr = addrel (P_symbolp, P_symbolp -> runtime_symbol.father);
    else do;
      father_ptr = P_symbolp;		/* point at symbol node */
      do low = 1 to level;		/* trace back to the block */
        father_ptr = addrel (father_ptr, father_ptr -> runtime_symbol.father);
      end;
    end;
  reverse = father_ptr -> runtime_block.fortran;

  do array_bounds_x = 1 to dims;	/* reverse order for FORTRAN */

    low = P_symbolp -> runtime_symbol.bounds (array_bounds_x).lower;
    if low < 0 then do;
        low = stu_$decode_runtime_value (low,
	   P_source_info.block_ptr, P_source_info.stack_ptr,
	   (P_source_info.seg_info_ptr -> seg_info.linkage_ptr),
	   P_source_info.block_ptr, P_address, code);
        if code ^= 0 then do;
	  call probe_error_$record (probe_info_ptr, probe_et_$bad_value,
	       P_reference.name);
	  goto RECORDED_MESSAGE;
	end;
      end;

    high = P_symbolp -> runtime_symbol.bounds (array_bounds_x).upper;
    if high < 0 then do;
        high = stu_$decode_runtime_value (high,
	   P_source_info.block_ptr, P_source_info.stack_ptr,
	   (P_source_info.seg_info_ptr -> seg_info.linkage_ptr),
	   P_source_info.block_ptr, P_address, code);
        if code ^= 0 then do;
	  call probe_error_$record (probe_info_ptr, probe_et_$bad_value,
	       P_reference.name);
	  goto RECORDED_MESSAGE;
	end;
      end;

    if reverse then do;
        array_bounds (LOW, dims - array_bounds_x + 1) = low;
        array_bounds (HIGH, dims - array_bounds_x + 1) = high;
      end;
      else do;
        array_bounds (LOW, array_bounds_x) = low;
        array_bounds (HIGH, array_bounds_x) = high;
      end;

  end;
  return (array_bounds);


RECORDED_MESSAGE:			/* error exit */
  P_code = probe_et_$recorded_message;
  array_bounds (*, *) = -1;		/* return useless dimensions */
  return (array_bounds);

  /*  */

%include probe_info;

  /* ;;;;;;; */

%include probe_source_info;

  /* ;;;;;;; */

%include probe_seg_info;

  /* ;;;;;;; */

%include runtime_symbol;

  /* ;;;;;;; */

%include probe_tokens;

  /* ;;;;;;; */

%include probe_references;

  end;				/* probe_array_bounds_ external procedure */




		    probe_assign_value_.pl1         11/11/88  1554.4r w 11/11/88  1545.0      256239



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

/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

/****^  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):
     Extended pointer values assignment capabilities when language is PASCAL.
     Any pointer value is now allowed (variable or constant).  Removed
     references to pascal_symbol_node declaration.  They have been replaced by
     calls to runtime_symbol_info_.
  2) change(88-06-01,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added a test that checks for character string constants in C.  If we
     happen to encounter one, we confirm that the 'constant_token_ptr' is
     null and allow the assignment because the 'string' is actually an
     array of characters (as changed by probe_eval_).
  3) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
                                                   END HISTORY COMMENTS */

probe_assign_value_:
  proc (P_probe_info_ptr, P_target, P_source, P_code);

  /* assign the value designated by P_source to the storage designated by
   P_target.  Both are input only */

  /*   Written 11 Nov 78 By James R. Davis
   Modified 11 May 79 JRD to check for constant assignment.
   Modified June 79 WOS to convert to probe 4.0
   Modified 13 Nov 79 JRD to convert to assign_$computational and data_type_info */
  /* Fixed to catch size condition 08/20/81 S. Herbst */
  /* Modified June 83 JMAthane to add PASCAL values */
  /* Fixed "let pascal_string = constant_string" to pad target with blanks 07/27/83 S. Herbst */
  /* Changed for new probe_increment_indices_ calling sequence 08/02/83 Olin Sibert */
  /* Fixed to work on arrays, cross-sections and structures 08/23/83 S. Herbst */
  /* Added version string to runtime_type_info structure 10/06/83 S. Herbst */
  /* Changed to call get_size_in_bits_$structure with ref_ptr, handle var extents 06/05/84 S. Herbst */
  /* Fixed to compute addresses correctly for based cross-sections 06/06/84 S. Herbst */
  /* Extended pointer values assignment possibilities in Pascal.
   Removed references to pascal_symbol_node declaration.
   JMAthane June 85 	*/

  dcl (
      P_probe_info_ptr	pointer,
      P_code		fixed bin (35)
      )			parameter;

  dcl 1 P_target		aligned like reference_node parameter;
  dcl 1 P_source		aligned like reference_node parameter;

  dcl BASED_CLASS		bit (4) unaligned int static
			options (constant) init ("0011"b);

  dcl (
      1 source,
      1 target
      )			aligned like computational_data;

  dcl (target_indices, source_indices)
			(16) fixed bin;
  dcl (target_invert, source_invert)
			bit (1) aligned;
  dcl (target_p, source_p)	ptr;
  dcl done		bit (1) aligned init ("0"b);
  dcl code		fixed bin (35);

  dcl 1 subscripts		aligned based like reference_subscripts;

  /* FORTRAN allows up to 7 dims, PL/I allows more than 16 I think, but 16 is our maximum */

  dcl (
      probe_et_$bad_assign,
      probe_et_$bad_section,
      probe_et_$constant_target,
      probe_et_$no_address,
      probe_et_$recorded_message,
      probe_et_$c_string_assign,
      probe_et_$size
      )			fixed bin (35) external static;

  dcl probe_error_$record	entry options (variable);
  dcl get_size_in_bits_	entry (fixed bin, fixed bin (35), bit (1))
			returns (fixed bin);
  dcl get_size_in_bits_$structure
			entry (ptr) returns (fixed bin);
  dcl probe_increment_indices_
			entry (bit (1) aligned, (*) fixed bin,
			(2, *) fixed bin (24),
			fixed bin, bit (1) aligned, bit (1) aligned);
  dcl probe_pascal_$real_type entry (fixed bin (35), ptr, fixed bin (35), ptr)
			;
  dcl assign_$computational_	entry (ptr, ptr, fixed bin (35));
				/* converts computational types */
  dcl area_assign_		entry (pointer, pointer);
				/* assigns one area to another */
  dcl stu_$get_runtime_address
			entry (ptr, ptr, ptr, ptr, ptr, ptr, ptr)
			returns (ptr);
  dcl stu_$offset_to_pointer	entry (ptr, ptr, ptr, ptr, ptr, ptr)
			returns (ptr);
  dcl stu_$pointer_to_offset	entry (ptr, ptr, ptr, ptr, ptr, ptr)
			returns (offset);
				/* used to convert on based of default area */

  dcl (addr, baseno, binary, copy, divide, null, nullo, pointer, string,
      substr, unspec)	builtin;

  dcl conversion		condition;
				/* \014 */
  probe_info_ptr = P_probe_info_ptr;

  if P_target.flags.constant & ^P_target.flags.pseudo_var then do;
				/* "let 7 = 14", eh? */
      if (probe_info.language_type = C_lang_type &
	 P_target.type = char_dtype & P_target.precision > 1)
        then do;
	if (P_source.type ^= char_dtype & ^P_source.flags.constant)
	  then
	       code = probe_et_$c_string_assign;
	else if ^P_target.flags.c_ptr_to_char
	     & P_target.constant_token_ptr = null () then do;
	    begin;
	      dcl based_str		    char (256) based;
	      dcl the_null_byte	    char (1)
				    based (addr (zero_value));
	      dcl zero_value	    fixed bin (9) unsigned init (0);
	      substr (P_target.address_ptr -> based_str, 1,
		 P_source.precision) =
		 substr (P_source.address_ptr -> based_str, 1,
		 P_source.precision);
	      substr (P_target.address_ptr -> based_str,
		 P_source.precision + 1, 1) =
		 the_null_byte;
	      return;
	    end;
	  end;
	else do;
	  call probe_error_$record (probe_info_ptr, 0,
	       "Cannot assign a string to a char pointer.");
	  goto RECORDED_MESSAGE;
	end;
        end;
        else code = probe_et_$constant_target;
      goto SOME_ERROR;
    end;

  if ^P_target.cross_section then do;
      if P_source.cross_section then do;/* cant assign xsection to scalar */
	code = probe_et_$bad_section;
	goto SOME_ERROR;
        end;

      if P_target.address_ptr = null () then do;
				/* no place to assign to */
	call probe_error_$record (probe_info_ptr, probe_et_$no_address,
	     P_target.name);
	goto RECORDED_MESSAGE;
        end;

      call assign_reference ();
    end;
    else do;			/* assigning to a xsection */

      target_indices = P_target.subscript_ptr -> subscripts.value (1, *);
				/* set to low bound */
      target_p = P_target.address_ptr;
      if P_target.symbol_ptr ^= null
        then
	   if P_target.symbol_ptr -> runtime_symbol.class = BASED_CLASS
	     then
		target_p = null;	/* let stu_ compute the based address */
      target_invert =
	 P_target.source_info_ptr -> source_info.seg_info_ptr
	 -> seg_info.language_type
	 = FORTRAN_lang_type;

      source_indices = P_source.subscript_ptr -> subscripts.value (1, *);
				/* set to low bound */
      source_p = P_source.address_ptr;
      if P_source.symbol_ptr ^= null
        then
	   if P_source.symbol_ptr -> runtime_symbol.class = BASED_CLASS
	     then
		source_p = null;	/* let stu_ compute the based address */
      source_invert =
	 P_source.source_info_ptr -> source_info.seg_info_ptr
	 -> seg_info.language_type
	 = FORTRAN_lang_type;

      do while (^done);

        P_target.address_ptr =
	   stu_$get_runtime_address (P_target.source_info_ptr
	   -> source_info.block_ptr,
	   P_target.symbol_ptr,
	   P_target.source_info_ptr -> source_info.stack_ptr,
	   (P_target.source_info_ptr -> source_info.seg_info_ptr
	   -> seg_info.linkage_ptr),
	   P_target.source_info_ptr -> source_info.block_ptr,
	   target_p,
	   addr (target_indices));
        if P_target.address_ptr = null () then do;
	  call probe_error_$record (probe_info_ptr, probe_et_$no_address,
	       P_target.name);
	  goto RECORDED_MESSAGE;
	end;

        /* do the same with source if not a constant */
        if P_source.symbol_ptr ^= null
	then P_source.address_ptr = stu_$get_runtime_address
		(P_source.source_info_ptr -> source_info.block_ptr,
		P_source.symbol_ptr,
		P_source.source_info_ptr -> source_info.stack_ptr,
		(P_source.source_info_ptr -> source_info.seg_info_ptr
		-> seg_info.linkage_ptr),
		P_source.source_info_ptr -> source_info.block_ptr,
		source_p,
		addr (source_indices));
        call assign_reference ();
        call probe_increment_indices_ (target_invert, target_indices,
	   P_target.subscript_ptr -> subscripts.value,
	   P_target.subscript_ptr -> subscripts.number,
	   done, ("0"b));

        if P_source.cross_section
	then
	     call probe_increment_indices_ (source_invert, source_indices,
		P_source.subscript_ptr -> subscripts.value,
		P_source.subscript_ptr -> subscripts.number,
		done, ("0"b));

      end;			/* of cross-section assign loop */
    end;				/* of cross-section code */

  P_code = 0;			/* all done, successfully */
  return;


RECORDED_MESSAGE:
  code = probe_et_$recorded_message;
  goto SOME_ERROR;


SOME_ERROR:
  P_code = code;
  return;


bad_assignment:
  call probe_error_$record (probe_info_ptr, probe_et_$bad_assign,
       P_source.name, P_target.name);
  goto RECORDED_MESSAGE;

  /* \014 */

assign_reference:
  procedure ();

  dcl 1 temp		aligned like reference_node;


  dcl based_ptr		pointer aligned based;
				/* overlays for various data types */
  dcl based_packed_ptr	pointer unaligned based;
  dcl based_offset		offset based;
  dcl based_label		label based;
  dcl based_entry		entry based;
  dcl based_file		file based;

  dcl 1 label_var		aligned,	/* internal representation of label */
       2 place		pointer,	/* location of label */
       2 frame		pointer;	/* stack frame containing invocation */

  dcl 1 entry_var		aligned like label_var;

  dcl gen			pointer;	/* temporary for generation of offset */
  dcl p			pointer;	/* temporary */

  dcl (source_len, source_size, target_len, target_size)
			fixed bin;
  dcl target_object		bit (target_size)
			based (P_target.address_ptr) unal;
  dcl source_object		bit (source_size)
			based (P_source.address_ptr) unal;
  dcl target_string		char (target_len) based (P_target.address_ptr);
  dcl source_string		char (source_len) based (P_source.address_ptr);
  dcl (target_real_type, source_real_type)
			fixed bin (35);
  dcl (target_real_type_ptr, source_real_type_ptr)
			ptr;
  dcl 1 target_type_type_info like runtime_type_info;
  dcl 1 source_type_type_info like runtime_type_info;
				/* \014                                                      */

  temp.argument_list, target_real_type_ptr, source_real_type_ptr = null;
  on conversion go to bad_assignment;	/* catch error */
  on size
    begin;
    code = probe_et_$size;
    go to SOME_ERROR;
  end;

  if probe_info.language_type = PASCAL_lang_type then do;
      if P_target.source_info_ptr ^= null
        then
	   if baseno (P_target.address_ptr)
	        = baseno (P_target.source_info_ptr -> source_info.entry_ptr)
	     then do;
	       code = probe_et_$constant_target;
	       go to SOME_ERROR;
	     end;
      call probe_pascal_$real_type (P_target.type, P_target.type_ptr,
	 target_real_type, target_real_type_ptr);
      call probe_pascal_$real_type (P_source.type, P_source.type_ptr,
	 source_real_type, source_real_type_ptr);
    end;
    else do;
      target_real_type = P_target.type;
      target_real_type_ptr = P_target.type_ptr;
      source_real_type = P_source.type;
      source_real_type_ptr = P_source.type_ptr;
    end;


  if source_real_type_ptr ^= null then do;
      source_type_type_info.version = RUNTIME_TYPE_INFO_VERSION_1;
      call runtime_symbol_info_$type (source_real_type_ptr,
	 addr (source_type_type_info), code);
      if code ^= 0
        then go to bad_assignment;
    end;
  if target_real_type_ptr ^= null then do;
      target_type_type_info.version = RUNTIME_TYPE_INFO_VERSION_1;
      call runtime_symbol_info_$type (target_real_type_ptr,
	 addr (target_type_type_info), code);
      if code ^= 0
        then go to bad_assignment;
    end;

  if target_real_type = structure_dtype then do;
      if source_real_type ^= structure_dtype then do;
	call probe_error_$record (probe_info_ptr, 0,
	     "Can't assign a scalar to a structure.");
	go to RECORDED_MESSAGE;
        end;

      if ^same_format (P_target.symbol_ptr, P_source.symbol_ptr) then do;
	if target_real_type = structure_dtype
	  then call probe_error_$record (probe_info_ptr, 0,
		  "Structures have different format. Use the unspec builtin if necessary."
		  );
	  else call probe_error_$record (probe_info_ptr,
		  "Arrays have different dimension.");
	go to RECORDED_MESSAGE;
        end;

      call make_unspec (P_target);
      call make_unspec (P_source);

      call setup_str (P_target, target, (bit_dtype));
      call setup_str (P_source, source, (bit_dtype));

      call assign_$computational_ (addr (target), addr (source), code);
      if code ^= 0
        then go to SOME_ERROR;
    end;

  else if data_type_info_$info (target_real_type).computational then do;
      if ^data_type_info_$info (source_real_type).computational
        then goto bad_assignment;

      call setup_str (P_target, target, target_real_type);
      call setup_str (P_source, source, source_real_type);

      call assign_$computational_ (addr (target), addr (source), code);
      if code ^= 0
        then goto SOME_ERROR;
    end;				/* computational */

  else if target_real_type = pointer_dtype then do;
      if (source_real_type = pascal_user_defined_type_instance_dtype
	 & source_type_type_info.type = pascal_typed_pointer_type_dtype)
	 | source_real_type = pointer_dtype
				/* another pointer */
        then if P_source.packed	/* is it a packed pointer */
	     then p = P_source.address_ptr -> based_packed_ptr;
	     else p = P_source.address_ptr -> based_ptr;
      else if source_real_type = offset_dtype /* offset */
        then do;
	gen = P_source.source_info_ptr;
				/* to avoid typing */
	p = stu_$offset_to_pointer (gen -> source_info.block_ptr,
	     P_source.symbol_ptr, P_source.address_ptr,
	     gen -> source_info.stack_ptr,
	     (gen -> source_info.seg_info_ptr -> seg_info.linkage_ptr),
	     gen -> source_info.block_ptr);
				/* convert offset using default area */
	if p = null & P_source.address_ptr -> based_offset ^= nullo
	  then go to bad_assignment;	/* could not get default area */
        end;
      else go to bad_assignment;	/* won't allow ptr = 1 */

      if P_target.packed
        then P_target.address_ptr -> based_packed_ptr = p;
				/* assign value to symbol */
        else P_target.address_ptr -> based_ptr = p;

    end;				/* pointer */

  else if target_real_type = offset_dtype then do;

      if source_real_type = pointer_dtype /* pointer */
        then do;
	gen = P_target.source_info_ptr;
	if P_source.packed		/* unpack it if necessary */
	  then p = P_source.address_ptr -> based_packed_ptr;
	  else p = P_source.address_ptr -> based_ptr;
	P_target.address_ptr -> based_offset =
	     /* convert ptr relative to area */
	     stu_$pointer_to_offset (gen -> source_info.block_ptr,
	     P_target.symbol_ptr, addr (p),
	     gen -> source_info.stack_ptr,
	     (gen -> source_info.seg_info_ptr -> seg_info.linkage_ptr),
	     gen -> source_info.block_ptr);
	if P_target.address_ptr -> based_offset = nullo & p ^= null
	  then go to bad_assignment;	/* could not get default area */
        end;
      else if source_real_type = offset_dtype
				/* another offset */
        then P_target.address_ptr -> based_offset =
	        P_source.address_ptr -> based_offset;
      else go to bad_assignment;

    end;				/* offset */

  else if target_real_type = label_dtype then do;

      if source_real_type = label_dtype /* variable */
        then P_target.address_ptr -> based_label =
	        P_source.address_ptr -> based_label;
      else if source_real_type
	 =
	 label_constant_runtime_dtype
	 /* constant, must get frame label is in */
        then do;
	label_var.place = P_source.address_ptr;
	label_var.frame = P_source.source_info_ptr -> source_info.stack_ptr;
	unspec (P_target.address_ptr -> based_label) = unspec (label_var);
        end;
      else go to bad_assignment;

    end;				/* label var */

  else if target_real_type = entry_dtype then do;

      if source_real_type = entry_dtype /* entry variable */
        then P_target.address_ptr -> based_entry =
	        P_source.address_ptr -> based_entry;
      else if source_real_type >= int_entry_runtime_dtype /* entry constant */
        then do;
	entry_var.place = P_source.address_ptr;
	if source_real_type = int_entry_runtime_dtype
	  then entry_var.frame =
		  P_source.source_info_ptr -> source_info.stack_ptr;
				/* internal proc, get display */
	  else entry_var.frame = null ();
				/* level 0, display is null */
	P_target.address_ptr -> based_entry =
	     addr (entry_var) -> based_entry;
        end;
      else go to bad_assignment;

    end;				/* entry var */

  else if target_real_type = area_dtype then do;

      if source_real_type ^= area_dtype
        then go to bad_assignment;	/* can only assign an area to another area */

      call area_assign_ (P_target.address_ptr, P_source.address_ptr);
    end;				/* area */

  else if target_real_type = file_dtype then do;
      if source_real_type ^= file_dtype
        then go to bad_assignment;	/* only a file can be source */

      P_target.address_ptr -> based_file = P_source.address_ptr -> based_file;

    end;				/* file */

  else if data_type_info_$info (target_real_type).type then do;
      call probe_error_$record (probe_info_ptr, 0,
	 "Can't assign to a PASCAL type");
      go to RECORDED_MESSAGE;
    end;				/* type */

  else if target_real_type = pascal_char_dtype then do;
      if source_real_type = pascal_char_dtype
        then
	   call assign_pascal_enumerated;
      else if source_real_type = char_dtype
	 & P_source.precision = 1 then do;
				/* unique char constant */
	P_source.type = pascal_char_dtype;
	P_source.precision = 9;
	call assign_pascal_enumerated;
        end;
      else go to bad_assignment;
    end;				/* PASCAL char */

  else if target_real_type = pascal_boolean_dtype then do;
      if source_real_type = pascal_boolean_dtype
        then
	   call assign_pascal_enumerated;
        else go to bad_assignment;
    end;				/* PASCAL boolean */

  else if target_real_type = pascal_enumerated_type_element_dtype then do;
      call probe_error_$record (probe_info_ptr, 0,
	 "Can't assign to an enumerated type element constant.");
      go to RECORDED_MESSAGE;
    end;				/* PASCAL enumerated type element */

  else if target_real_type = pascal_enumerated_type_instance_dtype then do;
      if source_real_type = pascal_enumerated_type_element_dtype then do;
	if target_real_type_ptr
	     = runtime_symbol_info_$father_type (P_source.symbol_ptr)
	  then
	       call assign_pascal_enumerated;
	  else go to bad_assignment;
        end;
      else if source_real_type = pascal_enumerated_type_instance_dtype
        then do;
	if target_real_type_ptr = source_real_type_ptr
	  then
	       call assign_pascal_enumerated;
	  else go to bad_assignment;
        end;
      else go to bad_assignment;
    end;				/* PASCAL enumerated type instance */

  else if target_real_type = pascal_text_file_dtype then do;
      call probe_error_$record (probe_info_ptr, 0,
	 "Can't assign to a PASCAL file (temporary restriction).");
      go to RECORDED_MESSAGE;
    end;

  else if target_real_type = pascal_user_defined_type_instance_dtype then do;
      if source_real_type = pascal_user_defined_type_instance_dtype then do;
	if source_real_type_ptr = target_real_type_ptr then do;
	    if target_type_type_info.has_dimensions /* array */
	         | target_type_type_info.type
	         = pascal_record_type_dtype /* record */
	         | target_type_type_info.type = pascal_set_dtype /* set */
	      then do;
	        source_size =
		   get_size_in_bits_ ((P_source.type), P_source.precision,
		   P_source.packed);
	        target_size =
		   get_size_in_bits_ ((P_target.type), P_target.precision,
		   P_target.packed);
	        if source_size > target_size
		then
		     target_object =
			substr (source_object, 1, target_size);
		else
		     target_object = source_object;
	      end;
	    else if target_type_type_info.type =
	         pascal_record_file_type_dtype then do;
	        call probe_error_$record (probe_info_ptr, 0,
		   "Can't assign to a PASCAL file (temporary restriction)."
		   );
	        go to RECORDED_MESSAGE;
	      end;
	    else if target_type_type_info.type =
	         pascal_typed_pointer_type_dtype then do;
	        if P_target.precision = 36
		then
		     if P_source.precision = 72
		       then
			  P_target.address_ptr -> based_packed_ptr =
			       P_source.address_ptr -> based_ptr;
		       else
			  P_target.address_ptr -> based_packed_ptr =
			       P_source.address_ptr -> based_packed_ptr;
	        else
		   if P_source.precision = 72
		then
		     P_target.address_ptr -> based_ptr =
			P_source.address_ptr -> based_ptr;
	        else
		   P_target.address_ptr -> based_ptr =
		        P_source.address_ptr -> based_packed_ptr;
	      end;
	    else go to bad_assignment;
	  end;
	else
	     if target_type_type_info.type = pascal_set_dtype
	     & P_source.name = "<<set>>" then do;
	    source_size =
	         get_size_in_bits_ ((P_source.type), P_source.precision,
	         P_source.packed);
	    target_size =
	         get_size_in_bits_ ((P_target.type), P_target.precision,
	         P_target.packed);
	    if source_size > target_size
	      then
		 target_object = substr (source_object, 1, target_size);
	      else
		 target_object = source_object;
	  end;
	else go to bad_assignment;
        end;
      else if source_real_type = pointer_dtype then do;
	if target_type_type_info.type = pascal_typed_pointer_type_dtype
	  then do;
	    if P_target.precision = 36
	      then
		 if ^P_source.packed
		   then
		        P_target.address_ptr -> based_packed_ptr =
			   P_source.address_ptr -> based_ptr;
		   else
		        P_target.address_ptr -> based_packed_ptr =
			   P_source.address_ptr -> based_packed_ptr;
	    else
	         if ^P_source.packed
	      then
		 P_target.address_ptr -> based_ptr =
		      P_source.address_ptr -> based_ptr;
	    else
	         P_target.address_ptr -> based_ptr =
		    P_source.address_ptr -> based_packed_ptr;
	  end;
	  else go to bad_assignment;
        end;
      else if source_real_type = char_dtype then do;
	if P_source.precision > 1
	     & target_type_type_info.packed
	     & target_type_type_info.has_dimensions then do;

	    target_type_type_info.version = RUNTIME_TYPE_INFO_VERSION_1;

	    call runtime_symbol_info_$type (target_real_type_ptr,
	         addr (target_type_type_info), code);
	    if code ^= 0
	      then go to bad_assignment;

	    n_dims = runtime_symbol_info_$array_dims (target_real_type_ptr);
	    if (target_type_type_info.base_type = pascal_char_dtype)
	         & (n_dims = 1)
	      then
	        do;
	        target_size =
		   get_size_in_bits_ ((P_target.type), P_target.precision,
		   P_target.packed);
	        source_size =
		   get_size_in_bits_ ((P_source.type), P_source.precision,
		   P_source.packed);
	        if source_size > target_size
		then
		     target_object =
			substr (source_object, 1, target_size);
		else do;
		  target_len = divide (target_size, 9, 17, 0);
		  source_len = divide (source_size, 9, 17, 0);
		  target_string =
		       source_string
		       || copy (" ", target_len - source_len);
		end;
	      end;
	      else go to bad_assignment;
	  end;
	  else go to bad_assignment;
        end;
      else go to bad_assignment;
    end;				/* PASCAL user defined type instance dtype */

  else do;
    call probe_error_$record (probe_info_ptr, 0,
         "Can't assign to an object of type like ^a", P_target.name);
    go to RECORDED_MESSAGE;
  end;
  return;
%page;
  /* Procedures internal to assign_reference: */

assign_pascal_enumerated:
  proc;

  call set_up (P_target, target);
  call set_up (P_source, source);

  call assign_$computational_ (addr (target), addr (source), code);
  if code ^= 0
    then go to SOME_ERROR;

set_up:
  proc (ref, comp);

  dcl 1 ref		parameter aligned like reference_node;
  dcl 1 comp		parameter aligned like computational_data;

  comp.address = ref.address_ptr;
  comp.prec_or_length = ref.precision;
  if ref.precision >= 36
    then
         comp.data_type = real_fix_bin_2_uns_dtype;
    else
         comp.data_type = real_fix_bin_1_uns_dtype;
  string (comp.flags) = "0"b;
  comp.flags.packed = "1"b;
  comp.scale = 0;
  end set_up;
  end assign_pascal_enumerated;
%page;
make_unspec:
  proc (P_ref);

  dcl 1 P_ref		aligned like reference_node;

  P_ref.pseudo_var = "1"b;
  P_ref.type = bit_dtype;
  P_ref.type_ptr = null;
  P_ref.descriptor = P_ref.type * 2;
  P_ref.packed = "1"b;
  P_ref.precision = get_size_in_bits_$structure (addr (P_ref));
  if P_ref.precision = -1 then do;
      call probe_error_$record (probe_info_ptr, 0,
	 "Can't determine size of ^a", P_ref.name);
      go to RECORDED_MESSAGE;
    end;
  end make_unspec;
%page;
same_format:
  proc (P_ptr1, P_ptr2) returns (bit (1));

  dcl (P_ptr1, P_ptr2)	ptr;	/* pointers to symbol nodes */
  dcl (p1, p2)		ptr;
  dcl (var1_type, var2_type)	fixed bin;

  var1_type = binary (P_ptr1 -> runtime_symbol.type);
  var2_type = binary (P_ptr2 -> runtime_symbol.type);
  if var1_type ^= var2_type
    then
         return ("0"b);
  if P_ptr1 -> runtime_symbol.ndims ^= P_ptr2 -> runtime_symbol.ndims
    then
         return ("0"b);

  if var1_type = structure_dtype then do;
      p1 = runtime_symbol_info_$son (P_ptr1);
      do p2 = runtime_symbol_info_$son (P_ptr2)
	 repeat (runtime_symbol_info_$brother (p2))
	 while (p2 ^= null);

        if ^same_format (p1, p2)
	then
	     return ("0"b);
        p1 = runtime_symbol_info_$brother (p1);
      end;
      if p1 ^= null
        then return ("0"b);
        else return ("1"b);
    end;

    else do;
      if P_ptr1 -> runtime_symbol.aligned ^= P_ptr2 -> runtime_symbol.aligned
        then return ("0"b);
      if P_ptr1 -> runtime_symbol.packed ^= P_ptr2 -> runtime_symbol.packed
        then return ("0"b);
      if P_ptr1 -> runtime_symbol.simple ^= P_ptr2 -> runtime_symbol.simple
        then return ("0"b);
      if P_ptr1 -> runtime_symbol.scale ^= P_ptr2 -> runtime_symbol.scale
        then return ("0"b);
      if P_ptr1 -> runtime_symbol.size ^= P_ptr2 -> runtime_symbol.size
        then return ("0"b);

      return ("1"b);
    end;

  end same_format;
%page;
setup_str:
  proc (ref, comp, t_code);

  dcl 1 ref		parameter aligned like reference_node;
  dcl t_code		fixed bin (35);
  dcl 1 comp		parameter aligned like computational_data;

  dcl 1 an_encoded_value	like encoded_precision;

  comp.address = ref.address_ptr;
  comp.data_type = t_code;
  string (comp.flags) = "0"b;
  comp.flags.packed = ref.flags.packed;
  if data_type_info_$info (ref.type).arithmetic
    then do;
      unspec (an_encoded_value) = unspec (ref.precision);

      comp.prec_or_length = an_encoded_value.prec;
      comp.scale = an_encoded_value.scale;
    end;
    else do;
      comp.prec_or_length = ref.precision;
      comp.scale = 0;
    end;
  if ref.type = picture_runtime_dtype
    then comp.picture_image_ptr = pointer (ref.symbol_ptr, ref.precision);
    else comp.picture_image_ptr = null ();
  end setup_str;

  end assign_reference;
				/* \014                                                      */
%include probe_info;
%include probe_tokens;
%include probe_references;
%include probe_source_info;
%include probe_seg_info;
%include probe_lang_types;

%include encoded_precision;
%include data_type_info_;
%include computational_data;
%include runtime_symbol;
%include std_descriptor_types;
%include runtime_symbol_info_;

  end probe_assign_value_;




		    probe_block_name_.pl1           10/27/88  1244.0rew 10/27/88  1223.0      105921



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


/****^  HISTORY COMMENTS:
  1) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
  2) change(88-10-19,WAAnderson), approve(88-10-19,MCR7952),
     audit(88-10-25,RWaters), install(88-10-27,MR12.2-1194):
     Modified to support C. We don't use 'ep', just 'bp'. The code
     written for the other languages is poorly written and doesn't lend
     itself well to the needs of C so a new block of code was written
     exclusively for C.
                                                   END HISTORY COMMENTS */

/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

probe_block_name_:
  proc (P_probe_info_ptr, P_source_info_ptr, P_longp)
       returns (char (256) varying);

  /* Given a block as defined by the source_info block pointed to by */
  /* P_source_info_ptr,  return its name in one of the following     */
  /* formats:                                                        */
  /*                                                                 */
  /* segname$entryname                      for an external entry.   */
  /* $entryname in segname                  for an internal proc.    */
  /* Block at line NN in segname$entryname  for a begin block where  */
  /*                                        line number is known.    */
  /* Block at segname|NNNNNN in entryname   for a begin block of     */
  /*                                        unknown line number.     */
  /*                                                                 */
  /* We use the following components of source_info:                 */
  /*                                                                 */
  /* block pointer (if available)                                    */
  /* entry pointer (except for quick begin blocks)                   */
  /* seg_info (to get the segname)                                   */
  /*                                                                 */
  /* The entryname portion of seg_info is not used, because there is */
  /* only one seg_info for a given external procedure, and we might  */
  /* be interested in one of its entry points other than the main    */
  /* one.                                                            */
  /*                                                                 */
  /*   James R. Davis 12 July 79                                     */

  /* 10/21/82, S.Herbst,                                             */
  /* Changed to print entry point name of ext proc if different from */
  /* segname.                                                        */
  /* 06/??/83, JMAthane,                                             */
  /* Changed to handle PASCAL with blocks.                           */
  /* 08/26/83, S.Herbst,                                             */
  /* Implemented P_longp to return full pathnames.                   */
  /* 02/14/84, S.Herbst,                                             */
  /* Fixed to work on hardcore segments.                             */
  /* 05/29/84, S.Herbst,                                             */
  /* Fixed bug sometimes causing foo$bar$foo$baz, also garbage names.*/
  /* 05/29/84, S. Herbst,                                            */
  /* Fixed to detect ext entry points in lang's other than PL/1      */
  /* (runtime_block.type="01"b3).                                    */

  dcl P_probe_info_ptr	ptr parameter;
				/* Input: only used because subrs we call use it */
  dcl P_source_info_ptr	ptr parameter;
				/* to callers source info */
  dcl P_longp		bit (1) aligned parameter;
				/* Input: return full pathnames */

  dcl ret_string		char (256) varying;
				/* what we return */

  dcl source_info_ptr	ptr;

  dcl 1 callers_source	aligned like source_info
			based (source_info_ptr);

  dcl bp			ptr;	/* copy of block_ptr */
  dcl ep			ptr;	/* cop of entry ptr */
  dcl sip			ptr;	/* ptr to seg_info */
  dcl p			ptr;	/* temp ptr */
  dcl (file, line, stmt)	fixed bin;/* from statement_map entry */
  dcl whole_name		char (256);
  dcl segment_pathname	char (168);
  dcl ext_entry_name	char (72);
  dcl proc_name		char (32);

  dcl format_pointer_$its	entry (ptr, bit (1) aligned, ptr)
			returns (char (256) varying);
  dcl ioa_$rsnnl		entry options (variable);
  dcl get_entry_name_	entry (ptr, char (*), fixed bin (18),
			char (8) aligned, fixed bin (35));
  dcl pathname_		entry (char (*), char (*)) returns (char (168));
  dcl code		fixed bin (35);

  dcl (addrel, after, before, fixed, index, ltrim, null, rel, rtrim,
      substr)		builtin;

  probe_info_ptr = P_probe_info_ptr;
  source_info_ptr = P_source_info_ptr;
  bp = callers_source.block_ptr;
  ep = callers_source.entry_ptr;

  sip = callers_source.seg_info_ptr;

  ext_entry_name = "";
  ret_string = "";
  segment_pathname = "";
  if (probe_info.language_type = C_lang_type) then do;
      if P_longp
        then
	   segment_pathname =
	        pathname_ (sip -> seg_info.directory_name,
	        sip -> seg_info.entry_name);
        else segment_pathname = sip -> seg_info.entry_name;
      if bp ^= null () then do;
	if bp -> runtime_block.name then do;
	    p = addrel (bp, bp -> runtime_block.name);
	    ret_string = p -> acc.string;
	    ret_string =
	         before (ret_string, "$") || " in "
	         || rtrim (segment_pathname);
	    return (ret_string);
	  end;			/* named proc */
	  else do;		/* is a begin block */
	    ret_string = sip -> seg_info.entry_name;
	    if bp -> runtime_block.first ^= "0"b
	      then do;		/* have statement map */
	        p = addrel (bp, bp -> runtime_block.first);
				/* pt to statement_map entry */

	        file = fixed (p -> statement_map.file, 8);
	        line = fixed (p -> statement_map.line, 14);
	        stmt = fixed (p -> statement_map.statement, 5);

	        call ioa_$rsnnl (
		   "Block at line ^[^d-^;^s^]^d^[,^d^;^s^] of ^a",
		   ret_string, (0),
		   file > 0, file, line, stmt > 1, stmt,
		   rtrim (segment_pathname));
	        return (ret_string);
	      end;		/* begin block with line */
	  end;			/* begin-block */
        end;			/* using bp */
    end;

  if P_longp then do;
      whole_name, segment_pathname =
	 pathname_ (sip -> seg_info.directory_name,
	 sip -> seg_info.entry_name);
      proc_name = sip -> seg_info.segname;
      if proc_name ^= sip -> seg_info.entry_name
        then /* bound component ... unless language is C */
	   whole_name =
	        rtrim (sip -> seg_info.segname) || " in "
	        || segment_pathname;
    end;
    else do;
      whole_name, proc_name = sip -> seg_info.segname;
      if whole_name = ""		/* is this possible */
        then whole_name = sip -> seg_info.entry_name;
    end;
  if whole_name = ""		/* what still?? */
    then whole_name = "<<unknown>>";

  if bp ^= null ()
    then do;
				/* first look for containing block if PASCAL with block */
      if bp -> symbol_block.type = PASCAL_WITH_BLOCK
        then
	   bp = addrel (bp, bp -> symbol_block.owner);
      if bp -> runtime_block.name /* a proc, may be internal or external */
        then do;
	p = addrel (bp, bp -> runtime_block.name);
	ret_string = p -> acc.string;
	ret_string = before (ret_string, "$");
				/* just the segment name */
	if P_longp
	  then
	       if ret_string = proc_name
	         then ret_string = whole_name;
				/* external procedure ... all external in C */
	         else ret_string =
		         ret_string || " in " || rtrim (whole_name);
				/* internal procedure */
	if (bp -> runtime_block.father = "777421"b3
	     | bp -> runtime_block.type = "01"b3)
	  then
	       /* external entry point */
	       if ep ^= null then do;
		 call get_entry_name_ (ep, ext_entry_name, 0, "", code);
		 if index (ext_entry_name, "$") ^= 0
		   then /* just the entry point name */
		        ext_entry_name = after (ext_entry_name, "$");
		 if code = 0 & ext_entry_name ^= ret_string
		   then
		        if P_longp
			then
			     if sip -> seg_info.segname
				^= sip -> seg_info.entry_name
			       then /* bound comp */
				  ret_string =
				       rtrim (sip -> seg_info.segname)
				       || "$" ||
				       rtrim (ext_entry_name)
				       || " in " || segment_pathname;
			       else ret_string =
				       rtrim (segment_pathname)
				       || "$"
				       || rtrim (ext_entry_name);
			else ret_string =
				ret_string || "$"
				|| rtrim (ext_entry_name);
	         end;
        end;			/* named proc */
        else do;			/* is a begin block */
	if bp -> runtime_block.first ^= "0"b
	  then do;		/* have statement map */
	    p = addrel (bp, bp -> runtime_block.first);
				/* pt to statement_map entry */

	    file = fixed (p -> statement_map.file, 8);
	    line = fixed (p -> statement_map.line, 14);
	    stmt = fixed (p -> statement_map.statement, 5);

	    call ioa_$rsnnl ("Block at line ^[^d-^;^s^]^d^[,^d^;^s^] of ^a",
	         ret_string, (0),
	         file > 0, file, line, stmt > 1, stmt,
	         whole_name);
	  end;			/* begin block with line */
	  else do;
	    call ioa_$rsnnl ("Block at ^a|^o", ret_string, (0),
	         whole_name,
	         fixed (rel (ep), 18));
	  end;			/* begin block with offset */
        end;			/* begin-block */
    end;				/* using bp */
  else if ep ^= null ()
    then do;
      if is_begin_block (ep)
        then do;
	call ioa_$rsnnl ("Block at ^a|^o", ret_string, (0),
	     whole_name,
	     fixed (rel (ep), 18));
        end;			/* begin-block */
        else do;
	dcl entry_point_name        char (32);
	call get_entry_name_ (ep, entry_point_name, (0), (""), code);
	if code = 0
	  then
	       if P_longp
	         then ret_string =
		         rtrim (whole_name) || "$"
		         || rtrim (entry_point_name);
	         else ret_string = rtrim (entry_point_name);
	  else do;
	    ret_string = format_pointer_$its (ep, "1"b, null);
	    ret_string =
	         ltrim (substr (ret_string, index (ret_string, " ")));
	  end;
        end;			/* proc using ep */
    end;				/* trying to use ep */
  else ret_string = rtrim (whole_name); /* have no info, so I doubt this will help */

  return (ret_string);




is_begin_block:
  proc (tp) returns (bit (1) aligned);


  dcl tp			ptr parameter;
  dcl cp			ptr;
  dcl iword		bit (36) aligned based (cp);
  dcl i			fixed bin;
  dcl (addrel, hbound)	builtin;

  cp = addrel (tp, 1);		/* point to first instruction */
  do i = 1 to hbound (begin_block_entries, 1);
    if iword = begin_block_entries (i)	/*  matches */
      then return ("1"b);
  end;
  return ("0"b);

%include begin_block_entries;

  end is_begin_block;

%include probe_source_info;

%include probe_seg_info;

%include statement_map;

%include acc;

%include runtime_symbol_block;

%include runtime_block_type;

%include runtime_symbol;

%include probe_lang_types;
%include probe_info;
  end probe_block_name_;




		    probe_break_.alm                10/24/88  1612.3rew 10/24/88  1353.5       16758



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

" HISTORY COMMENTS:
"  1) change(88-10-18,WAAnderson), approve(88-10-18,MCR7952),
"     audit(88-10-18,JRGray), install(88-10-24,MR12.2-1184):
"     Probe source archive split. Part of C-Probe support.
"                                                      END HISTORY COMMENTS


"
"
"	PROBE_BREAK_  --  Transfer vector for implementing probe breakpoints.
"
"	There are eight entries which correspond with the eight types of breakpoints
"	presently implemented by operator_pointers_, type1 through type8. Of these
"	eight, only type1 is presently used by ordinary probe -- the others are reserved
"	for debugging and future use, and simply return if called.
"
"	06/27/79 WOS
"

	segdef	type1		" Standard probe breakpoint

type1:	epbpsb	sp|0		" Get Stack Base pointer
	epaq	*		" Get LP
	lprplp	sb|stack_header.lot_ptr,*au
	tra	probe_break_handler_$break_type_1 " Transfer to probe breakpoint handler


	segdef	type2		" Types 2 through 8 are presently ignored.

type2:	short_return


	segdef	type3

type3:	short_return


	segdef	type4

type4:	short_return


	segdef	type5

type5:	short_return


	segdef	type6

type6:	short_return


	segdef	type7

type7:	short_return


	segdef	type8

type8:	short_return


"
" 
"

	include	stack_header

	end




		    probe_break_handler_.pl1        10/27/88  1244.0r w 10/27/88  1225.3       92394



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



/****^  HISTORY COMMENTS:
  1) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

probe_break_handler_:
  proc ();


  call probe_error_$malfunction ();	/* dummy entry */

  /* *	This procedure contains the routines which are called by the code sequences
   *	in the break map header. It sets up a new probe_info structure, and interprets
   *	the breakpoint request list. */

  /* Changed to ignore 2 breaks in a row in probe itself, for debugging 10/07/81 S. Herbst */
  /* Changed to reset a temporary break when it hits one 12/10/81 S. Herbst */
  /* Fixed to ignore break if break segment not found. 05/13/83 S. Herbst */
  /* Do "start" control order on output switch before returning to prevent losing wakeups 09/02/83 S. Herbst */
  /* Changed to apply RETURN_PTR_MASK to stack_frame.return_ptr (see incl comment) 03/06/84 S. Herbst */
  /* Changed to call probe_break_mgr_$reset_all_pause_breaks on cleanup 04/19/84 S. Herbst */

  dcl PAUSE_LINE		char (6) int static options (constant)
			init ("pause
");

  dcl bp			ptr;
  dcl p			ptr;
  dcl code		fixed bin (35);
  dcl callers_frame		pointer;

  dcl 1 based_instruction	aligned based,
       2 offset		bit (18) unal,
       2 misc		bit (18) unal;
				/* opcode and modifier */

  dcl com_err_		entry options (variable);
  dcl iox_$control		entry (ptr, char (*), ptr, fixed bin (35));

  dcl probe_break_mgr_$reset_all_pause_breaks
			entry (ptr);
  dcl probe_break_mgr_$reset_break_at_line
			entry (ptr, ptr, fixed bin, bit (1) aligned,
			fixed bin (35));
  dcl probe_error_		entry options (variable);
  dcl probe_error_$malfunction
			entry options (variable);
  dcl probe_listen_$interpret_line
			entry (ptr, ptr, fixed bin (21), fixed bin (35))
			;
  dcl probe_seg_info_	entry (ptr, ptr, fixed bin (35)) returns (ptr);

  dcl probe_subsys_util_$create_invocation
			entry (fixed bin, ptr, fixed bin (35));
  dcl probe_subsys_util_$destroy_invocation
			entry (ptr);

  dcl (probe_et_$old_break)	fixed bin (35) external static;

  dcl cleanup		condition;

  dcl (addr, addrel, baseno, length, null, pointer, size, stackframeptr,
      unspec)		builtin;
				/*  */

probe_break_handler_$break_type_1:
  entry ();

  /* *	This is the entry for type 1 (standard) breaks */

  probe_info_ptr = null ();

  on cleanup
    begin;
    call probe_break_mgr_$reset_all_pause_breaks (probe_info_ptr);
    call clean_things_up ();
  end;

  call probe_subsys_util_$create_invocation (probe_info_version,
       probe_info_ptr, code);
  if code ^= 0 then do;		/* MOBY lossage */
      call com_err_ (code, "probe",
	 "Unable to initialize probe for breakpoint; break ignored.");
      call clean_things_up ();
      return;
    end;

  if probe_info.break_segment_ptr = null
    then go to IGNORE_BREAK;		/* rather than blow up later */

  probe_info.abort_probe_label = BREAK_TYPE_1_RETURNS;
				/* for handling initialization errors, mostly */
  probe_info.abort_line_label = BREAK_TYPE_1_RETURNS;
  probe_info.current_stack_frame = stackframeptr ();

  callers_frame = stackframeptr () -> stack_frame.prev_sp;
				/* frame of caller - routine that took break */

  break_extension_info_ptr =
       addrel (stackframeptr (), -size (probe_break_extension));

  p = probe_break_extension.slot_return_addr;
				/* instruction after call to map seq. */

  /* FOR DEBUGGING: Ignore second recursive break in probe itself */

  if ^probe_static_info.recursive_breaks_sw
    then
         if baseno (p) = probe_static_info.probe_segno
	 then
	      if probe_static_info.last_break_segno
		 = probe_static_info.probe_segno
	        then
		   go to IGNORE_BREAK;
				/* skip the second break in a row in probe itself */

  probe_static_info.last_break_segno = baseno (p);

  if p -> based_instruction.misc ^= NOP_code
    then call probe_error_ (probe_info_ptr, probe_et_$old_break);

  bsp = pointer (p, p -> based_instruction.offset);
				/* to break slot */
  stp = pointer (bsp, break_slot.statement_item_offset);
				/* set up statement item */
  ent = pointer (probe_info.break_segment_ptr, statement_item.proc_entry);

  /* some consistency checks here */

  if ent = null
    then go to IGNORE_BREAK;
  if procedure_entry.time_stamp ^= statement_item.identifier
    then do;			/* probably set by someone else  - we shall ignore it */
IGNORE_BREAK:
      call clean_things_up ();
      return;
    end;

  current_source.stmnt_map_entry_index = statement_item.number;
  current_source.instruction_ptr = pointer (bsp, break_slot.location);
  current_source.stack_ptr = callers_frame;

  /* now to get entry ptr - someday this should be stored in proc_entry */

  if break_slot.symbol_block_offset = "0"b
    then do;			/* someday, this will happen, when breaks can be set ala debug */
      current_source.block_ptr = null ();
      current_source.entry_ptr = callers_frame -> stack_frame.entry_ptr;
    end;
    else do;
      current_source.block_ptr, bp =
	 pointer (bsp, break_slot.symbol_block_offset);

      if bp -> runtime_block.quick then do;
	p = null ();		/* havent got entry yet */
	if bp -> runtime_block.entry_info ^= "0"b then do;
	    p = addrel (callers_frame, bp -> runtime_block.entry_info);
				/* pt to entry_info */
	    p = addrel (p -> quick_entry.return, -1);
				/* pt to call to this block */
	    p = addrel (p, p -> based_instruction.offset);
				/* assume it is a relative TRA NNN,ic */

	    /* now i think for fortran, this is instead a pl1_op call  so this kludeg ahead... */

	    if baseno (p) ^= baseno (bp)
				/* our return isn't into same seg we started  in */
	      then p = null ();	/* show failure */
	  end;
	if p = null () /* fortran, or no entry info */
	  then do;
	    p = addrel (bp, bp -> runtime_block.first);
				/* pt to statement_map for first stmt */
	    p = pointer (p, p -> statement_map.location);
	  end;
        end;			/* quick */
        else p = callers_frame -> stack_frame.entry_ptr;

      current_source.entry_ptr = p;
    end;				/* non-null bp */


  current_source.seg_info_ptr =
       probe_seg_info_ (probe_info_ptr, (current_source.entry_ptr), (0));

  /*  In old probe, when the break was encountered, a ptr to the break map was saved in seg_info.break_info
   But we don't need it anymore --- I hope --- */



  /* *Note that the return loc in frame will be into break map, not text, and stu_ gets
   *confused, so fudge it (remember stack_frame_exit gives return loc - 1). Record
   *information about the break, to make it restartable. We will want to return to the
   *spot in the break map, unless it gets changed by resetting an active break, but
   *make it look otherwise for a while. */

  probe_info.break_slot_ptr = bsp;
  unspec (probe_info.real_break_return_loc) =
       unspec (callers_frame -> stack_frame.return_ptr) & RETURN_PTR_MASK;
  callers_frame -> stack_frame.return_ptr =
       addrel (current_source.instruction_ptr, 1);

  probe_info.return_method = RETURN_TO_BREAK;
				/* remember how we got here */


  initial_source = current_source;
  probe_info.language_type =
       current_source.seg_info_ptr -> seg_info.language_type;

  probe_static_info.stack_info.good_stack = "0"b;
				/* the stack has changed, after all */

  if bsp -> break_slot.command_list = PAUSE_LINE then do;
				/* reset if temporary break */
      call probe_break_mgr_$reset_break_at_line (probe_info_ptr,
	 probe_info.ptr_to_current_source, BREAK_BEFORE, "0"b, (0));

      call probe_listen_$interpret_line (probe_info_ptr, addr (PAUSE_LINE),
	 length (PAUSE_LINE), (0));
    end;

    else call probe_listen_$interpret_line (probe_info_ptr,
	    addr (bsp -> break_slot.command_list),
	    (bsp -> break_slot.count), (0));

BREAK_TYPE_1_RETURNS:
  call clean_things_up ();		/* clean up */
  return;				/* return to program causing the break */






clean_things_up:
  proc ();

  if probe_info_ptr ^= null () then do; /* do some things, if we can */
      if addr (probe_static_info) ^= null ()
        then /* invalidate the saved stack */
	   probe_static_info.good_stack = "0"b;

      if probe_info.return_method = RETURN_TO_BREAK
        then /* only true if break info is also valid */
	   callers_frame -> stack_frame.return_ptr =
	        probe_info.real_break_return_loc;
    end;				/* repair damage done earlier */

  call probe_subsys_util_$destroy_invocation (probe_info_ptr);

  call iox_$control (probe_info.output_switch, "start", null, 0);
				/* prevent wakeups from being lost while break is executing */
  return;
  end;				/* internal procedure clean_things_up */


  /*	INCLUDE FILES	*/

%include probe_info;

  /* ;;;;;;; */

%include probe_static_info;

  /* ;;;;;;; */

%include probe_modes;

  /* ;;;;;;; */

%include probe_source_info;

  /* ;;;;;;; */

%include probe_seg_info;

  /* ;;;;;;; */

%include probe_break_slot;
%include probe_break_info;
%include probe_break_extension;

  /* ;;;;;;; */

%include probe_info_constants;

  /* ;;;;;;; */

%include runtime_symbol;

  /* ;;;;;;; */

%include statement_map;

  /* ;;;;;;; */

%include quick_entry;

  /* ;;;;;;; */

%include stack_frame;

  end;				/* probe_break_handler_ external procedure */




		    probe_break_mgr_.pl1            10/27/88  1244.0rew 10/27/88  1221.9      497907



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


/****^  HISTORY COMMENTS:
  1) change(88-09-30,WAAnderson), approve(88-09-30,MCR7863),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Fixed bugs associated with object segments compiled with the -brief_table
     control argument.
  2) change(88-09-30,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
  3) change(88-10-21,WAAnderson), approve(88-10-21,MCR7952),
     audit(88-10-24,RWaters), install(88-10-27,MR12.2-1194):
     Modified for C.  The names of C functions were not been printed.
                                                   END HISTORY COMMENTS */

/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

probe_break_mgr_:
  proc;

  call probe_error_$malfunction ();	/* dummy entry */

  /* Here we have entries to set breaks, to list breaks, and to reset breaks -
   programs here know about how breaks are implemented, and about the various data structures.
   The exact arrangements of procedures is subject to change

   COMPLETELY NEW CODE - by James R. Davis 25 Sept 79

   ENTRIES

   set_break

   list_breaks_at_line
   list_breaks_in_seg
   list_breaks_in_world
   list_broken_segs

   reset_break_at_line
   reset_breaks_in_seg
   reset_breaks_in_world
   reset_all_pause_breaks

   print_instructions	prints code for a stmt, with breaks invisible.

   Big comment explaining the data structures used - see end, just before include files */
  /* Modified 17 August 1981 by Melanie Weaver to handle segs that end on even word. */
  /* Changed to initialize break segment when needed (instead of at command time) 09/28/81 S. Herbst */
  /* Fixed to always delete break map after last break in seg is reset 11/03/81 S. Herbst */
  /* Added $is_temporary_break returns "1"b if after break is "pause" 12/02/81 S. Herbst */
  /* Fixed bug when breakmap is deleted 12/29/81 S. Herbst */
  /* Fixed to remove added w access when done 03/15/82 S. Herbst */
  /* Fixed ACL forcing once more 05/25/82 S. Herbst */
  /* Added $print_instructions 09/15/82 S. Herbst */
  /* Fixed error message printed when debug breaks are left in break map 08/12/83 S. Herbst */
  /* Fixed bug in "r N" that can reset an extra break 03/30/84 S. Herbst */
  /* Added $reset_all_pause_breaks, called when exiting probe 04/19/84 S. Herbst */
  /* Fixed not to overwrite a real break with one set by "step" 04/19/84 S. Herbst */
  /* Fixed to fail gracefully if source_info.instruction_ptr = null 08/02/84 S. Herbst */


  dcl (
      P_probe_info_ptr	ptr parameter,
      P_break_type		fixed bin,/* BREAK_AT, BREAK_AFTER, etc. */
      P_command_ptr		ptr,	/* to break request list */
      P_command_length	fixed bin (21),
				/* how many chars in list */
      P_instruction_ptr	ptr,	/* for $print_instructions */
      P_len		fixed bin,/* for $print_instructions */
      P_long_sw		bit (1) aligned,
				/* verbosity control */
      P_source_info_ptr	ptr,	/* to source_info */
      P_code		fixed bin (35)
      )			parameter;

  dcl (
      PRINT		init ("1"b),
      NO_PRINT		init ("0"b)
      )			bit (1) aligned int static options (constant);
  dcl BRIEF		bit (1) aligned int static
			options (constant) init ("0"b);

  dcl seginfop		ptr;	/* to the seg info of some object seg */
  dcl code		fixed bin (35);
  dcl number		fixed bin;/* the index into Map_array */
  dcl happy		bit (1) aligned;
				/* did we find even one break */
  dcl breakmap_deleted_sw	bit (1) aligned;
  dcl break_type		fixed bin;/* global use: AT AFTER BEFORE */
  dcl based_word		bit (36) aligned based;

  dcl first		ptr;	/* in loops, to the first */
  dcl next		ptr;	/* in loops, to the next */
  dcl long_sw		bit (1) aligned;
				/* copy of P_long, at times */
  dcl pauses_entry_sw	bit (1) aligned;
				/* called $reset_all_pause_breaks */

  dcl instruction_ptr	ptr;
  dcl slot_ptr		ptr;
  dcl slot_offset		bit (18);
  dcl saved_instruction	bit (36) aligned;

  dcl added_w_sw		bit (1) aligned;
				/* to remove w access when done if it was added */
  dcl after_sw		bit (1) aligned;
				/* ON => temporarily resetting an after break */
  dcl saved_mode_sw		bit (1) aligned;
				/* there was already an acl entry for group_id$tag_star */
  dcl saved_mode		bit (3);	/* access to restore when removing w */
  dcl saved_stp		ptr;	/* saved copy of stp while resetting breaks */
  dcl 1 seg_acl		(1) aligned like segment_acl;
  dcl acl_dn		char (168);
  dcl acl_en		char (32);

  dcl 1 Break_source	aligned like source_info
			based (break_source_info_ptr);
  dcl break_source_info_ptr	ptr;

  dcl 1 Map_array		(Map_size) aligned like statement_map
			based (Map_ptr);
  dcl Map_size		fixed bin;
  dcl Map_ptr		ptr;

  dcl NL			char (1) int static options (constant) init ("
");
  dcl (
      probe_map_sequence_$before_code
			bit (36), /* to get its address */
      probe_map_sequence_$after_code
			bit (36),
      probe_map_sequence_$count
			fixed bin,
      probe_map_sequence_$code
			bit (36),
      probe_map_sequence_$return
			bit (36),
      probe_map_sequence_$old_return
			bit (36)
      )			aligned external static;

  dcl probe_seg_mgr_$create_breakseg
			entry (fixed bin (35)) returns (ptr);
  dcl probe_seg_mgr_$get_procedure_entry
			entry (ptr, ptr, ptr, ptr, fixed bin (35));
  dcl probe_seg_mgr_$first_procedure_ptr
			entry (ptr, fixed bin (35)) returns (ptr);
  dcl probe_seg_mgr_$create_procedure_entry
			entry (ptr, ptr, ptr, ptr, fixed bin (35));
  dcl probe_seg_mgr_$delete_procedure_entry
			entry (ptr, ptr, fixed bin (35));

  dcl (
      probe_error_$malfunction,
      probe_error_$record
      )			entry options (variable);

  dcl get_group_id_		entry returns (char (32));
  dcl inst_length_		entry (ptr, fixed bin) returns (fixed bin);
  dcl print_instructions_	entry (ptr, fixed bin, ptr);
  dcl relocate_instruction_	entry (ptr, ptr, fixed bin (35));
  dcl hcs_$add_acl_entries	entry (char (*), char (*), ptr, fixed bin,
			fixed bin (35));
  dcl hcs_$delete_acl_entries entry (char (*), char (*), ptr, fixed bin,
			fixed bin (35));
  dcl hcs_$fs_get_path_name	entry (ptr, char (*), fixed bin, char (*),
			fixed bin (35));
  dcl hcs_$list_acl		entry (char (*), char (*), ptr, ptr, ptr,
			fixed bin, fixed bin (35));
  dcl hcs_$set_bc_seg	entry (ptr, fixed bin (24), fixed bin (35));


  dcl ioa_$ioa_switch	entry options (variable);

  dcl (
      probe_et_$breakless,
      probe_et_$no_breaks_set,
      probe_et_$no_breaks,
      probe_et_$non_standard,
      probe_et_$breaks_exist,
      probe_et_$old_break_map,
      probe_et_$recorded_message
      )			fixed bin (35) external static;

  dcl (add, addr, addrel, binary, bit, divide, fixed, hbound,
      mod, multiply, null, pointer, ptr, rel, size, substr, subtract, unspec)
			builtin;


RECORDED_MESSAGE:
  P_code = probe_et_$recorded_message;
  return;


set_break:
  entry (P_probe_info_ptr, P_source_info_ptr, P_break_type, P_command_ptr,
       P_command_length, P_code);


  begin;

    dcl command_ptr		  ptr;
    dcl command_length	  fixed bin (21);
    dcl command		  char (command_length) based (command_ptr);
    dcl map_seq_ptr		  ptr;	/* to map_sequence in this object seg */
    dcl place_to_set	  ptr;	/* where to put the break */
    dcl next_loc		  ptr;	/* to instruction after the broken one */
    dcl copy		  (copy_count) bit (36) based;
    dcl copy_count		  fixed bin (21);



    /* HOW TO SET BREAKS :

   Create a break map for the object seg (if one doesn't exist already)
   Ensure sufficient access and that maxlength of seg is reset to big
   create a procedure entry for seg in break_seg (if not one already)
   if there is already a break at the line of same type, reset it

   if there is no statement entry for the given statement, create it

   create a break_slot of the right kind
   relocate instruction


   An additional hairy feature:

   It may be that the user sets a break after and before a line, and the line is only one instrcuton
   long.  This is known as a "strange" break.  A "strange" break is implemented by a "tra" to the before code sequence
   (just as for a normal before break).  the before code executes its map sequence, and probe is invoked in the usual way.
   The "moved_instruction" in the before slot, however, is replaced with a "tra" to the after slot sequence.  It is as if
   there has been an "after" break set IN THE BEFORE SEQUENCE ITSELF.
   The after sequence first executes the original "moved" instruction (which completes the execution of all object code
   for the line), then executes the map sequence, and probe is once again invoked.

   When the "before" break is reset, it copies the "old_instruction" back into the object segment (just as is done for a
   "normal"    before break).  This instruction is a tra to the after code, not the original instruction.
   The original   is still stored in the after slot, since the after break is still in effect..
   If a "strange" after break   is reset, then the saved "old" and "moved" instructions are returned
   to the before slot where they   were copied from, and all is well
*/

    probe_info_ptr = P_probe_info_ptr;
    P_code = 0;
    command_length = P_command_length;
    command_ptr = P_command_ptr;
    break_type = P_break_type;
    break_source_info_ptr = P_source_info_ptr;
    code = 0;
    seginfop = Break_source.seg_info_ptr;

    if Break_source.instruction_ptr = null then do;
        place_to_set = null;
        go to CANT_RELOCATE;
      end;

    if probe_static_info.break_segment_ptr = null then do;
        probe_static_info.break_segment_ptr =
	   probe_seg_mgr_$create_breakseg (code);
        if code ^= 0 then do;
	  call probe_error_$record (probe_info_ptr, 0,
	       "Can't initialize break segment.");
	  go to RECORDED_MESSAGE;
	end;
      end;

    call probe_seg_mgr_$create_procedure_entry (probe_info_ptr, seginfop, ent,
         bmp, P_code);
    if P_code ^= 0
      then
	 return;

    call ensure_writeable ((Break_source.instruction_ptr));
    if bmp = null () then do;
        call create_breakmap ();
        procedure_entry.break_map = rel (bmp);
      end;

    number = Break_source.stmnt_map_entry_index;
    stp = search_for_stmt (ent, bmp, number);

    if stp = null ()		/* no previous record for this line */
      then stp = create_statement_entry (ent, bmp,
	      Break_source.stmnt_map_entry_index);
      else do;
        if statement_item.slots (break_type) ^= (18)"0"b
	then
	     if command = "pause"
	       then
		  return;		/* "step" break shouldn't overwrite real one */
	       else call remove_break ((break_type));
      end;


    Map_ptr = seginfop -> seg_info.statement_map_ptr;
    Map_size = seginfop -> seg_info.map_size;
    place_to_set = pointer (bmp, Map_array (number).location);

    command_list_size = command_length + 1;
				/* for NL */

    map_seq_ptr = addr (break_map.map_sequence);
    if break_type = BREAK_BEFORE then do;
        next_loc = addrel (place_to_set, inst_length_ (place_to_set, (0)));
        if next_loc = place_to_set
	then goto CANT_GET_LENGTH;

        bsp, before_slot_ptr =
	   allocate_in_breakmap (size (break_slot_before));

        /* because we didn't use pl1 allocate we must initialize the slot ourselves */

        call common_break_slot_setup (before_slot_ptr);
				/* size is set by allocate_in_breakmap */
        break_slot_before.type = BREAK_BEFORE;

        copy_count = size_of_before_sequence;
        unspec (break_slot_before.sequence) =
	   unspec (addr (probe_map_sequence_$before_code) -> copy);
        break_slot_before.sequence.map_seq_offset = rel (map_seq_ptr);
        break_slot_before.sequence.slot_offset = rel (before_slot_ptr);
        break_slot_before.sequence.return.offset = rel (next_loc);

        call relocate_instruction_ (place_to_set,
	   addr (break_slot_before.moved_instruction), code);

        if code ^= 0
	then goto CANT_RELOCATE;
        break_slot_before.old_instruction = place_to_set -> based_word;

        place_to_set -> based_word =
	   rel (addr (break_slot_before.sequence)) || TRA_code;
				/* ughh */

      end;			/* break before */
      else do;
        if number = hbound (Map_array, 1) then do;
	  call probe_error_$record (probe_info_ptr, 0,
	       "Can't set break after last line in program");
	  goto RECORDED_MESSAGE;
	end;
        next_loc = place_to_set;

        /* find last inst. in line, and first inst. after it.  this is hard,
   because we can't just look at last word of the line, because it could be
   the descriptor of an EIS.  the only safe way is to look at each instruction, find its length,
   and look where the next inst. is to begin.  I wish the statement map told us.
*/

        if statement_item.slots (BREAK_BEFORE) = "0"b
	then before_slot_ptr = null ();
	else do;

	  /* the instruction there is only a TRA, of length one, the real instruction is in the break_slot */
	  before_slot_ptr =
	       pointer (stp, statement_item.slots (BREAK_BEFORE));
	  next_loc = addrel (next_loc,
	       inst_length_ (addr (break_slot_before.old_instruction), (0)))
	       ;
	end;

        do while (rel (next_loc) < Map_array (number + 1).location);
				/* find last inst. in line */
	place_to_set = next_loc;	/* this one is known good */
	next_loc = addrel (next_loc, inst_length_ (next_loc, (0)));
	if next_loc = place_to_set	/* means the length was 0, i.e. bad */
	  then goto CANT_GET_LENGTH;
        end;

        bsp, after_slot_ptr = allocate_in_breakmap (size (break_slot_after));
        call common_break_slot_setup (after_slot_ptr);
        copy_count = size_of_after_sequence;
        unspec (break_slot_after.sequence) =
	   unspec (addr (probe_map_sequence_$after_code) -> copy);

        break_slot_after.sequence.map_seq_offset = rel (map_seq_ptr);
        break_slot_after.sequence.slot_offset = rel (after_slot_ptr);
        break_slot_after.sequence.return.offset = rel (next_loc);
        break_slot_after.type = BREAK_AFTER;

        /* where we really set the break depends on strangeness */

        if strange_casep ()
	then do;
	  call relocate_instruction_ (
	       addr (break_slot_before.moved_instruction),
	       addr (break_slot_after.moved_instruction), code);
	  if code ^= 0
	    then goto CANT_RELOCATE;
	  break_slot_after.old_instruction =
	       break_slot_before.old_instruction;
	  break_slot_before.old_instruction,
	       break_slot_before.moved_instruction =
	       rel (addr (break_slot_after.sequence)) || TRA_code;

	end;
	else do;
	  break_slot_after.old_instruction = place_to_set -> based_word;
	  call relocate_instruction_
	       (place_to_set, addr (break_slot_after.moved_instruction),
	       code);
	  if code ^= 0
	    then goto CANT_RELOCATE;
	  place_to_set -> based_word =
	       rel (addr (break_slot_after.sequence)) || TRA_code;

	end;
      end;			/* BREAK after code */

    statement_item.slots (break_type) = rel (bsp);
				/* remember the break */

    if added_w_sw
      then call restore_readonly ((Break_source.instruction_ptr));
    return;



CANT_RELOCATE:
    call probe_error_$record (probe_info_ptr, 0,
         "Can't set break because can't relocate instruction at ^p",
         place_to_set);
    goto RECORDED_MESSAGE;

CANT_GET_LENGTH:
    call probe_error_$record (probe_info_ptr, 0,
         "Can't set break because can't get length of instruction at ^p",
         place_to_set);
    goto RECORDED_MESSAGE;



strange_casep:
  proc () returns (bit (1) aligned);

  if before_slot_ptr ^= null ()
    then if before_slot_ptr -> break_slot_before.location = rel (place_to_set)
	 then return ("1"b);
  return ("0"b);
  end strange_casep;




common_break_slot_setup:
  proc (P_bsp);

  dcl P_bsp		ptr parameter;
  dcl absp		ptr;

  absp = P_bsp;

  absp -> break_slot.item_type = BREAK_ITEM;
  absp -> break_slot.breakmap_header_offset = rel (bmp);
  absp -> break_slot.statement_item_offset = rel (stp);
  if Break_source.block_ptr = null ()
    then absp -> break_slot.symbol_block_offset = "0"b;
    else absp -> break_slot.symbol_block_offset =
	    rel (Break_source.block_ptr);
  absp -> break_slot.location = rel (place_to_set);
  absp -> break_slot.count = command_list_size;
  absp -> break_slot.command_list = command || NL;
  end common_break_slot_setup;
  end;				/* set break begin block */
%page;
is_temporary_break:
  entry (P_probe_info_ptr, P_source_info_ptr) returns (bit (1));

  /* Returns "1"b if the stmt pointed to has a temporary break (the before break is "pause"), "0"b otherwise */

  probe_info_ptr = P_probe_info_ptr;
  break_source_info_ptr = P_source_info_ptr;
  seginfop = Break_source.seg_info_ptr;

  number = Break_source.stmnt_map_entry_index;

  call probe_seg_mgr_$get_procedure_entry (probe_info_ptr, seginfop, ent, bmp,
       code);
  if code ^= 0
    then
         return ("0"b);

  if ent ^= null & bmp ^= null then do;

      stp = search_for_stmt (ent, bmp, number);
      if stp ^= null
        then
	   if stp -> statement_item.slots (BREAK_BEFORE) ^= (18)"0"b
	     then do;
	       bsp = pointer (stp, statement_item.slots (BREAK_BEFORE));
	       if bsp -> break_slot.command_list = "pause" || NL
	         then return ("1"b);
				/* a temporary break */
	     end;
    end;
  return ("0"b);
%page;


  /* here are the entries to list breaks - we have four flavors

   list_breaks_at_line
   list_breaks_in_seg
   list_breaks_in_world
   list_broken_segs

*/

list_breaks_at_line:
  entry (P_probe_info_ptr, P_source_info_ptr, P_break_type, P_long_sw, P_code)
       ;

  probe_info_ptr = P_probe_info_ptr;
  break_source_info_ptr = P_source_info_ptr;
  P_code = 0;
  long_sw = P_long_sw;

  seginfop = Break_source.seg_info_ptr;
  break_type = P_break_type;
  happy = "0"b;

  number = Break_source.stmnt_map_entry_index;

  call probe_seg_mgr_$get_procedure_entry (probe_info_ptr, seginfop, ent, bmp,
       P_code);
  if P_code ^= 0
    then
         return;

  if ent ^= null () & bmp ^= null () then do;
      stp = search_for_stmt (ent, bmp, number);
      if stp ^= null then do;
	if stp -> statement_item.slots (BREAK_BEFORE) ^= (18)"0"b &
	     (break_type = BREAK_BEFORE | break_type = BREAK_AT) then do;
	    happy = "1"b;
	    call display_break
	         (ptr (stp, statement_item.slots (BREAK_BEFORE)), "0"b,
	         long_sw);
	  end;
	if stp -> statement_item.slots (BREAK_AFTER) ^= (18)"0"b &
	     (break_type = BREAK_AFTER | break_type = BREAK_AT) then do;
	    happy = "1"b;
	    call display_break
	         (ptr (stp, statement_item.slots (BREAK_AFTER)), "0"b,
	         (long_sw));
	  end;
        end;
    end;

  if ^happy
    then P_code = probe_et_$breakless;
  return;


list_breaks_in_seg:
  entry (P_probe_info_ptr, P_source_info_ptr, P_long_sw, P_code);

  probe_info_ptr = P_probe_info_ptr;
  P_code = 0;
  break_source_info_ptr = P_source_info_ptr;
  happy = "0"b;
  long_sw = P_long_sw;

  seginfop = Break_source.seg_info_ptr;
  call probe_seg_mgr_$get_procedure_entry (probe_info_ptr, seginfop, ent, bmp,
       P_code);
  if P_code ^= 0
    then
         return;

  if ent ^= null () & bmp ^= null ()
    then call list_all_in (long_sw, PRINT, happy);
  if ^happy
    then P_code = probe_et_$no_breaks;
  return;


list_breaks_in_world:
  entry (P_probe_info_ptr, P_long_sw, P_code);

  /* Note similarity to list_broken_segs and reset_breaks_in_world.
   All have exact same control structure (which is right).
   Wish PL/I supported generator-style co-rountines */

  probe_info_ptr = P_probe_info_ptr;
  happy = "0"b;
  P_code = 0;
  long_sw = P_long_sw;
  first = probe_seg_mgr_$first_procedure_ptr (probe_info_ptr, P_code);
  if P_code ^= 0
    then
         return;

  if first ^= null ()
    then
      do ent = first repeat next while (rel (ent) ^= (18)"0"b);
      next = pointer (ent, procedure_entry.chain);
				/* might disappear if found obs */
      bmp = get_breakmap_ptr ();
      if bmp ^= null ()
        then call list_all_in (long_sw, PRINT, happy);
    end;				/* lop over ents */

  if ^happy
    then P_code = probe_et_$no_breaks_set;
  return;

list_broken_segs:
  entry (P_probe_info_ptr, P_code);

  probe_info_ptr = P_probe_info_ptr;
  P_code = 0;

  first = probe_seg_mgr_$first_procedure_ptr (probe_info_ptr, P_code);
  if P_code ^= 0
    then
         return;

  happy = "0"b;

  if first ^= null ()
    then
      do ent = first repeat next while (rel (ent) ^= (18)"0"b);

      next = pointer (first, procedure_entry.chain);
				/* might disappear next line */
      bmp = get_breakmap_ptr ();	/* this could zap it */
      if bmp ^= null () then do;
	if ^happy then do;
	    happy = "1"b;		/* this is the first */
	    call ioa_$ioa_switch (probe_info.output_switch,
	         "Breaks set in:");
	  end;
	call ioa_$ioa_switch (probe_info.output_switch,
	     "   ^a>^a$^a",
	     procedure_entry.directory, procedure_entry.entry,
	     procedure_entry.segname);
        end;
    end;				/* loop */

  if ^happy
    then P_code = probe_et_$no_breaks_set;
  return;

  /* entries to reset breaks

   reset_break_at_line
   reset_breaks_in_seg
   reset_breaks_in_world

*/

reset_break_at_line:
  entry (P_probe_info_ptr, P_source_info_ptr, P_break_type, P_long_sw, P_code)
       ;

  probe_info_ptr = P_probe_info_ptr;
  break_source_info_ptr = P_source_info_ptr;
  seginfop = Break_source.seg_info_ptr;
  number = Break_source.stmnt_map_entry_index;
  break_type = P_break_type;
  long_sw = P_long_sw;
  P_code = 0;
  happy = "0"b;

  call probe_seg_mgr_$get_procedure_entry (probe_info_ptr, seginfop, ent, bmp,
       P_code);
  if P_code ^= 0
    then
         return;
  if ent ^= null () & bmp ^= null () then do;
      stp = search_for_stmt (ent, bmp, number);
      if stp ^= null () then do;
	call ensure_writeable ((bmp));
	saved_stp = stp;
	if stp -> statement_item.slots (BREAK_BEFORE) ^= (18)"0"b &
	     (break_type = BREAK_BEFORE | break_type = BREAK_AT) then do;
	    happy = "1"b;
	    call reset_the_break_at (BREAK_BEFORE, long_sw);

	    if breakmap_deleted_sw
	      then go to RESET_DONE;
	  end;
	stp = saved_stp;
	if stp -> statement_item.slots (BREAK_AFTER) ^= (18)"0"b &
	     (break_type = BREAK_AFTER | break_type = BREAK_AT) then do;
	    happy = "1"b;
	    call reset_the_break_at (BREAK_AFTER, long_sw);
	  end;
	if added_w_sw
	  then call restore_readonly ((bmp));
        end;
    end;				/* non -null break map */

RESET_DONE:
  if ^happy
    then P_code = probe_et_$breakless;
  return;

reset_breaks_in_seg:
  entry (P_probe_info_ptr, P_source_info_ptr, P_long_sw, P_code);

  probe_info_ptr = P_probe_info_ptr;
  P_code = 0;
  break_source_info_ptr = P_source_info_ptr;
  seginfop = Break_source.seg_info_ptr;
  happy = "0"b;

  call probe_seg_mgr_$get_procedure_entry (probe_info_ptr, seginfop, ent, bmp,
       P_code);
  if P_code ^= 0
    then
         return;
  if ent ^= null () & bmp ^= null () then do;
      call ensure_writeable ((bmp));
      call reset_all_breaks_in (long_sw,
	 "0"b /*reset all types, not just pauses*/, happy);
      if added_w_sw
        then call restore_readonly ((bmp));
    end;
  if ^happy
    then P_code = probe_et_$no_breaks;
  return;


reset_breaks_in_world:
  entry (P_probe_info_ptr, P_long_sw, P_code);

  probe_info_ptr = P_probe_info_ptr;
  long_sw = P_long_sw;
  pauses_entry_sw = "0"b;
RESET_ALL:
  happy = "0"b;
  code = 0;

  first = probe_seg_mgr_$first_procedure_ptr (probe_info_ptr, code);
  if code ^= 0 then do;
      if ^pauses_entry_sw
        then P_code = code;
      return;
    end;

  if first ^= null ()
    then
      do ent = first repeat next while (rel (ent) ^= (18)"0"b);
      next = pointer (ent, procedure_entry.chain);
      bmp = get_breakmap_ptr ();
      if bmp ^= null ()
        then do;
	call ensure_writeable ((bmp));
	call reset_all_breaks_in (long_sw, pauses_entry_sw, happy);
	if added_w_sw
	  then call restore_readonly ((bmp));
        end;
    end;

  if ^happy & ^pauses_entry_sw
    then P_code = probe_et_$no_breaks_set;
  return;


reset_all_pause_breaks:
  entry (P_probe_info_ptr);

  probe_info_ptr = P_probe_info_ptr;
  long_sw = "0"b;
  pauses_entry_sw = "1"b;

  go to RESET_ALL;

print_instructions:
  entry (P_probe_info_ptr, P_source_info_ptr, P_instruction_ptr, P_len);

  /* Prints the instructions for a given line, without showing the break instruction */

  probe_info_ptr = P_probe_info_ptr;
  break_source_info_ptr = P_source_info_ptr;

  seginfop = Break_source.seg_info_ptr;
  number = Break_source.stmnt_map_entry_index;
  ent, bmp, slot_ptr = null;

  /* Find out if any breaks are set at this line */

  call probe_seg_mgr_$get_procedure_entry (probe_info_ptr, seginfop, ent, bmp,
       0);
  if ent ^= null & bmp ^= null then do;

      stp = search_for_stmt (ent, bmp, number);
      if stp ^= null then do;

	after_sw = "0"b;
	slot_offset = stp -> statement_item.slots (BREAK_BEFORE);
	if slot_offset ^= (18)"0"b
	  then slot_ptr = pointer (stp, slot_offset);
	  else do;
	    after_sw = "1"b;
	    slot_offset = stp -> statement_item.slots (BREAK_AFTER);
	    if slot_offset ^= (18)"0"b
	      then slot_ptr = pointer (stp, slot_offset);
	      else slot_ptr = null;
	  end;
        end;
    end;

  /* If there is one, temporarily replace it with the original instruction */

  if slot_ptr ^= null then do;

      call ensure_writeable ((bmp));

      if after_sw then do;
	instruction_ptr =
	     pointer (P_instruction_ptr,
	     slot_ptr -> break_slot_after.location);
	saved_instruction = instruction_ptr -> based_word;
	instruction_ptr -> based_word =
	     slot_ptr -> break_slot_after.old_instruction;
        end;
        else do;
	instruction_ptr =
	     pointer (P_instruction_ptr,
	     slot_ptr -> break_slot_before.location);
	saved_instruction = instruction_ptr -> based_word;
	instruction_ptr -> based_word =
	     slot_ptr -> break_slot_before.old_instruction;
        end;
    end;

  /* Print the instructions for the statement */

  call print_instructions_ (P_instruction_ptr, P_len,
       probe_info.output_switch);

  /* Now replace the break if necessary */

  if slot_ptr ^= null then do;

      instruction_ptr -> based_word = saved_instruction;

      if added_w_sw
        then call restore_readonly ((bmp));
    end;
  return;


  /* ************************ INTERNAL PROCS ********************* */


list_all_in:
  proc (P_long, P_print, P_exists);


  dcl P_long		bit (1) aligned parameter;
				/* input: include command list? */
  dcl P_print		bit (1) aligned parameter;
  dcl P_exists		bit (1) aligned parameter;

  /* GLOBAL imports: ent, bmp,  and sets stp */

  /* Note that P_exists is SET if we FIND a break, but not cleared if we don't
   although the presence of a procedure entry that has no breaks, yet hasn't been
   garbaged collected is a bit frightening */

  do stp = pointer (bmp, procedure_entry.first_statement)
       repeat pointer (bmp, statement_item.chain)
       while (rel (stp) ^= "0"b);
    if statement_item.slots (BREAK_BEFORE) ^= "0"b
      then do;
        P_exists = "1"b;
        if ^P_print
	then
	     return;
        call display_break (
	   pointer (stp, statement_item.slots (BREAK_BEFORE)), "1"b,
	   (P_long));
      end;
    if statement_item.slots (BREAK_AFTER) ^= "0"b then do;
        P_exists = "1"b;
        if ^P_print
	then
	     return;
        call display_break (pointer (stp, statement_item.slots (BREAK_AFTER)),
	   "1"b, (P_long));
      end;
  end;				/* loop */
  end list_all_in;



display_break:
  proc (P_bsp, P_want_proc_name, P_long);

  dcl P_bsp		ptr parameter;
  dcl P_want_proc_name	bit (1) aligned parameter;
  dcl P_long		bit (1) aligned parameter;

  /* GLOBAL! ent stp  *** used by list_break */

  call ioa_$ioa_switch (probe_info.output_switch,
       "Break exists ^a ^[ :^a^;^s^]",
       formatted_break_line ((ent), (stp), (P_bsp), (P_want_proc_name)),
       P_long, P_bsp -> break_slot.command_list);
  end display_break;

formatted_break_line:
  proc (P_ent, P_stp, P_bsp, P_proc) returns (char (132) varying);

  dcl P_ent		ptr parameter;
  dcl P_stp		ptr parameter;
  dcl P_bsp		ptr parameter;
  dcl P_proc		bit (1) aligned parameter;
  dcl ioa_$rsnnl		entry options (variable);
  dcl linestr		char (132) varying;

  dcl 1 map_array		(map_size) like statement_map based (map_ptr);
  dcl map_size		fixed bin;
  dcl map_ptr		ptr;
  dcl number		fixed bin;
  dcl file		fixed bin;
  dcl line		fixed bin;
  dcl stmt		fixed bin;
  dcl use_this_name           char(32) unaligned;
  

  if (probe_info.language_type ^= C_lang_type) then
    use_this_name = P_ent->procedure_entry.segname;
  else
    use_this_name = P_ent->procedure_entry.entry;

  map_ptr = pointer (P_stp, P_ent -> procedure_entry.statement_map);
  map_size = fixed (P_ent -> procedure_entry.statement_map_size, 24);
  number = P_stp -> statement_item.number;

  if map_ptr ^= null () & number <= map_size then do;
				/* have legit number */
      file = fixed (map_array (number).file, 8);
      line = fixed (map_array (number).line, 14);
      stmt = fixed (map_array (number).statement, 5);

      call ioa_$rsnnl ("^a line ^[^d-^;^s^]^d^[,^d^;^s^]^[ in ^a^;^s^]",
	 linestr, (0),
	 PLACE (P_bsp -> break_slot.type),
	 file > 0, file,
	 line,
	 stmt > 1, stmt,
	 P_proc, use_this_name);
    end;
    else do;
      call ioa_$rsnnl ("^a|^o", linestr, (0),
            use_this_name,
	 fixed (P_bsp -> break_slot.location, 18));
    end;

  return (linestr);
  end formatted_break_line;

create_statement_entry:
  proc (P_ent, P_bmp, P_number) returns (ptr);

  dcl (
      P_ent		ptr,
      P_bmp		ptr,
      P_number		fixed bin
      )			parameter;

  dcl (ent, bmp)		ptr;
  dcl new_stmt		ptr;

  ent = P_ent;
  bmp = P_bmp;

  new_stmt = allocate_in_breakmap (size (statement_item));
  new_stmt -> statement_item.item_type = STATEMENT_ITEM;
  new_stmt -> statement_item.number = P_number;
  new_stmt -> statement_item.slots = (18)"0"b;
  new_stmt -> statement_item.proc_entry = rel (ent);
  new_stmt -> statement_item.identifier = ent -> procedure_entry.time_stamp;
  new_stmt -> statement_item.chain = ent -> procedure_entry.first_statement;

  ent -> procedure_entry.first_statement = rel (new_stmt);
  return (new_stmt);
  end create_statement_entry;



delete_statement_entry:
  proc ();

  /* GLOBAL! bmp ent stp */

  /* unthread the statement and delete it */

  dcl prev		ptr;	/* to statement item before the one to kill */

  if procedure_entry.first_statement = rel (stp)
    then procedure_entry.first_statement = statement_item.chain;
    else do;			/* not first, must search for predecessor */
      do prev = pointer (stp, procedure_entry.first_statement)
	 repeat pointer (prev, prev -> statement_item.chain)
	 while (prev -> statement_item.chain ^= rel (stp));
        if prev -> statement_item.chain = "0"b
				/* NOT FOUND */
	then call probe_error_$malfunction (probe_info_ptr, 0,
		"Break statement item ^p not found on chain of proc entry ^p",
		stp, ent);
      end;			/* search */
      prev -> statement_item.chain = statement_item.chain;
    end;

  call release_in_breakmap ((stp));
  end delete_statement_entry;




search_for_stmt:
  proc (P_ent, P_bmp, P_map_number) returns (ptr);
  dcl (
      P_ent		ptr,
      P_bmp		ptr,
      P_map_number		fixed bin
      )			parameter;

  dcl bmp			ptr;
  dcl map_number		fixed bin;
  dcl p			ptr;

  map_number = P_map_number;
  bmp = P_bmp;
  do p = pointer (bmp, P_ent -> procedure_entry.first_statement)
       repeat (pointer (bmp, p -> statement_item.chain))
       while (rel (p) ^= (18)"0"b);
    if p -> statement_item.number = map_number
      then
	 return (p);
  end;
  return (null ());
  end search_for_stmt;


reset_all_breaks_in:
  proc (P_long, P_pauses_only, P_existed);

  /* GLOBAL imports bmp, stp, ent */

  dcl P_long		bit (1) aligned parameter;
				/* shall we tell of them as they go? */
  dcl P_pauses_only		bit (1) aligned parameter;
				/* ON => reset only breaks set by "step" */
  dcl P_existed		bit (1) aligned parameter;
				/* set, if we find one - should always happen */

  dcl next		ptr;

  do stp = pointer (bmp, procedure_entry.first_statement) repeat next
       while (rel (stp) ^= "0"b);
    next = pointer (stp, statement_item.chain);
    if statement_item.slots (BREAK_BEFORE) ^= "0"b then do;
        saved_stp = stp;
        P_existed = "1"b;
        if ^P_pauses_only | ptr (stp, statement_item.slots (BREAK_BEFORE)) ->
	   break_slot_before.command_list = "pause" || NL
	then /* a break set by "step" */
	     call reset_the_break_at (BREAK_BEFORE, (P_long));

        if breakmap_deleted_sw
	then
	     return;

        stp = saved_stp;
      end;
    if statement_item.slots (BREAK_AFTER) ^= "0"b then do;
        saved_stp = stp;
        P_existed = "1"b;
        if ^P_pauses_only | ptr (stp, statement_item.slots (BREAK_AFTER)) ->
	   break_slot_after.command_list = "pause" || NL
	then /* a break set by "step" */
	     /* (shouldn't be any pause breaks after, but) */
	     call reset_the_break_at (BREAK_AFTER, (P_long));

        if breakmap_deleted_sw
	then
	     return;

        stp = saved_stp;
      end;
  end;				/* stmt loop */
  end reset_all_breaks_in;



reset_the_break_at:
  proc (P_type, P_long);

  dcl P_type		fixed bin parameter;
  dcl P_long		bit (1) aligned parameter;
  dcl other_type		fixed bin;
  dcl breaks_found		bit (1) aligned;

  /* GLOBAL! ent bmp stp */

  /* Remove the break - replace patched TRA **KLUDGE if active**
   Free the break slot
   If statement now empty, then remove it
   if proc now empty, then remove it
   if breakmap now empty, then  remove it

   If message desired, give the message

   Note: in version 3 probe, the garbage collecting was only done
   after an attempt to reset all breaks in a seg.  i suppose that was for efficiency.  In any event,
   it seems like old proc entries were not pruned.  That bug may have its cause elsewhere, tho.
*/
  breakmap_deleted_sw = "0"b;

  if P_long & ^probe_static_info.brief_sw
    then call ioa_$ioa_switch (probe_info.output_switch,
	    "Break reset ^a",
	    formatted_break_line ((ent), (stp),
	    pointer (stp, statement_item.slots (P_type)), "1"b));


  call remove_break ((P_type));

  statement_item.slots (P_type) = "0"b; /* forgotten */

  if P_type = BREAK_BEFORE
    then other_type = BREAK_AFTER;
    else other_type = BREAK_BEFORE;

  if statement_item.slots (other_type) = "0"b
    then call delete_statement_entry ();

  /* Delete the break map if there are no breaks left */

  breaks_found = "0"b;
  call list_all_in (BRIEF, NO_PRINT, breaks_found);
  if ^breaks_found then do;
      breakmap_deleted_sw = "1"b;

      call delete_breakmap ();
    end;


  if procedure_entry.first_statement
       = "0"b /* that was last stmt we just deleted */
    then do;
      call restore_readonly ((bmp));
      call probe_seg_mgr_$delete_procedure_entry (probe_info_ptr, ent, code);
				/* someday, consider macros & symbols */
    end;

  end reset_the_break_at;

remove_break:
  proc (P_type);

  dcl P_type		fixed bin parameter;

  /* GLOBAL bmp, stp */

  /* Unset the break. Unlink the slot. Free its storage.
   it was once thought (judging from the comments) that the way to rese an active break was to set a flag
   somewhere, then call an entry "release_break" to reset the break when continueing.  After that, somebody
   changed probe to kludge the probe data structures so that active breaks could be reset.
   i wonder what happens if the break request list of a break resets the break?????
*/

  dcl p			ptr;
  dcl pi_ptr		ptr;	/* to probe_info in past lives */
  dcl patch_place		ptr;	/* where to reset */
  dcl absp		ptr;	/* to slot to kill */
  dcl strange		bit (1) aligned;

  dcl based_word		bit (36) aligned based;

  absp = pointer (stp, statement_item.slots (P_type));

  if P_type = BREAK_AFTER & statement_item.slots (BREAK_BEFORE) ^= "0"b
    then do;			/* may be "strange" */
      p = pointer (stp, statement_item.slots (BREAK_BEFORE));
				/* pt to break slot for before */
      strange =
	 p -> break_slot_before.location
	 = absp -> break_slot_after.location;
    end;
    else strange = "0"b;

  patch_place = pointer (absp, absp -> break_slot.location);

  if strange then do;
      call relocate_instruction_ (
	 addr (absp -> break_slot_after.moved_instruction),
	 addr (p -> break_slot_before.moved_instruction), (0));
      p -> break_slot_before.old_instruction =
	 absp -> break_slot_after.old_instruction;
      patch_place -> based_word =
	 rel (addr (p -> break_slot_before.sequence)) || TRA_code;
				/* ughh */
    end;
    else patch_place -> based_word = absp -> break_slot.old_instruction;

  /* KLUDGE TIME - search back through all current invocations of probe for any who were invoked using
   this break */

  if P_type = BREAK_AFTER		/* where to return to */
    then patch_place = addrel (patch_place,
				/* instruction after broken one */
	    inst_length_ (addr (absp -> break_slot_after.old_instruction),
	    (0)));

  do pi_ptr = probe_info_ptr
       repeat pi_ptr -> probe_info.listener_info.previous
       while (pi_ptr ^= null ());
    if pi_ptr -> probe_info.break_slot_ptr = absp then do;
        p = pi_ptr -> probe_info.ptr_to_initial_source
	   -> source_info.stack_ptr -> stack_frame.next_sp;
        break_extension_info_ptr = addrel (p, -size (probe_break_extension));
        probe_break_extension.slot_return_addr = patch_place;

        if break_map.version >= 3
	then pi_ptr -> probe_info.real_break_return_loc =
		addr (probe_map_sequence_$return);
	else pi_ptr -> probe_info.real_break_return_loc =
		addr (probe_map_sequence_$old_return);
      end;
  end;				/* loop */

  call release_in_breakmap (absp);
  end remove_break;

create_breakmap:
  proc ();

  /* GLOBAL! seginfop SETS! bmp */

  dcl segp		ptr;	/* to seg in question */
  dcl correction		fixed bin (24);
  dcl bitcount		fixed bin (24);
  dcl wordcount		fixed bin (35);
  dcl obj_map_ptr		ptr;

  dcl 1 last_word_in_seg	aligned based,
       2 map_relp		bit (18) unal,
       2 lower_half		bit (18) unal;
  dcl copy		(copy_count) bit (36) aligned based;
  dcl copy_count		fixed bin;

  dcl hcs_$status_mins	entry (ptr, fixed bin (2), fixed bin (24),
			fixed bin (35));


  segp = seginfop -> seg_info.symbol_header_ptr;
  call hcs_$status_mins (segp, (0), bitcount, code);
  if code ^= 0
    then goto C_LOSS;
  wordcount = divide (bitcount, 36, 35, 0);
  obj_map_ptr =
       pointer (segp,
       pointer (segp, wordcount - 1) -> last_word_in_seg.map_relp);

  bmp = find_breakmap ();

  if bmp ^= null ()
    then
         if break_map.name ^= "breakmap" then do;
	   call probe_error_$record (probe_info_ptr, probe_et_$breaks_exist,
	        seginfop -> seg_info.segname);
	   go to RECORDED_MESSAGE;
	 end;
         else if break_map.version < 3
	 then code = probe_et_$old_break_map;
  if code ^= 0
    then goto C_LOSS;

  if bmp ^= null ()
    then
         return;			/* use existing breakmap */

  /* in theory, we are not called if map already existed, so this might be a bug */

  /* must create it, aligned for ptr */

  wordcount = wordcount + mod (wordcount, 2);
  bmp = pointer (segp, wordcount);

  /* may have to extend max length here */

  break_map.version = 3;
  break_map.name = "breakmap";
  break_map.identifier = seginfop -> seg_info.bound_create_time;
  break_map.symbol_header = rel (seginfop -> seg_info.bound_sym_header);

  /* now copy map_sequence code into break map */

  copy_count = probe_map_sequence_$count;
  addr (break_map.map_sequence) -> copy =
       addr (probe_map_sequence_$code) -> copy;

  wordcount = wordcount + size (break_map) + copy_count - 2;
				/* don't count ptr at end of map */
  wordcount = wordcount + mod (wordcount, 2);
  break_map.initial_word_count = wordcount;
  break_map.word_count = bit (binary (wordcount, 18, 0));

  /* upper bound is set to fill  page exactly */
  wordcount = fill_to_brim ((wordcount));
  break_map.upper_bound = bit (binary (wordcount, 18, 0));

  bitcount = (wordcount + 4) * 36;	/* why the + 4)? */
  call hcs_$set_bc_seg (bmp, bitcount, (0));

  pointer (bmp, binary (break_map.upper_bound, 18, 0) + 3)
       -> last_word_in_seg.map_relp = rel (obj_map_ptr);

  /* in version 3 probe, a pointer to the break_map was kept in the seg_info for
   either the bound_seg as  a whole (or the sole seg_info, for unbound).  But we
   dispense with this as I don't see what use it is (It was used in the break_handler)
*/

  if obj_map_ptr -> object_map.decl_vers = object_map_version_2
    then obj_map_ptr -> object_map.break_map_offset = rel (bmp);
    else obj_map_ptr -> old_object_map.break_map_offset = rel (bmp);
  return;



delete_breakmap:
  entry;

  /* GLOBAL bmp! */


  if addrel (bmp, -1) -> last_word_in_seg.map_relp ^= "0"b
    then correction = 0;
    else correction = -1;		/* break map always begins on even word;
						   must find real last word */
  obj_map_ptr =
       pointer (bmp,
       addrel (bmp, correction - 1) -> last_word_in_seg.map_relp);

  if obj_map_ptr -> object_map.decl_vers = object_map_version_2
    then obj_map_ptr -> object_map.break_map_offset = "0"b;
    else obj_map_ptr -> old_object_map.break_map_offset = "0"b;

  copy_count =
       binary (break_map.word_count, 18, 0) - fixed (rel (bmp), 18, 0) + 4;
  bmp -> copy = "0"b;

  bitcount = (binary (rel (bmp), 24, 0) + correction) * 36;

  call hcs_$set_bc_seg (bmp, bitcount, (0));
  return;

C_LOSS:
  call probe_error_$record (probe_info_ptr, code);
  goto RECORDED_MESSAGE;


find_breakmap:
  proc () returns (ptr);

  if obj_map_ptr -> object_map.identifier ^= "obj_map "
    then code = probe_et_$non_standard;

  else if obj_map_ptr -> object_map.decl_vers = object_map_version_2
    then if obj_map_ptr -> object_map.break_map_offset ^= "0"b
	 then
	      return (
		 pointer (obj_map_ptr,
		 obj_map_ptr -> object_map.break_map_offset));
	 else
	      return (null ());

  else if obj_map_ptr -> object_map.decl_vers = 1
    then if obj_map_ptr -> old_object_map.break_map_offset ^= "0"b
	 then
	      return (
		 pointer (obj_map_ptr,
		 obj_map_ptr -> old_object_map.break_map_offset));
	 else
	      return (null ());

  else code = probe_et_$non_standard;
  return (null ());

  end find_breakmap;

  end create_breakmap;		/* and delete_breakmap */



get_breakmap_ptr:
  proc returns (ptr);

  /* GLOBAL! imports ent */

  dcl hcs_$initiate		entry (char (*), char (*), char (*),
			fixed bin (1), fixed bin (2), ptr,
			fixed bin (35));
  dcl hcs_$terminate_noname	entry (ptr, fixed bin (35));

  dcl segp		ptr;


  call hcs_$initiate (procedure_entry.directory, procedure_entry.entry, "", 0,
       0, segp, (0));

  if segp ^= null () then do;		/* still exists, but may be modified */
      segp = pointer (segp, procedure_entry.break_map);
				/* look where map is spozed to be */
      if segp -> break_map.identifier = procedure_entry.time_stamp
        then
	   return (segp);
        else call hcs_$terminate_noname (segp, (0));
    end;

  /* either seg no longer exists, or has been recompiled.
   In either case, the procedure entry is obsolete and should be destroyed */

  call probe_seg_mgr_$delete_procedure_entry (probe_info_ptr, (ent), (0));

  return (null ());
  end get_breakmap_ptr;

ensure_writeable:
  proc (segptr);

  dcl segptr		ptr parameter;
				/* to the seg in question */

  dcl hcs_$fs_get_mode	entry (ptr, fixed bin (5), fixed bin (35));

  dcl mode		fixed bin (5);


  call hcs_$fs_get_mode (segptr, mode, code);
  if code ^= 0
    then goto ACL_LOSS;

  if divide (mode, 2, 17, 0) < 7 /* we don't have rew */
    then do;
      added_w_sw = "1"b;
      call hcs_$fs_get_path_name (segptr, acl_dn, (0), acl_en, code);
      if code ^= 0 then do;
ACL_LOSS:
	call probe_error_$record (probe_info_ptr, code);
	go to RECORDED_MESSAGE;
        end;

      acl_count = 1;
      seg_acl.access_name = get_group_id_ ();
      seg_acl.modes, seg_acl.zero_pad = "0"b;

      call hcs_$list_acl (acl_dn, acl_en, null, null, addr (seg_acl), 1, code)
	 ;
      if seg_acl (1).status_code ^= 0
        then saved_mode_sw = "0"b;
        else do;
	saved_mode_sw = "1"b;
	saved_mode = substr (seg_acl (1).modes, 1, 3);
        end;

      call set_access ("111"b);	/* force rew */
    end;

    else added_w_sw = "0"b;
  return;


restore_readonly:
  entry (segptr);


  if added_w_sw
    then
         if saved_mode_sw
	 then call set_access (saved_mode);
	 else call hcs_$delete_acl_entries (acl_dn, acl_en, addr (seg_acl),
		 1, 0);
				/* if there was no term for group_id, delete the added one */
  return;


set_access:
  proc (new_mode);

  dcl new_mode		bit (3) parameter;

  seg_acl.modes = new_mode;

  call hcs_$add_acl_entries (acl_dn, acl_en, addr (seg_acl), 1, code);
  if code ^= 0
    then goto ACL_LOSS;
  end set_access;

  end;				/* ensure_writeable */





fill_to_brim:
  proc (wordct) returns (fixed bin (35));

  /* given word ct, get next highest word ct that uses its pages to the max. */

  dcl wordct		fixed bin (35) parameter;
  dcl wordtp		fixed bin (35);

  wordtp = wordct + 1023;		/* make next higher word ct */
  wordtp = divide (wordtp, 1024, 0);	/* number of pages */
  wordtp = multiply (wordtp, 1024, 35, 0);
				/* restore word ct */
  wordtp = subtract (wordtp, 4, 35, 0); /* dont know why */

  return (wordtp);
  end fill_to_brim;

allocate_in_breakmap:
  procedure (required) returns (pointer);

  dcl required		fixed bin parameter;
				/* number of words needed */

  dcl needed		fixed bin;/* 0 mod 2 size */
  dcl fip			pointer;
  dcl lfip		pointer;
  dcl word		bit (36) based;

  needed = required + mod (required, 2);/* 0 mod 2 size */
  lfip = null ();
  do fip = pointer (bmp, break_map.first_free_item)
       repeat pointer (fip, fip -> free_item.chain)
       while (rel (fip) ^= (18)"0"b);

    /* search for a free item that can contain the allocation */

    if fip -> free_item.size >= needed then do;
				/* this one will work */
        if fip -> free_item.size = needed then do;
				/* occupies entire area */
	  if lfip ^= null ()
	    then
	         lfip -> free_item.chain = fip -> free_item.chain;
				/* skip this one */
	    else break_map.first_free_item = fip -> free_item.chain;
	end;
	else do;			/* only uses part, let rest remain free */
	  fip -> free_item.size = fip -> free_item.size - needed;
	  fip = addrel (fip, fip -> free_item.size);
				/* use top part */
	end;
        fip -> item.size = needed;	/* fill in for freeing */
        return (fip);
      end;

    lfip = fip;
  end;				/* of loop through chain */

  /* if we get here, weither there were no free areas, or there were none large enough, in
   either case, allocate the space at the end of the segment */

  fip = pointer (bmp, break_map.word_count);
  fip -> item.size = needed;
  break_map.word_count =
       bit (add (binary (break_map.word_count, 18, 0), needed, 18, 0));

  /* must check if this allocation has overflowed the area, if so we will extend it */

  if break_map.word_count > break_map.upper_bound then do;
      break_map.upper_bound =
	 bit (
	 subtract (
	 multiply (divide (add (binary (break_map.word_count, 18, 0),
	 1023, 18, 0), 1024, 18, 0), 1024, 18, 0), 4, 18, 0));

      call hcs_$set_bc_seg (bmp,
	 multiply (binary (break_map.upper_bound, 18, 0) + 4, 36, 24, 0),
	 (0));
				/* an error here will only cause move problems */
      addrel (pointer (bmp, break_map.upper_bound), 3) -> word =
	 addrel (bmp, -1) -> word;
    end;
  return (fip);
  end allocate_in_breakmap;


release_in_breakmap:
  procedure (item_pointer);

  dcl item_pointer		pointer,	/* pointer to the item itself */
      ip			pointer,	/* working copies of the above */
      i			fixed bin (35),
				/* offset of item */
      (p, lp)		pointer;
  dcl copy_overlay		(copy_count) bit (36) aligned based;
				/* for zeroing */
  dcl copy_count		fixed bin;


  ip = item_pointer;		/* copy pointers */
  i = binary (rel (ip), 18, 0);

  /* first check if item is at the end of the segment */

  if i + ip -> item.size
       = binary (break_map.word_count, 18, 0) /* it is at the end */
    then do;
      break_map.word_count = rel (ip);
      copy_count = ip -> item.size;
      ip -> copy_overlay = "0"b;	/* zero out words at the end of a segment */

      lp = null ();
      do p = pointer (bmp, break_map.first_free_item)
	 repeat pointer (p, p -> free_item.chain)
	 while (rel (p) ^= (18)"0"b); /*  see if this leaves one at the end of the area */

        if addrel (p, p -> free_item.size) = ip then do;
				/* this one is at the end, so remove it */
	  break_map.word_count = rel (p);
				/* new length */
	  if lp ^= null ()		/* remove form chain */
	    then lp -> free_item.chain = (18)"0"b;
				/* as items are order, this is the last */
	    else break_map.first_free_item = (18)"0"b;
	  copy_count = p -> free_item.size;
				/* zero it out */
	  p -> copy_overlay = "0"b;
	  return;
	end;

      end;
      return;
    end;

  /* no, free it within the area */

  if break_map.first_free_item then do; /* if this is not the only one, we will have to
						   check if it is contguous with the others */
      lp = null ();
      do p = pointer (bmp, break_map.first_free_item)
	 repeat pointer (p, p -> free_item.chain);
				/* termination condition checked below */

        if i < binary (rel (p), 18, 0) then do;
				/* the item goes here */
	  if lp ^= null /* if there is a previous item look at it */
	    then do;
	      if addrel (lp, lp -> free_item.size)
		 = ip /* last one and new one touch */
	        then do;
		lp -> free_item.size =
		     lp -> free_item.size + ip -> item.size;
		ip = lp;		/* we are now interested in the combination */
	        end;
	        else do;
		ip -> free_item.size = ip -> item.size;
		lp -> free_item.chain = rel (ip);
	        end;
	    end;
	    else do;
	      ip -> free_item.size = ip -> item.size;
	      break_map.first_free_item = rel (ip);
	    end;

	  if addrel (ip, ip -> free_item.size)
	       = p /* the new one and the next one touch */
	    then do;
	      ip -> free_item.size =
		 ip -> free_item.size + p -> free_item.size;
	      ip -> free_item.chain = p -> free_item.chain;
	    end;
	    else do;
	      ip -> free_item.chain = rel (p);
	    end;
	  return;			/* all done */
	end;

        if p -> free_item.chain
	   = (18)"0"b /* if this is the end of the chain, put it here */
	then do;
	  if addrel (p, p -> free_item.size) = ip
	    then p -> free_item.size =
		    p -> free_item.size + ip -> item.size;
	    else do;
	      ip -> free_item.size = ip -> item.size;
	      ip -> free_item.chain = (18)"0"b;
	      p -> free_item.chain = rel (ip);
	    end;
	  return;
	end;

      end;			/* of search through free chain */

    end;

  /* first free_item, start the chain */

  break_map.first_free_item = rel (ip);
  ip -> free_item.chain = (18)"0"b;
  ip -> free_item.size = ip -> item.size;
  return;

  end release_in_breakmap;

  /* * 			***** DATA STRUCTURES USED IN BREAKS *****

   (also see the probe implementation guide)

   the probe seg (or the break seg) it is in user's homedir and is named [user name].probe

   the object seg containing a break has a section called the breakmap - this begins
   with a breakmap header.  It is impure object segment.  Only one user may probe (or debug)
   segment at a time - the results of more than one user attempting to write
   are undefined

   The break seg begins with a break segment header, which contains the offsets (relative to base of the seg)
   of the first item of each of the following types:

   PROCEDURE -  a procedure entry describes an object seg that has breaks in it
   FREE	  - a free item is just some free storage
   SYMBOL	  - unused today, someday use to hold probe "variables" maybe
   MACRO	  - unused today, someday can hold request list for probe "macros" maybe

   Note that we do our own allocation and garbage-collection in the probe seg and in the break_map
   There is no good reason for this! (other than history)  if there were more time, I'd convert them
   both to be areas.

   In the break map we   have the break map header, and the statement entries (one for each line that has a break)
   and the break_slots (one for each break).  The last portion of the break_map_header is the "map_sequence",
   which is object code executed to cause a break.  It is extraordinarily hirsute!

   Statement_items are chained together.  The offset of the first is stored in the corresponding
   procedure entry in the probe seg.    A statement item has (among other things) the index into the
   statement_map array for the line it represents, an offset to the procedure entry it is part of
   (relative to the base of the probe_seg), and the offsets (relative to the base of the object seg) of
   the break_slots for the breaks before or after its line.

   A break_slot consists of per-break information.  The break request list is stored here
   (actual characters).  Also the relocated instruction from where the break was.

   Breaks are implemented as a "tra" to a break_slot.  There are eight words of executable code
   in each break_slot.  The "map_sequence" referred to above is the common code for each type of break.
   The code in "sequence" for each type of break is:

   * before:  spri	sp|stack_frame.next_sp,*	after:    <instruction>
   * 	  tsplb	map_sequence			nop	0,du
   * 	  nop	slot,du				nop	0,du
   * 	  <instruction>				nop	0,du
   * 	  nop	0,du				spri	sp|stack_frame.next_sp,*
   * 	  nop	0,du				tsplb	map_sequence
   * 	  nop	0,du				nop	slot,du
   * 	  tra	old_loc+il			tra	old_loc+il


   Certain of these instructions are "patched" when the break_slot is created:
   The offset of the map_sequence, and the location in the object segment to return to.
   The offset of the break_slot is saved in a "nop" instruction, where the map_sequence code   can get it.
   The instruction in the object seg is relocated into the break_slot, along with its descriptors if any.
   The instruction is replaced by a "tra" to the sequence in the break slot.

*/

%include probe_info;
%include probe_static_info;
%include probe_lang_types;
%include probe_source_info;
%include probe_seg_info;
%include probe_break_slot;
%include probe_break_extension;
%include probe_break_info;
%include object_map;
%include probe_old_object_map;
%include acls;
%include statement_map;
%include stack_frame;

  end probe_break_mgr_;




		    probe_builtins_.pl1             11/11/88  1554.4r w 11/11/88  1545.0      212535



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



/****^  HISTORY COMMENTS:
  1) change(88-06-01,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Changed the code in the 'addr_builtin' entry to allow the address of
     a constant to be taken only when we are referring to a C character
     array that has been internally converted to a character string
     constant.
  2) change(88-06-21,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added the 'sizeof_builtin' entry and the appropriate code to perform
     the task.
  3) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

probe_builtins_:
  proc;


  /* All probe builtins are here - each builtin has same calling sequence.
   The reference_node we get a pointer to is pounded on pretty hard as the builtin is evaluated
   The arguments to the builtin are stored as reference_nodes in their own right,
   and the pointers to the ref nodes are in the array sub_refs (see below).

   Someday, builtins might want to work on cross-sections:
   this would require calling increment_indices to iterate over the reference
   We would have to construct an array of return values (that isn't hard, but must know
   how many will be needed at allocate time, which would be before iterating),
   then fill in as we iterate.

   Designed and Coded by Jim Davis 11 Aug 79
   Modified 17 Aug 79

   Modified June 83 JMAthane to add following entries:
   probe_builtins_$pascal_nil_builtin
   probe_builtins_$pascal_false_builtin
   probe_builtins_$pascal_true_builtin
   probe_builtins_$pascal_chr_builtin
   probe_builtins_$pascal_ord_builtin
   probe_builtins_$pascal_eof_builtin
   probe_builtins_$pascal_eoln_builtin
*/
  /* Fixed unspec to work on structures and arrays 08/12/83 S. Herbst */
  /* Changed to call get_size_in_bits_$structure with ref_ptr, handle var extents 06/05/84 S. Herbst */

  call probe_error_$malfunction ();

  dcl (
      P_probe_info_ptr	ptr,
      P_refp		ptr,	/* to a reference node */
      P_code		fixed bin (35)
      )			parameter;

  dcl 1 P_reference		aligned like reference_node based (refp);
  dcl refp		ptr;	/* copy of P_refp */

  dcl 1 sub_refs		aligned like subscript_reference_ptrs
			based (P_reference.subscript_refs_ptr);
  dcl 1 subscript		aligned based (sub) like reference_node;
				/* an arbitrary arg */

  dcl sub			ptr;	/* to one of our args */
  dcl data_length		fixed bin (35);
  dcl start		fixed bin (35);
  dcl ptr_bitno		fixed bin (35);
				/* bit offset ofptr used in "ptr" builtin */

  dcl bit_array		(data_length) bit (1) unal based;
				/* used in substr builtin to get addr */
  dcl char_array		(data_length) char (1) unal based;

  dcl based_ptr		ptr based;
  dcl based_integer		fixed bin (35) based;

  dcl ioa_$ioa_switch	entry options (variable);
				/* used for warnings */

  dcl probe_error_$record	entry options (variable);
  dcl probe_error_$malfunction
			entry options (variable);

  dcl get_size_in_bits_	entry (fixed bin, fixed bin (35),
			bit (1) aligned) returns (fixed bin);
  dcl get_size_in_bits_$structure
			entry (ptr) returns (fixed bin);

  dcl probe_et_$recorded_message
			fixed bin (35) external static;

  dcl p1			ptr;

  dcl i			fixed bin (35);

  dcl 1 p			based,
       2 p1		bit (30) unal,
       2 ftag		bit (6) unal,
       2 p2		bit (36) unal;

  dcl (addr, addrel, baseno, baseptr, divide, fixed, null, pointer, rel)
			builtin;

RECORDED_MESSAGE:
  P_code = probe_et_$recorded_message;
EXIT_HERE:

  return;

probe_builtins_$addr_builtin:
  entry (P_probe_info_ptr, P_refp, P_code);

  call setup (1, 1);

  sub = sub_refs (1, 1).ptr;
  if subscript.constant & ^subscript.pseudo_var &
       ^(subscript.type = 21
       & P_probe_info_ptr -> probe_info.random_info.language_type
       = C_lang_type) then do;
      call probe_error_$record (probe_info_ptr, 0,
	 "Can't get the address of a constant");
      goto RECORDED_MESSAGE;
    end;
  pointer_bif () -> based_ptr = subscript.address_ptr;
  goto EXIT_HERE;

probe_builtins_$pascal_nil_builtin:
  entry (P_probe_info_ptr, P_refp, P_code);

probe_builtins_$null_builtin:
  entry (P_probe_info_ptr, P_refp, P_code);

  call setup (0, 0);
  pointer_bif () -> based_ptr = null ();
  goto EXIT_HERE;

probe_builtins_$octal_builtin:
  entry (P_probe_info_ptr, P_refp, P_code);

  call setup (1, 1);

  call octunspecom;
  P_reference.octal = "1"b;
  goto EXIT_HERE;

probe_builtins_$unspec_builtin:
  entry (P_probe_info_ptr, P_refp, P_code);

  call setup (1, 1);
  call octunspecom;
  goto EXIT_HERE;

probe_builtins_$substr_builtin:
  entry (P_probe_info_ptr, P_refp, P_code);

  call setup (2, 3);

  P_reference.pseudo_var = "1"b;
  sub = sub_refs.ptr (1, 1);
  call require_string (1);
  if data_type_info_$info (subscript.type).varying
    then do;
      P_reference.type = subscript.type - 1;
				/* same type, nonvarying */
      P_reference.address_ptr = addrel (subscript.address_ptr, 1);
      data_length = subscript.address_ptr -> based_integer;
    end;
    else do;
      P_reference.type = subscript.type;
      P_reference.address_ptr = subscript.address_ptr;
      data_length = subscript.precision;
    end;
  P_reference.descriptor = P_reference.type * 2 + 1;
				/* packed */
  P_reference.packed = "1"b;

  start = get_num_arg (2);

  if P_reference.n_subscripts = 3
    then do;
      P_reference.precision = get_num_arg (3);

      if P_reference.precision < 0
        then do;
	call probe_error_$record (probe_info_ptr, 0,
	     "The third arg to substr must be  > 0");
	goto RECORDED_MESSAGE;
        end;
      if start + P_reference.precision - 1 > data_length
        then call ioa_$ioa_switch (probe_info.output_switch, "stringrange");

    end;
    else P_reference.precision = data_length - start + 1;

  if P_reference.type = bit_dtype
    then P_reference.address_ptr =
	    addr (P_reference.address_ptr -> bit_array (start));
    else P_reference.address_ptr =
	    addr (P_reference.address_ptr -> char_array (start));
  goto EXIT_HERE;

probe_builtins_$length_builtin:
  entry (P_probe_info_ptr, P_refp, P_code);

  call setup (1, 1);

  sub = sub_refs (1, 1).ptr;
  call require_string (1);
  if data_type_info_$info (subscript.type).varying
    then data_length = subscript.address_ptr -> based_integer;
    else data_length = subscript.precision;

  integer_bif () -> based_integer = data_length;
  goto EXIT_HERE;

probe_builtins_$maxlength_builtin:
  entry (P_probe_info_ptr, P_refp, P_code);

  call setup (1, 1);
  sub = sub_refs (1, 1).ptr;
  call require_string (1);
  integer_bif () -> based_integer = subscript.precision;
  goto EXIT_HERE;

probe_builtins_$addrel_builtin:
  entry (P_probe_info_ptr, P_refp, P_code);

  call setup (2, 2);
  pointer_bif () -> based_ptr = addrel (get_ptr_arg (1), get_num_arg (2));
  goto EXIT_HERE;

probe_builtins_$ptr_builtin:
  entry (P_probe_info_ptr, P_refp, P_code);

  call setup (2, 3);
  if P_reference.n_subscripts = 3
    then ptr_bitno = get_num_arg (3);
    else ptr_bitno = 0;

  pointer_bif () -> based_ptr =
       bitrel (pointer (get_ptr_arg (1), get_num_arg (2)), ptr_bitno);
  goto EXIT_HERE;

bitrel:
  proc (p, bo) returns (ptr);
  dcl p			ptr parameter;
  dcl bo			fixed bin (35) parameter;
  dcl bit_array		(0:35) bit (1) unal based (p);


  if bo > 35 | bo < 0
    then do;
      call probe_error_$record (probe_info_ptr, 0,
	 "pointer: bit offset must be between 0 and 35");
      goto RECORDED_MESSAGE;
    end;
  return (addr (bit_array (bo)));
  end bitrel;

probe_builtins_$rel_builtin:
  entry (P_probe_info_ptr, P_refp, P_code);

  call setup (1, 1);
  integer_bif () -> based_integer = fixed (rel (get_ptr_arg (1)), 35);
  goto EXIT_HERE;

probe_builtins_$segno_builtin:
  entry (P_probe_info_ptr, P_refp, P_code);

  call setup (1, 1);
  integer_bif () -> based_integer = fixed (baseno (get_ptr_arg (1)), 35, 0);
  goto EXIT_HERE;

probe_builtins_$baseptr_builtin:
  entry (P_probe_info_ptr, P_refp, P_code);

  call setup (1, 1);
  pointer_bif () -> based_ptr = baseptr (get_num_arg (1));
  goto EXIT_HERE;

probe_builtins_$pascal_false_builtin:
  entry (P_probe_info_ptr, P_refp, P_code);

  call setup (0, 0);
  pascal_boolean_bif () -> based_integer = 0;
  goto EXIT_HERE;

probe_builtins_$pascal_true_builtin:
  entry (P_probe_info_ptr, P_refp, P_code);

  call setup (0, 0);
  pascal_boolean_bif () -> based_integer = 1;
  goto EXIT_HERE;

probe_builtins_$pascal_chr_builtin:
  entry (P_probe_info_ptr, P_refp, P_code);

  call setup (1, 1);
  pascal_char_bif () -> based_integer = get_num_arg (1);
  goto EXIT_HERE;

probe_builtins_$pascal_ord_builtin:
  entry (P_probe_info_ptr, P_refp, P_code);

  call setup (1, 1);
  integer_bif () -> based_integer = get_enumerated_arg (1);
  goto EXIT_HERE;

probe_builtins_$pascal_eof_builtin:
  entry (P_probe_info_ptr, P_refp, P_code);

  call setup (1, 1);
  i = eof_place_in_pascal_fsb;
  p1 = sub_refs.ptr (1, 1);
  if p1 -> reference_node.type_ptr ^= null
    then
      do;
      if p1 -> reference_node.type_ptr -> pascal_symbol_node_header.type
	 ^= pascal_record_file_type_dtype
        then
	   call iwanta (1, "file");
    end;
  else if p1 -> reference_node.type ^= pascal_text_file_dtype
    then
         call iwanta (1, "file");
  go to join;

probe_builtins_$pascal_eoln_builtin:
  entry (P_probe_info_ptr, P_refp, P_code);

  call setup (1, 1);
  i = eoln_place_in_pascal_fsb;
  p1 = sub_refs.ptr (1, 1);
  if p1 -> reference_node.type ^= pascal_text_file_dtype
    then
         call iwanta (1, "text file");
join:
  if p1 -> reference_node.address_ptr -> p.ftag ^= "43"b3
       | p1 -> reference_node.address_ptr -> based_ptr = null then do;
      call probe_error_$record (probe_info_ptr, 0,
	 "file control block for ^a is not initialized.",
	 p1 -> reference_node.name);
      go to RECORDED_MESSAGE;
    end;

  p1 = p1 -> reference_node.address_ptr -> based_ptr;
  pascal_boolean_bif () -> based_integer = addrel (p1, i) -> based_integer;
  goto EXIT_HERE;

probe_builtins_$sizeof_builtin:
  entry (P_probe_info_ptr, P_refp, P_code);

  dcl total_bytes		fixed bin (35);
  dcl rt_ptr		ptr;

  call setup (1, 1);

  if (P_probe_info_ptr -> probe_info.random_info.language_type ^= C_lang_type)
    then do;
      call probe_error_$record (probe_info_ptr, 0,
	 "The sizeof builtin is a C language builtin.");
      goto RECORDED_MESSAGE;
    end;

  sub = sub_refs.ptr (1, 1);

  if (subscript.symbol_ptr ^= null ()) then do;
      total_bytes = 0;
      rt_ptr = subscript.symbol_ptr;
      call get_the_size (rt_ptr, total_bytes, "0"b);
      sizeof_bif () -> based_integer = total_bytes;
    end;
    else do;
      call probe_error_$record (probe_info_ptr, 0,
	 "Cannot get a pointer to the runtime symbol node for ^a",
	 subscript.name);
      goto RECORDED_MESSAGE;
    end;
  goto EXIT_HERE;

get_the_size:
  proc (rt_ptr_arg, total_bytes, subcomponent);

  dcl rt_ptr_arg		ptr parameter;
  dcl total_bytes		fixed bin (35) parameter;
  dcl subcomponent		bit (1) parameter;

  if (fixed (rt_ptr_arg -> runtime_symbol.type) = structure_dtype) then do;
      rt_ptr_arg =
	 addrel (rt_ptr_arg, fixed (rt_ptr_arg -> runtime_symbol.son));
      do while (fixed (rt_ptr_arg -> runtime_symbol.brother) ^= 0);
        subcomponent = "1"b;
        rt_ptr_arg =
	   addrel (rt_ptr_arg, fixed (rt_ptr_arg -> runtime_symbol.brother))
	   ;
      end;
      total_bytes =
	 divide (fixed (rt_ptr_arg -> runtime_symbol.offset, 35), 9, 35, 0);
      if (fixed (rt_ptr_arg -> runtime_symbol.type) = structure_dtype)
        then
	   call get_the_size (rt_ptr_arg, total_bytes, subcomponent);
    end;
  if (fixed (rt_ptr_arg -> runtime_symbol.type) = c_union_dtype) then do;
      begin;
        dcl rt_ptr		      ptr;
        dcl (t_b, max_bytes)	      fixed bin (35);
        dcl not_done	      bit (1);

        rt_ptr =
	   addrel (rt_ptr_arg, fixed (rt_ptr_arg -> runtime_symbol.son));
        not_done = "1"b;
        max_bytes = 0;
        do while (not_done);
	t_b = 0;
	call get_the_size ((rt_ptr), t_b, subcomponent);
	if (t_b > max_bytes)
	  then max_bytes = t_b;
	if (rt_ptr -> runtime_symbol.brother = "000000"b3)
	  then
	       not_done = "0"b;
	  else rt_ptr =
		  addrel (rt_ptr,
		  fixed (rt_ptr -> runtime_symbol.brother));
        end;
        total_bytes = total_bytes + max_bytes;
      end;
      return;
    end;
  total_bytes = total_bytes + get_size_of_one (rt_ptr_arg, subcomponent);
  end get_the_size;

get_size_of_one:
  proc (sym_ptr, subcom) returns (fixed bin (35));

  dcl sym_ptr		ptr parameter;
  dcl subcom		bit (1) parameter;

  dcl rt_ptr		ptr;
  dcl size_of_unit		fixed bin (35);
  dcl no_of_dims		fixed bin;
  dcl no_of_elements	fixed bin;
  dcl i			fixed bin;

  no_of_elements = 1;

  rt_ptr = sym_ptr;
  do while (fixed (rt_ptr -> runtime_symbol.type) = c_typeref_dtype);
    rt_ptr = addrel (rt_ptr, fixed (rt_ptr -> runtime_symbol.son));
  end;
  if (fixed (rt_ptr -> runtime_symbol.type) = char_dtype) then do;
      if (rt_ptr -> runtime_symbol.size = 1
	 & rt_ptr -> runtime_symbol.bits.simple &
	 ^rt_ptr -> runtime_symbol.bits.packed)
        then
	   size_of_unit = 4;
        else size_of_unit = 1;
    end;
  else if (fixed (rt_ptr -> runtime_symbol.type) = real_fix_bin_1_dtype |
       fixed (rt_ptr -> runtime_symbol.type) = real_fix_bin_2_dtype)
    then
         size_of_unit = divide (rt_ptr -> runtime_symbol.size + 1, 9, 35, 0);
  else if (fixed (rt_ptr -> runtime_symbol.type) = real_fix_bin_1_uns_dtype |
       fixed (rt_ptr -> runtime_symbol.type) = real_fix_bin_2_uns_dtype |
       fixed (rt_ptr -> runtime_symbol.type) = real_flt_bin_2_dtype |
       fixed (rt_ptr -> runtime_symbol.type) = real_flt_bin_1_dtype)
    then
         size_of_unit = divide (rt_ptr -> runtime_symbol.size, 9, 35, 0);
  else if (fixed (rt_ptr -> runtime_symbol.type) = pointer_dtype)
    then
         size_of_unit = 8;

  if (^rt_ptr -> runtime_symbol.bits.simple
       & (subscript.n_subscripts = 0 | subcom)) then do;
      no_of_dims = fixed (rt_ptr -> runtime_symbol.ndims);
      do i = 1 to no_of_dims;
        no_of_elements =
	   no_of_elements
	   * (rt_ptr -> runtime_symbol.bounds (i).upper
	   - rt_ptr -> runtime_symbol.bounds (i).lower + 1);
      end;
      size_of_unit = size_of_unit * no_of_elements;
    end;
  return (size_of_unit);
  end get_size_of_one;


setup:
  proc (min_args, max_args);
  dcl min_args		fixed bin parameter;
  dcl max_args		fixed bin parameter;

  refp = P_refp;
  probe_info_ptr = P_probe_info_ptr;

  if P_reference.cross_section then do;
      call probe_error_$record (probe_info_ptr, 0,
	 "Cross-sections can only be used as array subscripts, not with builtins"
	 );
      goto RECORDED_MESSAGE;
    end;

  if P_reference.n_subscripts < min_args then do;
      call probe_error_$record (probe_info_ptr, 0,
	 "^a requires at least ^d arg^[s^]",
	 P_reference.name, min_args, (min_args > 1));
      goto RECORDED_MESSAGE;
    end;
  if P_reference.n_subscripts > max_args then do;
      call probe_error_$record (probe_info_ptr, 0,
	 "^a takes only ^d arg^[s^]",
	 P_reference.name, max_args, (max_args > 1));
      goto RECORDED_MESSAGE;
    end;

  P_reference.constant = "1"b;
  end setup;


  /* These are used to set the attributes of P_reference according to what will be returned */

sizeof_bif:
  proc () returns (ptr);

  P_reference.type = real_fix_bin_1_dtype;
  P_reference.type_ptr = null;
  P_reference.descriptor = P_reference.type * 2;
  P_reference.precision = 35;
  allocate based_integer in (expression_area) set (P_reference.address_ptr);
  return (P_reference.address_ptr);
  end sizeof_bif;

pascal_boolean_bif:
  proc () returns (ptr);

  P_reference.type = pascal_boolean_dtype;
  P_reference.type_ptr = null;
  P_reference.descriptor = P_reference.type * 2;
  P_reference.precision = 36;
  allocate based_integer in (expression_area) set (P_reference.address_ptr);
  return (P_reference.address_ptr);
  end pascal_boolean_bif;

pointer_bif:
  proc () returns (ptr);

  P_reference.type = pointer_dtype;
  P_reference.type_ptr = null;
  P_reference.descriptor = P_reference.type * 2;
  allocate based_ptr in (expression_area) set (P_reference.address_ptr);
  return (P_reference.address_ptr);
  end pointer_bif;

pascal_char_bif:
  proc () returns (ptr);

  P_reference.type = pascal_char_dtype;
  P_reference.type_ptr = null;
  P_reference.descriptor = P_reference.type * 2;
  P_reference.precision = 36;
  allocate based_integer in (expression_area) set (P_reference.address_ptr);
  return (P_reference.address_ptr);
  end pascal_char_bif;

integer_bif:
  proc () returns (ptr);

  P_reference.type = real_fix_bin_1_dtype;
  P_reference.type_ptr = null;
  P_reference.descriptor = P_reference.type * 2;
  P_reference.precision = 35;
  allocate based_integer in (expression_area) set (P_reference.address_ptr);
  return (P_reference.address_ptr);
  end integer_bif;

require_string:
  proc (sidx);
  dcl sidx		fixed bin parameter;
  dcl 1 ref		aligned like reference_node
			based (sub_refs (1, sidx).ptr);

  if ^data_type_info_$info (ref.type).char_string &
       ^data_type_info_$info (ref.type).bit_string
    then call iwanta (sidx, "string");
  if ref.cross_section
    then call nocross (sidx);
  end;

  /* These are used to get an the Nth arg -
   require it to be of the type needed, and convert it if possible and necessary
   the arg is returned for use by the builtin
*/
get_ptr_arg:
  proc (idx) returns (ptr);
  dcl idx			fixed bin;
  dcl 1 sref		aligned like reference_node
			based (sub_refs (1, idx).ptr);

  if sref.type ^= pointer_dtype
    then call iwanta (idx, "pointer");
  if sref.cross_section
    then call nocross (idx);
  return (sref.address_ptr -> based_ptr);
  end get_ptr_arg;


get_enumerated_arg:
  proc (idx) returns (fixed bin (35));
  dcl idx			fixed bin parameter;
  dcl val			fixed bin (35);
  dcl 1 sref		aligned like reference_node
			based (sub_refs.ptr (1, idx));
  dcl assign_$computational_	entry (ptr, ptr, fixed bin (35));

  dcl 1 tar_str		aligned like computational_data;
  dcl 1 src_str		aligned like computational_data;

  dcl 1 eprec		aligned like encoded_precision;

  dcl unspec		builtin;

  dcl probe_pascal_$real_type entry (fixed bin (35), ptr, fixed bin (35), ptr)
			;

  if sref.type = char_dtype then do;
      sref.type = pascal_char_dtype;
      sref.precision = 9;
    end;
  call probe_pascal_$real_type (sref.type, sref.type_ptr, sref.type,
       sref.type_ptr);
  if ^((sref.type = pascal_enumerated_type_element_dtype)
       | (sref.type = pascal_char_dtype)
       | (sref.type = pascal_enumerated_type_instance_dtype))
    then call iwanta (idx, "char or an enumerated type element or instance");

  if sref.cross_section
    then call nocross (idx);

  tar_str.address = addr (val);
  tar_str.data_type = real_fix_bin_1_dtype;
  tar_str.flags = "0"b;
  tar_str.prec_or_length = 35;
  tar_str.scale = 0;


  src_str.address = sref.address_ptr;
  if sref.precision >= 36
    then
         src_str.data_type = real_fix_bin_2_uns_dtype;
    else
         src_str.data_type = real_fix_bin_1_uns_dtype;
  src_str.flags = "0"b;
  src_str.flags.packed = "1"b;

  unspec (eprec) = unspec (sref.precision);

  src_str.prec_or_length = eprec.prec;
  src_str.scale = eprec.scale;

  call assign_$computational_ (addr (tar_str), addr (src_str), (0));
  return (val);

  end get_enumerated_arg;

get_num_arg:
  proc (idx) returns (fixed bin (35));
  dcl idx			fixed bin parameter;
  dcl val			fixed bin (35);
  dcl 1 sref		aligned like reference_node
			based (sub_refs.ptr (1, idx));
  dcl assign_$computational_	entry (ptr, ptr, fixed bin (35));

  dcl 1 tar_str		aligned like computational_data;
  dcl 1 src_str		aligned like computational_data;

  dcl 1 eprec		aligned like encoded_precision;

  dcl unspec		builtin;

  dcl probe_pascal_$real_type entry (fixed bin (35), ptr, fixed bin (35), ptr)
			;

  call probe_pascal_$real_type (sref.type, sref.type_ptr, sref.type,
       sref.type_ptr);
  if ^data_type_info_$info (sref.type).computational
    then call iwanta (idx, "number");

  if sref.cross_section
    then call nocross (idx);

  tar_str.address = addr (val);
  tar_str.data_type = real_fix_bin_1_dtype;
  tar_str.flags = "0"b;
  tar_str.prec_or_length = 35;
  tar_str.scale = 0;


  src_str.address = sref.address_ptr;
  src_str.data_type = sref.type;
  src_str.flags = "0"b;
  src_str.flags.packed = sref.flags.packed;

  unspec (eprec) = unspec (sref.precision);

  src_str.prec_or_length = eprec.prec;
  src_str.scale = eprec.scale;

  call assign_$computational_ (addr (tar_str), addr (src_str), (0));
  return (val);

  end get_num_arg;


iwanta:
  proc (num, what);
  dcl num			fixed bin parameter;
  dcl what		char (*) aligned parameter;

  call probe_error_$record (probe_info_ptr, 0,
       "The ^[first^;second^;third^] arg to the ^a builtin must be a ^a",
       num, P_reference.name, what);
  goto RECORDED_MESSAGE;
  end iwanta;

nocross:
  proc (n);
  dcl n			fixed bin parameter;
  call probe_error_$record (probe_info_ptr, 0,
       "The ^[first^;second^;third^;fourth^] argument to ^a cannot be an array cross-section",
       n, P_reference.name);
  goto RECORDED_MESSAGE;
  end nocross;

octunspecom:
  proc;

  /* common for octal and unspec */
  P_reference.pseudo_var = "1"b;
  sub = sub_refs.ptr (1, 1);
  if subscript.cross_section
    then call nocross (1);
  P_reference.address_ptr = subscript.address_ptr;
  P_reference.type = bit_dtype;
  P_reference.type_ptr = null;
  P_reference.descriptor = P_reference.type * 2;
  P_reference.packed = "1"b;

  if subscript.symbol_ptr ^= null
    then
         P_reference.precision = get_size_in_bits_$structure (sub);
    else
         P_reference.precision =
	    get_size_in_bits_ ((subscript.type), (subscript.precision),
	    (subscript.packed));
  if P_reference.precision = -1
    then do;
      call probe_error_$record (probe_info_ptr, 0,
	 "^a can't determine size of ^a",
	 P_reference.name, subscript.name);
      goto RECORDED_MESSAGE;
    end;
  return;


  end octunspecom;
%page;

%include probe_info;

%include probe_source_info;

%include probe_seg_info;

%include probe_references;

%include data_type_info_;

%include std_descriptor_types;

%include encoded_precision;

%include computational_data;

%include runtime_symbol;

%include pascal_gen_constants;

%include pascal_symbol_node;
%include probe_lang_types;
  end probe_builtins_;




		    probe_check_ptr_.pl1            10/24/88  1614.5rew 10/24/88  1339.1       84150



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



/****^  HISTORY COMMENTS:
  1) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

probe_check_ptr_:
  proc ();

  /* *	This procedure converts the pointer value P_xxx_pointerter into a character string,
   *	interpreting appropriately and including error messages describing any problems
   *	with it 
   *	Modified: 22 Sept 79 JRD to not require pad bits to be zero, because some Multics stack frame ptrs
   *			     keep information in these bits, and the hardware doesn't care.
*/
  /* Entry point $indirectable added 09/11/81 S. Herbst */
  /* Fixed to catch illegal_modifier that slipped through before; 06/01/82 S. Herbst */

  dcl (
      P_its_pointer		pointer aligned parameter,
      P_packed_pointer	pointer unaligned parameter,
      P_flags		bit (*),
      P_code		fixed bin (35)
      )			parameter;

  dcl return_str		char (256) varying;
  dcl dname		char (168);
  dcl ename		char (32);
  dcl long_info		char (100) aligned;
  dcl test_pointer		pointer;
  dcl code		fixed bin (35);

  dcl its_ptr_ptr		pointer;
  dcl 1 its_ptr		aligned based (its_ptr_ptr) like its_unsigned;

  dcl 1 flags		aligned,	/* P_flags overlays onto this */
       2 dont_include_pathname
			bit (1) unaligned;

  dcl process_dir_names	(2) char (64) varying internal static
			init ("", "");
				/* long and short name of users pdir */
  dcl initialized		bit (1) aligned internal static init ("0"b);

  dcl convert_status_code_	entry (fixed bin (35), char (8) aligned,
			char (100) aligned);
  dcl get_pdir_		entry () returns (char (168));
  dcl hcs_$fs_get_mode	entry (ptr, fixed bin (5), fixed bin (35));
  dcl hcs_$fs_get_path_name	entry (ptr, char (*), fixed bin, char (*),
			fixed bin (35));
  dcl ioa_$rsnnl		entry options (variable);

  dcl (
      error_table_$bad_ptr,
      error_table_$invalidsegno
      )			fixed bin (35) external static;

  dcl probe_et_$null_ptr	fixed bin (35) ext;

  dcl (addr, binary, length, null, rtrim, string, substr)
			builtin;

  dcl illegal_modifier	condition;
				/*  */

probe_check_ptr_$convert:
  entry (P_its_pointer, P_flags) returns (char (256) varying);

  if ^initialized
    then call initialize ();		/* initialize static copies of process dir names */

  call ioa_$rsnnl ("^o|^o^[(^d)^]", return_str, (0),
       addr (P_its_pointer) -> its_ptr.segno,
       addr (P_its_pointer) -> its_ptr.offset,
       (addr (P_its_pointer) -> its_ptr.bit_offset ^= 0),
       addr (P_its_pointer) -> its_ptr.bit_offset);

  call check_its_pointer ();		/* find out whether it's wholesome or not */
  if code = 0
    then test_pointer = P_its_pointer;	/* assign it for use later */
    else test_pointer = null ();

  goto CONVERT_POINTER_COMMON;


probe_check_ptr_$convert_packed:
  entry (P_packed_pointer, P_flags) returns (char (256) varying);

  if ^initialized
    then call initialize ();		/* initialize static copies of process dir names */

  call ioa_$rsnnl ("^p", return_str, (0), P_packed_pointer);

  call check_packed_pointer ();	/* find out if its any good */
  if code = 0
    then test_pointer = P_packed_pointer;
				/* assign it for use later */
    else test_pointer = null ();

  goto CONVERT_POINTER_COMMON;


CONVERT_POINTER_COMMON:		/* common code for converting */
  string (flags) = P_flags;		/* copy the flags */

  if code ^= 0 then do;		/* bad pointer -- set by check_xxx_pointer */
      return_str = return_str || " (Invalid pointer.)";
      return (return_str);
    end;

  if test_pointer = null ()
    then /* null */
         return ("null");

  dcl bit_1_unaligned_array	(100) bit (1) unaligned;
				/* Stupid bug in pl1 24c makes this arbitrarily difficult */
  dcl stupid_idx		fixed bin;

  stupid_idx = 73;
  bit_1_unaligned_array (stupid_idx) = flags.dont_include_pathname;
  if bit_1_unaligned_array (stupid_idx)
    then
         /* don't bother getting pathname */
         return (return_str);

  call hcs_$fs_get_path_name (test_pointer, dname, (0), ename, code);
  if code = error_table_$invalidsegno then do;
      return_str = return_str || " (Invalid segment number)";
      return (return_str);
    end;

  else if code ^= 0 then do;
      call convert_status_code_ (code, (""), long_info);
				/* get a string describing error */
      return_str = return_str || " (Error: ";
      return_str = return_str || rtrim (long_info);
      return_str = return_str || ")";
      return (return_str);
    end;

  return_str = return_str || " ";	/* append the pathname */
  if dname = process_dir_names (1)
    then /* construct the pathname to return */
         return_str = return_str || "[pd]";
  else if dname = process_dir_names (2)
    then
         return_str = return_str || "[pd]";
  else return_str = return_str || rtrim (dname);

  if dname ^= ">"
    then /* it's not the ROOT */
         return_str = return_str || ">";

  return_str = return_str || rtrim (ename);
				/* add the entryname */

  return (return_str);		/* all done converting pointer */

  /*  */

probe_check_ptr_$check:
  entry (P_its_pointer, P_code);

  /* *	This entry validates the supplied pointer */
  call check_its_pointer ();

  P_code = code;			/* copy the code */
  return;				/* end of code for $check entrypoint */


probe_check_ptr_$check_packed:
  entry (P_packed_pointer, P_code);

  /* *	just like the above, only for packed pointers */

  call check_packed_pointer ();

  P_code = code;
  return;				/* end of code for $check_packed entrypoint */


probe_check_ptr_$indirectable:
  entry (P_its_pointer, P_code);

  /* Makes sure you can indirect through the supplied pointer */


  if P_its_pointer = null
    then P_code = probe_et_$null_ptr;
    else do;
      code = 0;
      call hcs_$fs_get_mode (P_its_pointer, 0, code);
      P_code = code;
    end;
  return;
				/*  */

check_its_pointer:
  proc ();

  /* *	This procedure tests the validity of P_its_pointer, and sets code
   *	accordingly. */

  dcl test_ptr		ptr;


  code = 0;			/* assume it's good */
  its_ptr_ptr = addr (P_its_pointer);

  if its_ptr.its_mod ^= "43"b3
    then goto BAD_ITS_POINTER;

  if its_ptr.segno > binary ("7777"b3) & its_ptr.segno < binary ("77776"b3)
    then
         goto BAD_ITS_POINTER;	/* segno out of range */
  if its_ptr.bit_offset > 35
    then goto BAD_ITS_POINTER;

  on illegal_modifier go to BAD_ITS_POINTER;
  test_ptr = P_its_pointer;
  revert illegal_modifier;

  code = 0;
  return;				/* success */

BAD_ITS_POINTER:
  code = error_table_$bad_ptr;	/* failure */
  return;
  end;				/* check_its_pointer internal procedure */

  /*  */

check_packed_pointer:
  proc ();

  /* *	This procedure tests the validity of P_packed_pointer, and sets code
   *	accordingly. */

  dcl packed_ptr_ptr	pointer;
  dcl 1 packed_ptr		aligned based (packed_ptr_ptr),
				/* our own version of this, with unsigned binary */
      (
       2 bit_offset		fixed bin (6) unsigned,
       2 segno		fixed bin (12) unsigned,
       2 offset		fixed bin (18) unsigned
       )			unaligned;


  code = 0;			/* assume it's good */
  packed_ptr_ptr = addr (P_packed_pointer);

  if packed_ptr.bit_offset > 35
    then code = error_table_$bad_ptr;	/* there's not much you can check about one of these */
    else code = 0;
  return;
  end;				/* check_packed_pointer internal procedure */

  /*  */

initialize:
  proc ();

  /* *	This procedure initializes the process_dir_names array to be the
   *	the long and short names of this processes process dir; i.e.,
   *	>process_dir_dir>[unique] and >pdd>[unique], so that the convert
   *	entrypoints can replace that directory name with [pd]. */


  if process_dir_names (1) = "" then do;/* initialize them */
      process_dir_names (1) = get_pdir_ ();
				/* the real name */
      if substr (process_dir_names (1), 1, length (">process_dir_dir")) =
	 ">process_dir_dir" then do;
	process_dir_names (2) = ">pdd";
				/* make one with >pdd at the front */
	process_dir_names (2) = process_dir_names (2) ||
	     substr (process_dir_names (1), length (">process_dir_dir") + 1)
	     ;
        end;
        else process_dir_names (2) = process_dir_names (1);
    end;
  return;
  end;				/* internal procedure initialize */

  /*  */

%include its;
  end;				/* external procedure probe_check_ptr_ */




		    probe_command_.pl1              10/27/88  1244.0rew 10/27/88  1221.9      101448



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

/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

/****^  HISTORY COMMENTS:
  1) change(87-06-18,RWaters), approve(87-06-18,MCR7687), audit(87-06-24,Huen),
     install(87-07-15,MR12.1-1040):
     Probe error #107: correctly implement source path PATH.
  2) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
  3) change(88-10-21,WAAnderson), approve(88-10-21,MCR7952),
     audit(88-10-24,RWaters), install(88-10-27,MR12.2-1194):
     Modified code to implement a C feature. If the user specifes 'seg' instead
     of 'seg$main', probe will now assume the user wants 'seg$main' if no
     statement map is found for 'seg'.  This is not particularily elegant
     because it will try using the 'seg$main' convention for any object,
     regardless of the compiler used to generate the object.  Other modules
     affected to implement this feature are 'probe_find_procedure_' and
     'probe_seg_info_'. The include 'probe_info.incl.pl1' was modified to
     include the new file 'retry_using_main'.
                                                   END HISTORY COMMENTS */


probe_command_:
  procedure options (variable);

  /* *	Command procedure for the "probe" debugger. It does hardly anything at all, just
   *	creates the global data structure and calls the probe listener. The code for the
   *	"halt" request also appears here, since it must invoke the listener, as does the
   *	code for responding to breakpoints. */

  /* Improved error message if can't get ptr to break seg 08/31/81 S. Herbst */
  /* Changed to call probe_break_mgr_$reset_all_pause_breaks on cleanup 04/19/84 S. Herbst */
  /* Changed to omit epilogue when returning if previous error occurred during "quit" 01/15/85 Steve Herbst */
  /* Fixed to correctly implement source path PATH 05/21/87 RWaters */


  dcl code		fixed bin (35);
  dcl alp			pointer;

  dcl cu_$arg_count_rel	entry (fixed bin, ptr);
  dcl cu_$arg_list_ptr	entry (ptr);
  dcl cu_$arg_ptr_rel	entry (fixed bin, pointer, fixed bin,
			fixed bin (35), ptr);

  dcl have_we_greeted	bit (1) aligned internal static init ("0"b);
  dcl ioa_		entry options (variable);
  dcl probe_data_$greeting_msg
			char (256) varying external static;
  dcl probe_data_$version_string
			char (32) aligned external static;


  dcl probe_announce_entry_	entry (pointer);
  dcl probe_break_mgr_$reset_all_pause_breaks
			entry (ptr);
  dcl probe_error_		entry options (variable);
  dcl probe_error_$warning	entry options (variable);
  dcl probe_error_$malfunction
			entry options (variable);
  dcl probe_find_procedure_	entry (ptr, char (*), bit (36) aligned, ptr,
			fixed bin (35));
  dcl probe_listen_		entry (ptr, fixed bin (35));
  dcl probe_subsys_util_$create_invocation
			entry (fixed bin, ptr, fixed bin (35));
  dcl probe_subsys_util_$destroy_invocation
			entry (ptr);
  dcl probe_stack_trace_$where_source_info
			entry (ptr, ptr, fixed bin, char (*));
  dcl probe_stack_trace_$condition_raised
			entry (ptr, ptr, char (32));
  dcl probe_stack_trace_$find_condition_frame
			entry (ptr, ptr, char (32));
  dcl probe_stack_trace_$find_frame
			entry (ptr, ptr, ptr);

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

  dcl cleanup		condition;

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

  /*  */

  probe_info_ptr = null ();

  on cleanup
    begin;
    call probe_break_mgr_$reset_all_pause_breaks (probe_info_ptr);
    call clean_things_up ();
  end;

  call probe_subsys_util_$create_invocation
       (probe_info_version, probe_info_ptr, code);
  if code ^= 0 then do;
      if code ^= error_table_$action_not_performed
        then /* haven't already printed message about breakseg */
	   call probe_error_$malfunction (probe_info_ptr, code,
	        "Unable to initialize probe.");
      call clean_things_up ();
      return;
    end;

  probe_info.abort_probe_label = PROBE_COMMAND_RETURNS;
				/* for handling initialization errors, mostly */
  probe_info.abort_line_label = PROBE_COMMAND_RETURNS;
  probe_info.current_stack_frame = stackframeptr ();
  probe_static_info.good_stack = "0"b;	/* stack is a new beast */

  call cu_$arg_list_ptr (alp);


  if ^have_we_greeted then do;
      have_we_greeted = "1"b;
      if probe_data_$greeting_msg ^= ""
        then call ioa_ ("^a - ^a", probe_data_$version_string,
	        probe_data_$greeting_msg);
    end;

  call process_command_arguments (alp);

  call probe_listen_ (probe_info_ptr, (0));
				/* do it */

PROBE_COMMAND_RETURNS:
  if probe_info.executing_quit_request
    then
         return;			/* don't chance looping with another error */

  if probe_info.return_method = RETURN_TO_CONDITION then do;
      call probe_error_$warning (probe_info_ptr, 0,
	 "Temporary restriction: unable to restart conditions. Use the start command instead."
	 );
      probe_info.return_method = RETURN_TO_CALLER;
    end;

  call clean_things_up ();
  return;				/* end of code for probe command */

  /*  */

clean_things_up:
  proc ();

  if probe_info_ptr ^= null () then do; /* invalidate the saved stack */
      if addr (probe_static_info) ^= null ()
        then
	   probe_static_info.good_stack = "0"b;
    end;

  call probe_subsys_util_$destroy_invocation (probe_info_ptr);
  return;
  end;				/* internal procedure clean_things_up */

  /*  */

process_command_arguments:
  proc (P_alp) options (non_quick);

  /* *	This procedure is used to process the command-line arguments. */

  dcl P_alp		pointer parameter;

  dcl al			fixed bin;
  dcl ap			pointer;
  dcl arg			character (al) based (ap);
				/* argument as returned by cu_$arg_ptr */
  dcl procedure_arg		char (200);
  dcl (argno, nargs)	fixed bin;
  dcl cond_name		char (32);



  procedure_arg = "";		/* start out empty */

  call cu_$arg_count_rel (nargs, P_alp);/* get number of arguments that we were called with */

  do argno = 1 to nargs;		/* loop through our arguments */
    call cu_$arg_ptr_rel (argno, ap, al, (0), P_alp);

    if substr (arg, 1, 1) ^= "-" then do;
				/* a procedure name */
PROCESS_PROCEDURE_NAME:
        if procedure_arg ^= ""
	then /* punt if we already have one */
	     call probe_error_ (probe_info_ptr, 0,
		"At most one procedure may be specified. ^a", arg);

        procedure_arg = arg;		/* remember it */
      end;

      else do;			/* otherwise, process a control argument */
        if arg = "-name" | arg = "-nm" then do;
	  if argno = nargs
	    then call probe_error_
		    (probe_info_ptr, error_table_$noarg,
		    "A procedure name must follow ""^a"".", arg);

	  argno = argno + 1;	/* get the procedure name */
	  call cu_$arg_ptr_rel (argno, ap, al, (0), P_alp);
	  goto PROCESS_PROCEDURE_NAME;/* and process it */
	end;

        else if arg = "-brief" | arg = "-bf"
	then probe_static_info.brief_sw = "1"b;
        else if arg = "-long" | arg = "-lg"
	then probe_static_info.brief_sw = "0"b;

        else if arg = "-no_handle_conditions"
	then probe_static_info.no_handle_faults_sw = "1"b;
        else if arg = "-handle_conditions"
	then probe_static_info.no_handle_faults_sw = "0"b;

        else if arg = "-recursive_breaks"
	then probe_static_info.recursive_breaks_sw = "1"b;
        else if arg = "-no_recursive_breaks"
	then probe_static_info.recursive_breaks_sw = "0"b;

        else call probe_error_ (probe_info_ptr, error_table_$badopt, """^a""",
	        arg);
      end;			/* of control arg case */
  end;				/* of loop through arguments */

  if procedure_arg ^= "" then do;	/* user specified a procedure, use it */

      probe_info.retry_using_main = 0;  

      call probe_find_procedure_ (probe_info_ptr, procedure_arg, "111"b,
	 probe_info.ptr_to_initial_source, code);

/* A kludge. If no statement map and no explicit entry point given, try */
/* the same operation using procedure_arg$main. This is implemented for */
/* the convienience of C programmers.                                   */

      if (probe_info.retry_using_main = 1 & index(procedure_arg,"$") = 0) then do;
          procedure_arg = rtrim(procedure_arg) || "$main";
          code = 0;
          call probe_find_procedure_ (probe_info_ptr, procedure_arg, "111"b,
  	 probe_info.ptr_to_initial_source, code);
       end;

      if code ^= 0
        then call probe_error_ (probe_info_ptr, code);
				/* procedure seems to be losing */

      if initial_source.stack_ptr = null ()
        then /* figure out what to do upon return */
	   probe_info.return_method = RETURN_TO_CALLER;
				/* no active frame */

        else do;
	call probe_stack_trace_$condition_raised
	     (probe_info_ptr, probe_info.ptr_to_initial_source, cond_name);

	if cond_name = ""
	  then probe_info.return_method = RETURN_TO_FRAME;
				/* just has invocation on the stack */
	  else probe_info.return_method = RETURN_TO_CONDITION;
				/* faulted out */
        end;
    end;				/* processing procedure arg */

    else do;			/* no arg, look for a fault frame */
      call probe_stack_trace_$find_condition_frame (probe_info_ptr,
	 probe_info.ptr_to_initial_source, cond_name);
      if initial_source.entry_ptr ^= null ()
        then /* found a condition frame, use it */
	   probe_info.return_method = RETURN_TO_CONDITION;
        else do;			/* no fault on stack -use last frame */
	call probe_stack_trace_$find_frame (probe_info_ptr,
	     probe_info.ptr_to_initial_source,
	     probe_info.current_stack_frame -> stack_frame.prev_sp);
	probe_info.return_method = RETURN_TO_FRAME;
        end;
    end;				/* making implicit definition */

  current_source = initial_source;	/* they start out the same */
  current_source.seg_info_ptr -> seg_info.file_pointers (*) = null ();
				/* start out null */
  probe_info.language_type =
       current_source.seg_info_ptr -> seg_info.language_type;

  call probe_announce_entry_ (probe_info_ptr);
				/* announce our arrival */
  end;				/* process_command_args internal procedure */

  /*  */

  /*	INCLUDE FILES	*/

%include probe_info;

  /* ;;;;;;; */

%include probe_static_info;

  /* ;;;;;;; */

%include probe_source_info;

  /* ;;;;;;; */

%include probe_seg_info;

  /* ;;;;;;; */

%include probe_info_constants;

  /* ;;;;;;; */

%include stack_frame;

  end;				/* probe_command_ external procedure */




		    probe_compare_reference_.pl1    11/11/88  1554.4r w 11/11/88  1545.0      179325



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



/****^  HISTORY COMMENTS:
  1) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

probe_compare_reference_:
  procedure (P_probe_info_ptr, P_operation, P_operand_1, P_operand_2, P_code)
       returns (bit (1));

  /*
   Modified in July 1977 by R.J.C. Kissel to handle new data ttypes.	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 18 Nov 78 by James R. Davis to check for valid decimal and varying strings
   Modified 18 Nov 79 by James R. Davis to use data_type_info_ and assign_computational_
   Modified June 83 JMAthane to handle PASCAL values. */
  /* Added version string to runtime_type_info structure 10/06/83 S. Herbst */

  dcl (
      P_probe_info_ptr	pointer,
      P_operation		bit (18) aligned,
      P_code		fixed bin (35),
      1 P_operand_1		aligned like reference_node,
      1 P_operand_2		aligned like reference_node
      )			parameter;

  dcl 1 operand		(2) aligned like reference_node;
				/* copies of input operands */
  dcl 1 op_data		(2) aligned like computational_data;
  dcl 1 intermediate	(2) aligned like computational_data;

  dcl code		fixed bin (35);
				/* global error code */
  dcl operation_code	fixed bin;/* binary verison of comparison operation */

  dcl 1 generation		aligned like source_info based (generation_ptr);
				/* enviroment */
  dcl generation_ptr	pointer;

  dcl 1 type_bits		aligned,	/* indicates type, base and mode */
       2 float		bit (1) unaligned,
				/* of the temp or target, which */
       2 binary		bit (1) unaligned,
				/* need not be the same as for the operand */
       2 complex		bit (1) unaligned;
  dcl 1 type_bits_copy	aligned like type_bits;

  dcl type_type		fixed bin;/* type_bits, as in fixed bin (3) */

  dcl 1 common_info		(0:7),	/* indexed by type_type */
       2 type_array		fixed bin initial /* type to convert to */
			(real_fix_dec_9bit_ls_dtype,
			cplx_fix_dec_9bit_ls_dtype,
			real_fix_bin_2_dtype,
			cplx_fix_bin_2_dtype,
			real_flt_dec_9bit_dtype,
			cplx_flt_dec_9bit_dtype,
			real_flt_bin_2_dtype,
			cplx_flt_bin_2_dtype),
       2 prec_array		fixed bin
			initial (59, 59, 71, 71, 59, 59, 63, 63),
				/* precision of result */
       2 size_array		fixed bin initial (30, 60, 2, 4, 32, 64, 2, 4);
				/* number of words */

  dcl space		(2) bit (1152) aligned;
				/* enough to hold float decimal (59) complex */
  dcl first_based_char	char (str_len (1)) based (str_ptr (1));
  dcl second_based_char	char (str_len (2)) based (str_ptr (2));
  dcl first_based_bit	bit (str_len (1)) based (str_ptr (1));
  dcl second_based_bit	bit (str_len (2)) based (str_ptr (2));
  dcl str_len		(2) fixed bin (21);
  dcl str_ptr		(2) pointer;

  dcl result		bit (1);	/* often the result of the comapison */
  dcl i			fixed bin;

  dcl float_decimal		decimal (59) float based;
				/* overlay for a float decimal number  */
  dcl float_decimal_complex	decimal (59) float complex based;
				/* and others ... */
  dcl fixed_decimal		decimal (59, 0) fixed based;
  dcl float_binary		binary (63) float based;
  dcl float_binary_complex	binary (63) float complex based;
  dcl fixed_binary		binary (71) fixed based;
  dcl fixed_binary_complex	binary (71, 0) fixed complex based;
  dcl based_label		label based;
  dcl based_entry		entry variable based;
  dcl based_integer		fixed bin (35) based;
  dcl based_ptr		pointer based;
  dcl based_packed_ptr	pointer unaligned based;
  dcl based_file		file based;

  dcl pointers		(2) pointer;
  dcl labels		(2) label;
  dcl entries		(2) entry variable;
  dcl 1 label		aligned,
       2 place		pointer,
       2 frame		pointer;
  dcl 1 entry		aligned like label;


  dcl reverse_result	(7:12) bit (1) aligned internal static
			options (constant)
			initial /* ^= is the "reverse" of = */
			("0"b, "0"b, "0"b, "1"b, "1"b, "1"b);

  dcl wanted_result		(7:12) fixed bin internal static
			options (constant)
			initial /* result (ie sign (-)) desired */
			(-1, 1, 0, 0, 1, -1);


  dcl (
      probe_et_$bad_comparison,
      probe_et_$bad_decimal,
      probe_et_$bad_type,
      probe_et_$bad_varying,
      probe_et_$recorded_message
      )			fixed bin (35) external static;

  dcl probe_error_$record	entry options (variable);
  dcl valid_decimal_	entry (fixed bin, ptr, fixed bin)
			returns (bit (1));
  dcl assign_$computational_	entry (ptr, ptr, fixed bin (35));
  dcl stu_$offset_to_pointer	entry (pointer, pointer, pointer, pointer,
			pointer, pointer) returns (pointer);

  dcl (abs, addr, addrel, bin, ceil, character, fixed, max, null,
      pointer, sign, string, substr, unspec)
			builtin;
				/**/

  probe_info_ptr = P_probe_info_ptr;
  P_code = 0;			/* unless we find otherwise */
  operation_code = bin (substr (P_operation, 4, 15), 17);
				/* convert to a number */

  operand (1) = P_operand_1;		/* copy arguments */
  operand (2) = P_operand_2;

  if probe_info.language_type = PASCAL_lang_type then do;
      do i = 1 to 2;
        call set_pascal_term (operand (i));
      end;
      if operand (1).type_ptr ^= operand (2).type_ptr
        then go to BAD_OPERAND;
    end;
  do i = 1 to 2;			/* get information about reference */
    call setup_str (operand (i), op_data (i));
  end;


  if data_type_info_$info (op_data.data_type (1)).computational then do;
      if ^data_type_info_$info (op_data.data_type (2)).computational
        then
	   goto BAD_OPERAND;

      if ^data_type_info_$info (op_data.data_type (1)).arithmetic &
	 ^data_type_info_$info (op_data.data_type (2))
	 .arithmetic /* string to string */
        then do;

	do i = 1 to 2;

	  if data_type_info_$info (op_data (i).data_type).varying
	    then do;
	      str_len (i) = op_data (i).address -> based_integer;
	      str_ptr (i) = addrel (op_data (i).address, 1);

	      if str_len (i) < 0 | str_len (i) > op_data (i).prec_or_length
	        then do;
		call probe_error_$record (probe_info_ptr,
		     probe_et_$bad_varying, operand (i).name);
		goto RECORDED_MESSAGE;
	        end;
	    end;
	    else do;
	      str_len (i) = op_data (i).prec_or_length;
	      str_ptr (i) = op_data (i).address;
	    end;
	end;
	if data_type_info_$info (op_data (1).data_type).char_string then do;
				/* first is char */
	    if data_type_info_$info (op_data (2).data_type).char_string
	      then do;
	        if first_based_char > second_based_char
		then i = 1;
	        else if first_based_char = second_based_char
		then i = 0;
	        else i = -1;
	      end;
	      else do;		/* sec. is bit */
	        if first_based_char > character (second_based_bit)
		then i = 1;
	        else if first_based_char = character (second_based_bit)
		then i = 0;
	        else i = -1;
	      end;		/* char:bit */
	  end;			/* chart to ? */
	  else do;
	    if data_type_info_$info (op_data (2).data_type).char_string
	      then do;
	        if character (first_based_bit) > second_based_char
		then i = 1;
	        else if character (first_based_bit) = second_based_char
		then i = 0;
	        else i = -1;
	      end;
	      else do;
	        if first_based_bit > second_based_bit
		then i = 1;
	        else if first_based_bit = second_based_bit
		then i = 0;
	        else i = -1;
	      end;		/* bit:bit */
	  end;
	if reverse_result (operation_code)
	  then return (^(wanted_result (operation_code) = i));
	  else return (wanted_result (operation_code) = i);
        end;			/* string comparisons */


        else do;			/* at least one is arith */

	do i = 1 to 2;
	  if data_type_info_$info (op_data (i).data_type).decimal
	    then
	         if ^valid_decimal_ (op_data (i).data_type,
		    op_data.address (i), (op_data (i).prec_or_length))
		 then do;		/* and BAD!! */
		   call probe_error_$record (probe_info_ptr,
		        probe_et_$bad_decimal, operand (i).name);
		   goto RECORDED_MESSAGE;
		 end;
	end;

	/* must convert to common type for comparison */

	type_bits = compute_type_bits (op_data (1).data_type);
	type_bits_copy = compute_type_bits (op_data (2).data_type);
	string (type_bits) = string (type_bits) | string (type_bits_copy);

	type_type = fixed (string (type_bits), 3, 0);

	intermediate (*).data_type = common_info (type_type).type_array;
	intermediate (*).flags = "0"b;
	intermediate (*).prec_or_length =
	     common_info (type_type).prec_array;
	intermediate (*).picture_image_ptr = null ();

	do i = 1 to 2;
	  intermediate (i).scale = op_data (i).scale;
	  if data_type_info_$info (op_data (i).data_type).decimal &
	       type_bits.binary
	    then
	         intermediate (i).scale =
		    ceil (abs (op_data (i).scale) * 3.332)
		    * sign (op_data (i).scale);
	end;

	intermediate (*).scale =
	     max (intermediate (1).scale, intermediate (2).scale);

	do i = 1 to 2;
	  intermediate (i).address = addr (space (i));
	  call assign_$computational_ (addr (intermediate (i)),
	       addr (op_data (i)), code);
	  if code ^= 0
	    then goto SOME_ERROR;
	end;


	/* perform comparison */

	if type_bits.complex /* complex only allows equla or not equal */
	  then do;
	    if P_operation ^= EQUALS & P_operation ^= NOT_EQUALS
	      then
		 goto BAD_COMPARISON;
	    if ^type_bits.binary	/* we will compare fixed as float */
	      then result =
		      (addr (space (1)) -> float_decimal_complex
		      = addr (space (2)) -> float_decimal_complex);
	    else if type_bits.float
	      then result =
		      (addr (space (1)) -> float_binary_complex
		      = addr (space (2)) -> float_binary_complex);
	    else result =
		    (addr (space (1)) -> fixed_binary_complex
		    = addr (space (2)) -> fixed_binary_complex);
	    if reverse_result (operation_code)
				/* is result really ^ result */
	      then return (^result);
	      else return (result);
	  end;
	  else do;
	    if ^type_bits.binary
	      then do;
	        if type_bits.float
		then i = sign (addr (space (1)) -> float_decimal
			- addr (space (2)) -> float_decimal);
		else i = sign (addr (space (1)) -> fixed_decimal
			- addr (space (2)) -> fixed_decimal);
	      end;
	      else do;
	        if type_bits.float
		then i = sign (addr (space (1)) -> float_binary
			- addr (space (2)) -> float_binary);
		else i = sign (addr (space (1)) -> fixed_binary
			- addr (space (2)) -> fixed_binary);
	      end;
	    if reverse_result (operation_code)
	      then return (^(wanted_result (operation_code) = i));
	      else return (wanted_result (operation_code) = i);
	  end;


        end;			/* arith compare */
    end;				/* computational compares */
  else if op_data (1).data_type = pointer_dtype
       | op_data (1).data_type = offset_dtype then do;

      do i = 1 to 2;
        if P_operation ^= EQUALS & P_operation ^= NOT_EQUALS
	then
	     goto BAD_COMPARISON;
        if op_data (i).data_type = pointer_dtype
	then if op_data (i).flags.packed
	       then pointers (i) = op_data.address (i) -> based_packed_ptr;
	       else pointers (i) = op_data.address (i) -> based_ptr;
        else if op_data (i).data_type = offset_dtype /* offset */
	then do;
	  generation_ptr = operand (i).source_info_ptr;
	  pointers (i) =
	       stu_$offset_to_pointer (generation.block_ptr,
	       operand (i).symbol_ptr, op_data.address (i),
	       generation.stack_ptr,
	       (generation.seg_info_ptr -> seg_info.linkage_ptr),
	       generation.block_ptr);
	end;
        else go to BAD_OPERAND;
      end;


      result = pointers (1) = pointers (2);
      if reverse_result (operation_code)
        then return (^result);
        else return (result);


    end;				/* pointer and offset */
  else if op_data (1).data_type = label_dtype |
       op_data (1).data_type = label_constant_runtime_dtype
    then do;
      if P_operation ^= EQUALS & P_operation ^= NOT_EQUALS
        then
	   goto BAD_COMPARISON;

      do i = 1 to 2;		/* prepare both operands */
        if op_data (i).data_type = label_dtype
	then labels (i) = op_data.address (i) -> based_label;
        else if op_data (i).data_type = label_constant_runtime_dtype
	then do;
	  label.place = op_data.address (i);
	  label.frame =
	       operand (i).source_info_ptr -> source_info.stack_ptr;
	  labels (i) = addr (label) -> based_label;
	end;
        else go to BAD_OPERAND;
      end;

      result = labels (1) = labels (2);
      if reverse_result (operation_code)
        then return (^result);
        else return (result);

    end;				/* label */
  else if op_data (1).data_type = entry_dtype then do;
      do i = 1 to 2;
        if op_data (i).data_type = entry_dtype
				/* entry variable */
	then entries (i) = op_data.address (i) -> based_entry;
        else if op_data (i).data_type = int_entry_runtime_dtype
	then do;
	  entry.place = op_data.address (i);
	  entry.frame =
	       operand (i).source_info_ptr -> source_info.stack_ptr;
	  entries (i) = addr (entry) -> based_entry;
	end;
        else if op_data (i).data_type = ext_entry_runtime_dtype
	then do;
	  entry.place = op_data.address (i);
	  entry.frame = null;
	  entries (i) = addr (entry) -> based_entry;
	end;
        else go to BAD_OPERAND;
      end;


      if P_operation ^= EQUALS & P_operation ^= NOT_EQUALS
        then
	   goto BAD_COMPARISON;

      result = entries (1) = entries (2);
      if reverse_result (operation_code)
        then return (^result);
        else return (result);
    end;				/* entry */
  else if op_data (1).data_type = file_dtype then do;
      if op_data (2).data_type ^= file_dtype
				/* can only compare two files */
        then go to BAD_OPERAND;

      if P_operation = EQUALS
        then do;
	return (op_data.address (1) -> based_file
	     = op_data.address (2) -> based_file);
        end;
      if P_operation = NOT_EQUALS
        then do;
	return (op_data.address (1) -> based_file
	     ^= op_data.address (2) -> based_file);
        end;
      goto BAD_COMPARISON;

    end;				/* file */


  /* fall through */

BAD_OPERAND:
  call probe_error_$record (probe_info_ptr, probe_et_$bad_type,
       operand (1).name, operand (2).name);
  goto RECORDED_MESSAGE;


BAD_COMPARISON:
  code = probe_et_$bad_comparison;
  goto SOME_ERROR;


RECORDED_MESSAGE:
  code = probe_et_$recorded_message;
  goto SOME_ERROR;


SOME_ERROR:
  P_code = code;
  return ("0"b);			/* since it failed for other reasons, as well */


set_pascal_term:
  proc (ref);

  /* Transformation of a PASCAL value to more general type value,
   in order to allow comparison between PASCAL value and probe constants,
   comparison between typed pointers,
   comparison between values subranges of same type.. */

  dcl 1 ref		like reference_node parameter aligned;

  dcl barr		(100) bit (1) unal based (ref.address_ptr);
  dcl get_size_in_bits_	entry (fixed bin, fixed bin (35), bit (1))
			returns (fixed bin);
  dcl probe_pascal_$real_type entry (fixed bin (35), ptr, fixed bin (35), ptr)
			;
  dcl 1 type_info		like runtime_type_info;

  call probe_pascal_$real_type (ref.type, ref.type_ptr, ref.type,
       ref.type_ptr);		/* if subrange */

  if ref.type = pascal_char_dtype then do;
      ref.type = char_dtype;
      ref.packed = "1"b;
      ref.address_ptr = addr (barr (ref.precision - 8));
    end;
  if ref.type = pascal_user_defined_type_instance_dtype then do;
      if ref.type_ptr -> pascal_symbol_node_header.array_info
	 & ref.type_ptr -> pascal_symbol_node_header.packed then do;
	type_info.version = RUNTIME_TYPE_INFO_VERSION_1;

	call runtime_symbol_info_$type (type_ptr, addr (type_info), code);
	if code ^= 0
	  then
	       go to SOME_ERROR;

	if type_info.base_type = pascal_char_dtype
	     & runtime_symbol_info_$array_dims (ref.type_ptr) = 1 then do;
	    ref.precision =
	         get_size_in_bits_ ((ref.type), ref.precision, ref.packed)
	         / 9;
	    ref.type = char_dtype;
	    ref.type_ptr = null;
	    ref.packed = "1"b;
	  end;
        end;
      else if ref.type_ptr -> pascal_symbol_node_header.type
	 = pascal_typed_pointer_type_dtype then do;
	ref.type = pointer_dtype;
	ref.type_ptr = null;
	if ref.precision = 36
	  then ref.packed = "1"b;
	  else ref.packed = "0"b;
        end;
    end;
  else if ref.type = pascal_enumerated_type_element_dtype then do;
      ref.type = pascal_enumerated_type_instance_dtype;
      ref.type_ptr = runtime_symbol_info_$father_type (ref.symbol_ptr);
    end;

  if ref.type = pascal_enumerated_type_instance_dtype
       | ref.type = pascal_boolean_dtype then do;
      if ref.precision >= 36
        then ref.type = real_fix_bin_2_uns_dtype;
        else ref.type = real_fix_bin_1_uns_dtype;
      ref.packed = "1"b;
    end;

  if ref.type = pascal_user_defined_type_instance_dtype
       | ref.type = pascal_text_file_dtype then do;
      if ref.type_ptr -> pascal_symbol_node_header.type = pascal_set_dtype
        then ref.type_ptr = null;	/* to allow comparison with <<set>> constants */
      ref.type = bit_dtype;
      ref.packed = "1"b;
    end;
  end;

setup_str:
  proc (ref, comp);

  dcl 1 ref		parameter aligned like reference_node;
  dcl 1 comp		parameter aligned like computational_data;
  dcl 1 an_encoded_value	aligned like encoded_precision;

  comp.address = ref.address_ptr;
  comp.data_type = ref.type;
  string (comp.flags) = "0"b;
  comp.flags.packed = ref.flags.packed;
  if data_type_info_$info (ref.type).arithmetic
    then do;
      unspec (an_encoded_value) = unspec (ref.precision);
      comp.prec_or_length = an_encoded_value.prec;
      comp.scale = an_encoded_value.scale;
    end;
    else do;
      comp.prec_or_length = ref.precision;
      comp.scale = 0;
    end;
  if ref.type = picture_runtime_dtype
    then comp.picture_image_ptr = pointer (ref.symbol_ptr, ref.precision);
    else comp.picture_image_ptr = null ();
  end setup_str;

compute_type_bits:
  proc (P_dtype) returns (1 aligned like type_bits);

  dcl P_dtype		fixed bin parameter;

  dcl 1 d_type_bits		aligned like type_bits;


  if data_type_info_$info (P_dtype).arithmetic then do;
      d_type_bits.float = ^data_type_info_$info (P_dtype).fixed;
      d_type_bits.binary = ^data_type_info_$info (P_dtype).decimal;
      d_type_bits.complex = data_type_info_$info (P_dtype).complex;
    end;

    else do;
      d_type_bits.float = "0"b;
      if data_type_info_$info (P_dtype).bit_string
        then
	   d_type_bits.binary = "1"b;
        else d_type_bits.binary = "0"b;
      d_type_bits.complex = "0"b;
    end;
  return (d_type_bits);
  end compute_type_bits;


  /**/
%include probe_info;
%include probe_references;
%include probe_tokens;
%include probe_operators;
%include probe_lang_types;
%include probe_source_info;
%include probe_seg_info;

%include computational_data;
%include data_type_info_;
%include encoded_precision;
%include std_descriptor_types;
%include pascal_symbol_node;
%include runtime_symbol_info_;

  end probe_compare_reference_;




		    probe_create_reference_.pl1     11/11/88  1554.4r w 11/11/88  1545.0       46818



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



/****^  HISTORY COMMENTS:
  1) change(88-06-27,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added initialization data . Probe often used values that had not be
     properly initialized.
  2) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

probe_create_reference_:
  proc (P_probe_info_ptr, P_ref_ptr);

  /* *	This procedure allocates and initializes a reference node in the current
   *	expression area. */
  /* Modified June 83 JMAthane to initialize new "type_ptr" field */

  dcl (
      P_probe_info_ptr	pointer,
      P_ref_ptr		pointer,	/* pointer to reference node we create */
      P_ref_block_ptr	pointer
      )			parameter;/* pointer to reference block to initialize */


  dcl probe_seg_info_	entry (ptr, ptr, fixed bin (35)) returns (ptr);
  dcl (addr, null)		builtin;

  probe_info_ptr = P_probe_info_ptr;
  P_ref_ptr = null ();		/* until we find out otherwise */

  allocate ref_block in (expression_area) set (ref_block_ptr);

  ref_block.ref_node.type_ptr = null;
  ref_block.ref_node.argument_list = addr (ref_block.arglist);
  ref_block.ref_node.subscript_ptr = addr (ref_block.subscripts);
  ref_block.ref_node.source_info_ptr = addr (ref_block.source_info);
  ref_block.ref_node.subscript_refs_ptr = addr (ref_block.sub_refs);
  ref_block.subscripts.number = 0;
  ref_block.arglist.number = 0;
  ref_block.ref_node.optional_info.n_arguments = 0;
  ref_block.ref_node.optional_info.n_subscripts = 0;
  ref_block.ref_node.symbol_ptr = null ();
  ref_block.ref_node.type_ptr = null ();
  ref_block.ref_node.address_ptr = null ();
  ref_block.ref_node.base_addr = null ();
  ref_block.ref_node.name = "";
  ref_block.ref_node.type = 0;
  ref_block.ref_node.descriptor = 0;
  ref_block.ref_node.precision = 0;
  ref_block.ref_node.flags = "0"b;
  ref_block.ref_node.constant_token_ptr = null ();

  ref_block.source_info.seg_info_ptr =
       probe_seg_info_ (probe_info_ptr, null (), (0));
  ref_block.c_symbol_ptr = null ();

  P_ref_ptr = addr (ref_block.ref_node);/* all done */
  return;				/* end of probe_create_reference_ entry */


probe_create_reference_$init:
  entry (P_probe_info_ptr, P_ref_block_ptr);

  /* *	This entry just initializes an already existing ref_block, probably
   *	declared automatic in its caller. */

  probe_info_ptr = P_probe_info_ptr;
  ref_block_ptr = P_ref_block_ptr;


  ref_block.ref_node.type_ptr = null;
  ref_block.ref_node.argument_list = addr (ref_block.arglist);
  ref_block.ref_node.subscript_ptr = addr (ref_block.subscripts);
  ref_block.ref_node.source_info_ptr = addr (ref_block.source_info);
  ref_block.ref_node.subscript_refs_ptr = addr (ref_block.sub_refs);
  ref_block.ref_node.optional_info.n_subscripts = 0;
  ref_block.subscripts.number = 0;
  ref_block.arglist.number = 0;
  ref_block.ref_node.symbol_ptr = null ();
  ref_block.ref_node.type_ptr = null ();
  ref_block.ref_node.address_ptr = null ();
  ref_block.ref_node.base_addr = null ();
  ref_block.ref_node.name = "";
  ref_block.ref_node.type = 0;
  ref_block.ref_node.descriptor = 0;
  ref_block.ref_node.precision = 0;
  ref_block.ref_node.flags = "0"b;
  ref_block.ref_node.constant_token_ptr = null ();
  ref_block.source_info.seg_info_ptr =
       probe_seg_info_ (probe_info_ptr, null (), (0));
  ref_block.c_symbol_ptr = null ();

  return;				/* end of code for $init entrypoint */

probe_create_reference_$destroy:
  entry (P_probe_info_ptr, P_ref_ptr);

  /* *	This entry frees a reference node and associated storage that was
   *	created using probe_create_reference_. Since the expression area is
   *	freed with every request invocation, however, it is usually unnecessary
   *	to use this entrypoint. */

  probe_info_ptr = P_probe_info_ptr;

  ref_block_ptr = P_ref_ptr;
  P_ref_ptr = null ();

  free ref_block in (expression_area);
  return;				/* end of $destroy entrypoint */

%include probe_info;
%include probe_references;
%include probe_ref_block;
%include probe_source_info;

  end;				/* probe_create_reference_ external procedure */




		    probe_ctl_requests_.pl1         11/11/88  1554.4r w 11/11/88  1545.0      143145



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



/****^  HISTORY COMMENTS:
  1) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

probe_ctl_requests_:
  proc ();

  call probe_error_$malfunction ();	/* dummy entry */

  /* probe_ctl_requests_

   quit
   goto
   step
   continue_to
   continue
   halt
   pause

   Modified 23 Sept 79 for new probe_break_mgr_ */
  /* goto and continue_to changed to not guess line number 08/31/81 S. Herbst */
  /* Fixed goto to reset a temporary break 12/02/81 S. Herbst */
  /* Added "mode meter" code to halt and continue requests 09/23/82 S. Herbst */
  /* Do "start" control order in halt and pause to prevent lost wakeups 09/02/83 S. Herbst */
  /* Changed "quit" to call probe_break_mgr_$reset_all_pause_breaks 04/19/84 S. Herbst */
  /* Fixed "quit" to quit out of probe even if a condition occurs 01/15/85 Steve Herbst */


  dcl P_probe_info_ptr	pointer parameter;

  dcl code		fixed bin (35);
  dcl 1 new_source_info	aligned like source_info;

  dcl (new_page_faults, old_page_faults, page_faults, real_minutes,
      real_seconds)		fixed bin;
  dcl (virtual_msec, virtual_10ksec, virtual_usec)
			fixed bin;
  dcl (new_clock, new_vclock, old_clock, old_vclock)
			fixed bin (71);
  dcl (
      probe_et_$bad_label_frame,
      probe_et_$breakless,
      probe_et_$noarg,
      probe_et_$too_many_args
      )			fixed bin (35) external static;


  dcl probe_announce_entry_	entry (pointer);
  dcl probe_break_mgr_$is_temporary_break
			entry (ptr, ptr) returns (bit (1));
  dcl probe_break_mgr_$reset_all_pause_breaks
			entry (ptr);
  dcl probe_break_mgr_$reset_break_at_line
			entry (ptr, ptr, fixed bin, bit (1) aligned,
			fixed bin (35));
  dcl probe_break_mgr_$set_break
			entry (ptr, ptr, fixed bin, pointer,
			fixed bin (21), fixed bin (35));
  dcl probe_error_		entry options (variable);
  dcl probe_error_$malfunction
			entry options (variable);
  dcl probe_get_$line	entry (ptr, ptr, fixed bin, bit (36) aligned,
			fixed bin, fixed bin (35));
  dcl probe_listen_		entry (ptr, fixed bin (35));
  dcl cpu_time_and_paging_	entry (fixed bin, fixed bin (71), fixed bin);
  dcl ioa_$ioa_switch	entry options (variable);
  dcl iox_$control		entry (ptr, char (*), ptr, fixed bin (35));


  dcl command_abort_	condition;

  dcl (addr, clock, divide, length, null, pointer, vclock)
			builtin;
SOME_ERROR:			/* general for error code type errors */
  call probe_error_ (probe_info_ptr, code);
				/* never returns */
  goto MAIN_RETURN;			/* just in case */


MAIN_RETURN:
  return;				/* only such exit from this procedure */

quit_request:
  entry (P_probe_info_ptr);

  /* *	This request exits probe */

  probe_info_ptr = P_probe_info_ptr;

  call reject_argument ();		/* can't say "quit foo" */

  if probe_info.execute then do;	/* try to return to our caller */

      probe_info.executing_quit_request = "1"b;
				/* to prevent an error returning to listener */

      call probe_break_mgr_$reset_all_pause_breaks (probe_info_ptr);

      if probe_info.return_method = RETURN_TO_BREAK then do;
				/* KLUDGE, but probably the best we can do */
	signal condition (command_abort_);
				/* this should get us back to the command processor... */
	call probe_error_$malfunction
	     /* if we ever get returned to, what else should we do?? */
	     (probe_info_ptr, 0, "Unable to quit after a breakpoint.");
	return;
        end;

      probe_info.return_method = RETURN_TO_CALLER;
				/* this will make us just return to whoever called probe */

      goto probe_info.abort_probe_label;/* abort the invocation of probe */
    end;
  return;				/* if not executing, just return */

  /*  */

goto_request:
  entry (P_probe_info_ptr);

  /* *	Goto a particular label */

goto_request_block:
  begin;

    dcl line_type		  fixed bin;
				/* what data type probe_get_line found for us */
    dcl 1 label_overlay	  aligned based (addr (label_variable)),
         2 place		  pointer,
         2 frame		  pointer;
    dcl label_variable	  label variable aligned;

    dcl 1 map_array		  (map_size) based (map_ptr) aligned
			  like statement_map;
    dcl map_size		  fixed bin;
    dcl map_ptr		  ptr ptr;

    probe_info_ptr = P_probe_info_ptr;

    call require_argument ();		/* must have a following argument -- */
				/* goto <nl> would otherwise goto $c */

    call probe_get_$line (probe_info_ptr, addr (new_source_info), (0),
         "0001"b, line_type, code);
    if code ^= 0
      then goto SOME_ERROR;		/* we lost getting the label */
    if (line_type = ext_procedure_runtime_dtype |
         line_type = ext_entry_runtime_dtype |
         line_type = int_entry_runtime_dtype)
      then
	 call probe_error_ (probe_info_ptr, 0, "Can't goto a procedure");

    call reject_argument ();		/* and can't have any args after the label */

    if probe_info.execute then do;
        map_ptr = new_source_info.seg_info_ptr -> seg_info.statement_map_ptr;
        map_size = new_source_info.seg_info_ptr -> seg_info.map_size;
        label_overlay.place =
	   pointer (map_ptr,
	   map_array (new_source_info.stmnt_map_entry_index).location);
        label_overlay.frame = new_source_info.stack_ptr;
				/* and stack frame */
        if label_overlay.frame = null
	then /* check if procedure active */
	     call probe_error_ (probe_info_ptr, probe_et_$bad_label_frame);

        if probe_break_mgr_$is_temporary_break (probe_info_ptr,
	   probe_info.ptr_to_current_source) then do;
				/* if a temporary break (set by step), reset it */
	  call probe_break_mgr_$reset_break_at_line (probe_info_ptr,
	       probe_info.ptr_to_current_source,
	       BREAK_BEFORE, "0"b, (0));
	  call probe_break_mgr_$reset_break_at_line (probe_info_ptr,
	       probe_info.ptr_to_current_source,
	       BREAK_AFTER, "0"b, (0));
	end;

        goto label_variable;		/* cleanup will occur ! */
      end;
  end goto_request_block;
  goto MAIN_RETURN;			/* end of code for goto request */

  /*  */

step_request:
  entry (P_probe_info_ptr);

  /* *	This request sets a breakpoint immediately "before" the next statement,
   *	and then continues execution. It's not as useful as it might seem, of
   *	course, since there's no guarantee that the next statement will be
   *	executed, anyway, but life's like that. Perhaps when we get the step
   *	operator implemented things will work better. This code shares some
   *	temporaries with the goto request, above. */

  dcl STEP_COMMAND_LIST	char (5) internal static options (constant)
			init ("pause");
  dcl probe_source_segment_$position_source
			entry (ptr, ptr, fixed bin, fixed bin (35));

  probe_info_ptr = P_probe_info_ptr;

  call reject_argument ();		/* can't say 'step foo', of course */

  if probe_info.execute then do;
      if probe_info.return_method ^= RETURN_TO_BREAK
	 & probe_info.return_method ^= RETURN_TO_CONDITION
        then
	   call probe_error_ (probe_info_ptr, 0,
	        "The ""step"" request may only be used at a breakpoint or after a fault."
	        );

      new_source_info = initial_source; /* copy it, for we change the statement number */

      call probe_source_segment_$position_source (probe_info_ptr,
	 addr (new_source_info), 1, code);
      if code ^= 0
        then goto SOME_ERROR;

      call probe_break_mgr_$set_break (probe_info_ptr, addr (new_source_info),
	 BREAK_BEFORE,
	 addr (STEP_COMMAND_LIST), length (STEP_COMMAND_LIST), code);
      if code ^= 0
        then goto SOME_ERROR;

      goto probe_info.abort_probe_label;/* leave and restart */
    end;
  return;				/* end of code for continue request */

  /*  */

continue_to_request:
  entry (P_probe_info_ptr);

  /* *	This request sets a break at the specified label and continues execution until
   *	that point. This code shares various temporaries with the goto and step requests, above */

  probe_info_ptr = P_probe_info_ptr;

  call require_argument ();		/* must have a label */

  call probe_get_$line (probe_info_ptr, addr (new_source_info), (0), "0001"b,
       (0), code);
  if code ^= 0
    then go to SOME_ERROR;

  call reject_argument ();		/* must be no args after the label, of course */

  if probe_info.execute then do;	/* if for real, then set the break and resume execution */
      if probe_info.return_method ^= RETURN_TO_BREAK
	 & probe_info.return_method ^= RETURN_TO_CONDITION
        then
	   call probe_error_ (probe_info_ptr, 0,
	        "The ""continue_to"" request may only be used at a breakpoint or after a fault."
	        );

      call probe_break_mgr_$set_break (probe_info_ptr, addr (new_source_info),
	 BREAK_BEFORE,
	 addr (STEP_COMMAND_LIST), length (STEP_COMMAND_LIST), code);
      if code ^= 0
        then goto SOME_ERROR;

CONTINUE:
      if probe_modes.meter then do;	/* so user doesn't see probe's own usage */
	probe_static_info.last_clock = clock ();
	probe_static_info.last_vclock = vclock ();
	call cpu_time_and_paging_ (probe_static_info.last_page_faults, 0, 0)
	     ;
        end;

      probe_static_info.last_break_segno = "0"b;

      goto probe_info.abort_probe_label;/* leave probe */
    end;
  return;				/* end of code for continue_to request */

  /*  */

continue_request:
  entry (P_probe_info_ptr);

  /* *	This simply continues execution of the user program. It takes no arguments */

  probe_info_ptr = P_probe_info_ptr;

  call reject_argument ();		/* no arguments for continue */

  if probe_info.execute then do;	/* should we do it at all? */
      if probe_info.return_method ^= RETURN_TO_BREAK
	 & probe_info.return_method ^= RETURN_TO_CONDITION
        then
	   call probe_error_ (probe_info_ptr, 0,
	        "The ""continue"" request may only be used to continue from a fault or a breakpoint."
	        );

      goto CONTINUE;		/* no longer set "RETURN_TO_CALLER" -- wos 7/15/79 */
    end;
  return;				/* return if we're not executing */

  /*  */

halt_request:
  entry (P_probe_info_ptr);

  /* *	This is used in breakpoints to cause probe to come up to a new listener level.
   *	It just calls probe_listen_ recursively, which saves the old values so the breakpoint
   *	can later be resumed. */

  probe_info_ptr = P_probe_info_ptr;

  call reject_argument ();		/* no arguments for halt */

  call iox_$control (probe_info.output_switch, "start", null, 0);
				/* prevent wakeups from being lost by prev requests in breaklist */

  if probe_info.execute then do;	/* call ourselves */
      if probe_info.break_slot_ptr = null () /* but only if this is a break */
	 | probe_info.in_listener
        then /* and we haven't called the listener yet */
	   call probe_error_ (probe_info_ptr, 0,
	        "The ""halt"" request may only be issued in a breakpoint request list."
	        );

      if probe_modes.meter then do;
	old_clock = probe_static_info.last_clock;
	old_vclock = probe_static_info.last_vclock;
	old_page_faults = probe_static_info.last_page_faults;
	new_clock, probe_static_info.last_clock = clock ();
	new_vclock, probe_static_info.last_vclock = vclock ();
	call cpu_time_and_paging_ (new_page_faults, 0, 0);
	probe_static_info.last_page_faults = new_page_faults;
        end;

      call probe_announce_entry_ (probe_info_ptr);
				/* let user know what's happening */

      if probe_modes.meter then do;	/* print clock, vcpu, and page faults since last halt */
	real_seconds = divide (new_clock - old_clock, 1000000, 17, 0);
	real_minutes = divide (real_seconds, 60, 17, 0);
	real_seconds = real_seconds - real_minutes * 60;
	virtual_usec = new_vclock - old_vclock;
	virtual_msec = divide (virtual_usec, 1000, 17, 0);
	virtual_10ksec =
	     divide (virtual_usec - virtual_msec * 1000, 100, 17, 0);
	page_faults = new_page_faults - old_page_faults;

	if probe_static_info.brief_sw
	  then call ioa_$ioa_switch (probe_info.output_switch,
		  "^7t^d.^d MSEC", virtual_msec, virtual_10ksec);

	  else call ioa_$ioa_switch (probe_info.output_switch,
		  "^3xTime = ^[^d min ^]^d sec, Vcpu = .^d^d sec, Page faults = ^d",
		  real_minutes ^= 0, real_minutes, real_seconds,
		  virtual_msec, virtual_10ksec, page_faults);
        end;

      call probe_listen_ (probe_info_ptr, code);
				/* and let him type commands */
    end;

  return;				/* end of code for halt request */

  /*  */

pause_request:
  entry (P_probe_info_ptr);

  /* *	The pause request works just like the halt request, except that it causes the
   *	most recent breakpoint to be reset, if there was one, thus halting the program
   *	but once. */

  probe_info_ptr = P_probe_info_ptr;

  call reject_argument ();		/* pause takes no arguments */

  call iox_$control (probe_info.output_switch, "start", null, 0);
				/* prevent wakeups from being lost by prev requests in breaklist */

  if probe_info.execute then do;
      if probe_info.break_slot_ptr = null () /* but only if this is a break */
	 | probe_info.in_listener
        then /* and we haven't called the listener yet */
	   call probe_error_ (probe_info_ptr, 0,
	        "The ""pause"" request may only be issued in a breakpoint request list."
	        );

      call probe_announce_entry_ (probe_info_ptr);
				/* let user know what's happening */

      call probe_listen_ (probe_info_ptr, code);
				/* and let him type commands */

      if probe_info.break_slot_ptr ^= null () then do;
				/* upon return, reset the break which got us here */
	call probe_break_mgr_$reset_break_at_line (probe_info_ptr,
	     addr (initial_source),
	     probe_info.break_slot_ptr -> break_slot.type, "0"b, code);
	if code ^= 0 & code ^= probe_et_$breakless
	  then goto SOME_ERROR;
        end;
    end;
  return;				/* end of code for pause request */

  /*  */

  /*	INTERNAL PROCEDURES 	*/

reject_argument:
  proc ();

  /* *	This procedure simply calls probe_error_ if the current token is not the
   *	end of the token chain -- it is called by requests which have processed all
   *	expected arguments and want to barf if there are any extras */

  if probe_info.ct -> token.type < probe_info.end_token
    then
         call probe_error_ (probe_info_ptr, probe_et_$too_many_args);
  return;
  end;				/* reject_argument internal procedure */

require_argument:
  proc ();

  /* *	This is just like reject_argument, except that it barfs if there are not
   *	any more arguments */
  if probe_info.ct -> token.type >= probe_info.end_token
    then
         call probe_error_ (probe_info_ptr, probe_et_$noarg);
  return;
  end;				/* require_argument internal procedure */

  /*  */

%include probe_info;
%include probe_static_info;
%include probe_modes;
%include probe_tokens;
%include probe_references;
%include probe_source_info;
%include probe_operators;
%include std_descriptor_types;
%include probe_seg_info;
%include statement_map;
%include probe_break_slot;
%include probe_lang_types;
%include probe_info_constants;

  end;				/* external procedure probe_ctl_requests_ */




		    probe_cv_stu_code_.pl1          10/24/88  1614.6rew 10/24/88  1342.3       18882



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



/****^  HISTORY COMMENTS:
  1) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

probe_cv_stu_code_:
  proc (P_code);

  /* *	This procedure exists solely to convert the silly status code from stu_
   *	(called steps) into a more useful probe_et_ code. */

  dcl P_code		fixed bin (35) parameter;
				/* input and output */

  dcl (
      probe_et_$no_block,
      probe_et_$too_many_levels,
      probe_et_$too_long,
      probe_et_$no_dcl,
      probe_et_$ambiguous_ref
      )			fixed bin (35) external;

  if P_code >= 0
    then return;
  else if P_code < -5
    then return;
  else if P_code = -1
    then P_code = probe_et_$no_block;
  else if P_code = -2
    then P_code = probe_et_$too_many_levels;
  else if P_code = -3
    then P_code = probe_et_$too_long;
  else if P_code = -4
    then P_code = probe_et_$no_dcl;
  else if P_code = -5
    then P_code = probe_et_$ambiguous_ref;

  return;
  end;				/* probe_cv_stu_code_ external procedure */




		    probe_data_.cds                 10/24/88  1614.6rew 10/24/88  1354.2       41157



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




/* HISTORY COMMENTS:
  1) change(88-10-18,WAAnderson), approve(88-10-18,MCR7952),
     audit(88-10-18,JRGray), install(88-10-24,MR12.2-1184):
     Probe source archive split. Part of C-Probe Support.
                                                   END HISTORY COMMENTS */


probe_data_: proc ();

/* *	External static and constant data for the probe debugger.
   *	Created: 05/28/79 W. Olin Sibert (from rdm_data_)
   *	Modified: 09/19/79 JRDavis to add "greeting msg."
   *	Modified: 10 Sep 79 JRD remove cleverness so as to not startle Martinson
   *      Modified:  5 May 80 JRD probe 5.2
   *	Modified: 17 April 1981 by M. N. Davidoff for probe 5.3.
   *	Modified: 05/05/82 S. Herbst probe 5.4
   *	Modified: 04/20/84 S. Herbst probe 5.5
*/

	dcl     1 cds_data		 aligned like cds_args; /* arguments to create_data_segment_ subr */

	dcl     code		 fixed binary (35);


	dcl     com_err_		 entry () options (variable);
	dcl     ioa_$rsnnl		 entry options (variable);
	dcl     ioa_		 entry options (variable);
	dcl     create_data_segment_	 entry (pointer, fixed binary (35));


	dcl     whoami		 char (12) internal static options (constant) init ("probe_data_");
	dcl     EXCLUDE_ARRAY	 (1) char (32) internal static options (constant) init ("pad*");

	dcl     (addr, hbound, null, size, string) builtin;

	dcl     EXL_INFO		 bit (1) aligned internal static options (constant) initial ("0"b);
	dcl     EXL_VERSION		 bit (1) aligned internal static options (constant) initial ("0"b);

	dcl     1 probe_constant_data	 aligned,
		2 major_version	 fixed bin,
		2 minor_version	 fixed bin,
		2 version_string	 char (32) aligned,
		2 info_directory	 char (168) aligned,
		2 debug_sw	 bit (1) aligned,
		2 catch_faults	 bit (1) aligned,
		2 scratch_segment_name char (32) aligned,
		2 break_segment_suffix char (32) aligned,
		2 prompt_string	 char (32) varying,
		2 greeting_msg	 char (256) varying,
		2 pad1		 fixed bin;

	dcl     1 probe_static_data	 aligned,
		2 probe_scratch_ptr	 pointer,
		2 probe_static_info_ptr pointer,
		2 invocation_list_ptr pointer,
		2 break_segment_ptr	 pointer;

/**/

	probe_constant_data.major_version = 5;
	probe_constant_data.minor_version = 5;

	if EXL_VERSION then
	     call ioa_ ("Generating probe_data_ exl version ^d.^d",
		probe_constant_data.major_version, probe_constant_data.minor_version);

	call ioa_$rsnnl ("probe ^d.^d", probe_constant_data.version_string, (0),
	     probe_constant_data.major_version, probe_constant_data.minor_version);

	if EXL_INFO then
	     probe_constant_data.info_directory = ">exl>info";
	else probe_constant_data.info_directory = ">doc>info";

	probe_constant_data.scratch_segment_name = "probe_scratch_";
	probe_constant_data.break_segment_suffix = "probe";
	probe_constant_data.prompt_string = "probe^[(^d)^;^s^]:^2x";
	probe_constant_data.greeting_msg = "";

	probe_constant_data.debug_sw = "0"b;
	probe_constant_data.catch_faults = "1"b;

	probe_static_data.probe_static_info_ptr = null ();
	probe_static_data.invocation_list_ptr = null ();
	probe_static_data.probe_scratch_ptr = null ();
	probe_static_data.break_segment_ptr = null ();

	unspec (cds_data) = "0"b;

	cds_data.sections (1).p = addr (probe_constant_data);
	cds_data.sections (1).len = size (probe_constant_data);
	cds_data.sections (1).struct_name = "probe_constant_data";

	cds_data.sections (2).p = addr (probe_static_data);
	cds_data.sections (2).len = size (probe_static_data);
	cds_data.sections (2).struct_name = "probe_static_data";

	cds_data.seg_name = whoami;

	cds_data.num_exclude_names = hbound (EXCLUDE_ARRAY, 1);
	cds_data.exclude_array_ptr = addr (EXCLUDE_ARRAY);

	string (cds_data.switches) = "0"b;
	cds_data.switches.have_text = "1"b;		/* only create text section */
	cds_data.switches.have_static = "1"b;

	call create_data_segment_ (addr (cds_data), code);

	if code ^= 0 then call com_err_ (code, whoami);

	return;

/**/

%include cds_args;
     end probe_data_;




		    probe_display_data_.pl1         10/27/88  1244.0r w 10/27/88  1225.3       82062



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



/****^  HISTORY COMMENTS:
  1) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

probe_display_data_:
  proc (P_probe_info_ptr, P_ap, P_format, P_units, P_code);

  /* displays data pointed to by P_ap in format given by P_units

   James R. Davis 20 May 79 */
  /* Added formats bin, bin71, f, f63, code 09/30/81 S. Herbst */
  /* Changed to print entry point name of error code as well 10/23/81 S. Herbst */
  /* Fixed message printed for zero status code 10/18/82 S. Herbst */

  dcl P_probe_info_ptr	ptr aligned parameter;
  dcl P_ap		ptr aligned parameter;
  dcl P_format		char (32) aligned parameter;
  dcl P_units		fixed bin parameter;
  dcl P_code		fixed bin (35) parameter;
				/* output: error code */

  dcl ap			ptr;	/* to data, copy of P_ap */
  dcl strp		ptr;
  dcl units		fixed bin;/* copy of P_units */

  dcl 1 format_how		(29) internal static options (constant),
       2 fname		char (12) init
			("ascii", "character", "ch", "c", "a",
			"bit", "b",
			"binary", "bin", "binary35", "bin35",
			"binary71", "bin71",
			"float", "f", "float27", "f27",
			"float63", "f63",
			"pointer", "ptr", "its", "p",
			"octal", "o",
			"instruction", "inst", "i",
			"code"),

       2 method		fixed bin (9) unsigned unaligned init
			(1, 1, 1, 1, 1,
			2, 2,
			3, 3, 3, 3,
			4, 4,
			5, 5, 5, 5,
			6, 6,
			7, 7, 7, 7,
			8, 8,
			9, 9, 9,
			10);

  dcl based_bits		bit (units) based (ap);
  dcl based_char		char (units) based (ap);
  dcl based_fixed		fixed bin (35) based (ap);
  dcl based_fixed71		fixed bin (71) based (ap);
  dcl based_float		float bin (27) based (ap);
  dcl based_ptr_array	(units) ptr aligned based (ap);
  dcl based_words		(units) bit (36) aligned based (ap);

  dcl i			fixed bin;
  dcl error_message		char (100) aligned;

  dcl convert_status_code_	entry (fixed bin (35), char (8) aligned,
			char (100) aligned);
  dcl print_instructions_	entry (ptr, fixed bin, ptr);
  dcl octals_per_line	fixed bin internal static
			options (constant) init (8);

  dcl probe_error_$record	entry options (variable);
  dcl probe_et_$recorded_message
			fixed bin (35) external;

  dcl (
      ioa_$ioa_switch,
      ioa_$ioa_switch_nnl
      )			entry options (variable);

  dcl (addr, divide, hbound, mod, null, ptr, rel, rtrim)
			builtin;

  P_code = 0;
  units = P_units;
  ap = P_ap;
  probe_info_ptr = P_probe_info_ptr;

  do i = 1 to hbound (format_how, 1);
    if format_how (i).fname = P_format
      then goto display_data (format_how (i).method);
  end;

  /* fell through - bad format */

  call probe_error_$record (probe_info_ptr, 0,
       "Invalid format mode for displaying: ""^a"".", P_format);
  P_code = probe_et_$recorded_message;
  return;

display_data (1):			/* chars */

  /* must translate unprintables ? */

  call ioa_$ioa_switch (probe_info.io_switches.output_switch, "^a",
       based_char);
  return;


display_data (2):			/* bit strings */

  call ioa_$ioa_switch (probe_info.io_switches.output_switch, "^b",
       based_bits);
  return;


display_data (3):			/* decimal */

  if units > 35
    then go to FIXED71;
FIXED35:
  call ioa_$ioa_switch (probe_info.io_switches.output_switch, "^d",
       based_fixed);
  return;


display_data (4):			/* double precision decimal */

  if units < 36
    then go to FIXED35;
FIXED71:
  call ioa_$ioa_switch (probe_info.io_switches.output_switch, "^d",
       based_fixed71);
  return;


display_data (5):			/* floating point */

  if units > 27
    then go to FLOAT63;
FLOAT27:

  call ioa_$ioa_switch (probe_info.io_switches.output_switch, "^f",
       based_float);
  return;


display_data (6):			/* double precision floating point */

  if units < 28
    then go to FLOAT27;
FLOAT63:
  call ioa_$ioa_switch (probe_info.io_switches.output_switch, "^f",
       based_float);


display_data (7):			/* ptrs */

  do i = 1 to units;
    call ioa_$ioa_switch (probe_info.io_switches.output_switch, "^p",
         based_ptr_array (i));
  end;

  return;


display_data (8):			/* octals */

  do i = 1 to units;
    call ioa_$ioa_switch_nnl (probe_info.io_switches.output_switch,
         " ^12w^[^/^]",
         based_words (i),
         mod (i, octals_per_line) = 0 | i = units);
  end;
  return;


display_data (9):			/* instructions */

  call print_instructions_ (ap, units, probe_info.io_switches.output_switch);
  return;


display_data (10):			/* status codes */

  call convert_status_code_ (based_fixed, "", error_message);
  call ioa_$ioa_switch (probe_info.io_switches.output_switch,
       "^a^2x^[""^a""^]", get_code_name (based_fixed), based_fixed ^= 0,
       error_message);
  return;
%page;
get_code_name:
  proc (P_code) returns (char (128) varying);

  /* Returns the entry point name corresponding to an octal status code */

  dcl P_code		fixed bin (35);

  dcl 1 def		aligned,
       2 next_def		ptr,
       2 last_def		ptr,
       2 block_ptr		ptr,
       2 section		char (4) aligned,
       2 offset		fixed bin,
       2 entrypoint		fixed bin,
       2 defname		char (32) aligned;

  dcl seg_word		(0:last_word) fixed bin (35) based (entry_ptr);
  dcl packed_ptr		ptr unaligned based;
  dcl based_code		fixed bin (35) based;

  dcl (segment_name, offset_name)
			char (32);
  dcl (entry_ptr, ptr1, ptr2) ptr;
  dcl search_sw		bit (1);
  dcl type		fixed bin (2);
  dcl i			fixed bin;
  dcl (bit_count, last_word)	fixed bin (24);
  dcl (code, search_code)	fixed bin (35);

  dcl error_table_$		fixed bin (35) ext;

  dcl decode_definition_	entry (ptr, ptr) returns (bit (1) aligned);
  dcl decode_definition_$init entry (ptr, fixed bin (24));
  dcl hcs_$make_ptr		entry (ptr, char (*), char (*), ptr,
			fixed bin (35));
  dcl hcs_$status_mins	entry (ptr, fixed bin (2), fixed bin (24),
			fixed bin (35));
  dcl interpret_ptr_	entry (ptr, ptr, ptr);


  if P_code = 0
    then
         return ("0");

  entry_ptr = addr (P_code) -> packed_ptr;

  if ptr (entry_ptr, 0) = ptr (null, 0) then do;
				/* system's error_table_ */

      search_code = P_code;
ERROR_TABLE:
      call hcs_$make_ptr (null, "error_table_", "", entry_ptr, (0));
      if entry_ptr = null
        then
	   return ("");

      call hcs_$status_mins (entry_ptr, type, bit_count, code);
      if code ^= 0
        then
	   return ("");

      last_word = divide (bit_count, 36, 24, 0) - 1;
      do i = 0 to last_word while (search_code ^= seg_word (i));
      end;
      if i <= last_word
        then entry_ptr = ptr (entry_ptr, i);
        else
	   return ("");

      strp = addr (strbuf);
      call interpret_ptr_ (entry_ptr, null, strp);
      return (rtrim (struc.segment) || rtrim (struc.entryn));
    end;

  else if ptr (entry_ptr, 0) = addr (error_table_$) then do;
      entry_ptr = ptr (null, rel (entry_ptr));
      addr (search_code) -> packed_ptr = entry_ptr;
      search_code = search_code + 111000000000000000000000000000000b;
      go to ERROR_TABLE;
    end;

  else do;			/* another error table */
    ptr1 = ptr (entry_ptr, 0);
    call hcs_$status_mins (ptr1, type, bit_count, code);
    if code ^= 0
      then
	 return ("");

    segment_name, offset_name = "";
    call decode_definition_$init (ptr1, bit_count);
    search_sw = ^decode_definition_ (ptr1, addr (def));
    do while (search_sw);
      if def.section = "segn"
        then segment_name = def.defname;
      else if def.section = "link" | def.section = "stat" then do;
	offset_name = def.defname;
	call hcs_$make_ptr (null, segment_name, offset_name, ptr2, code);
	if ptr2 ^= null
	  then
	       if ptr2 -> based_code = P_code
	         then search_sw = "0"b;
        end;
      if search_sw then do;
	offset_name = "";
	search_sw = ^decode_definition_ (def.next_def, addr (def));
        end;
    end;

    if ptr2 ^= null
      then
	 if ptr2 -> based_code = P_code
	   then
	        return (rtrim (segment_name) || "$" || rtrim (offset_name));
    return ("");
  end;

  end get_code_name;

%include probe_info;


  /* ;;;;;;; */


%include interpret_ptr_struc;

  end probe_display_data_;




		    probe_display_request_.pl1      11/11/88  1554.4r w 11/11/88  1545.0       62487



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



/****^  HISTORY COMMENTS:
  1) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

probe_display_request_:
  proc (P_probe_info_ptr);

  /* This is the request processor for the display request - the actual work is done by probe_display_data_
   we just check the syntax -

   Modified 15 Oct 79 JRDavis
   Modified 08 Mar 80 JRDavis to always indirect through constant */
  /* Made subscript ranges work 07/23/82 S. Herbst */
  /* Changed for new probe_increment_indices_ calling sequence 08/25/83 S. Herbst */
  /* Changed to allow expression for the count arg 08/26/83 S. Herbst */
  /* Removed heuristic that always interpreted a pointer as an indirection 04/17/85 Steve Herbst */


  dcl P_probe_info_ptr	ptr aligned parameter;

  dcl indirect		bit (1) aligned;
				/* we should indirect through address supplied */
  dcl daddress		ptr;	/* to the place to dump */
  dcl dformat		char (32) aligned;
				/* name of format to use */
  dcl dunits		fixed bin (35);
				/* how many to dump */

  dcl a_ref_ptr		pointer;
  dcl 1 a_ref		aligned like reference_node based (a_ref_ptr);

  dcl 1 (source, target)	aligned like computational_data;

  dcl assign_$computational_	entry (ptr, ptr, fixed bin (35));

  dcl probe_display_data_	entry (ptr, ptr, char (32) aligned, fixed bin,
			fixed bin (35));

  dcl probe_get_$expression	entry (ptr,
			1 structure aligned like reference_node,
			fixed bin (35));
  dcl probe_get_$integer	entry (ptr, fixed bin (35), fixed bin (35));
  dcl probe_create_reference_ entry (ptr, ptr);
  dcl probe_increment_indices_
			entry (bit (1) aligned, (*) fixed bin,
			(2, *) fixed bin (24),
			fixed bin, bit (1) aligned, bit (1) aligned);
  dcl stu_$get_runtime_address
			entry (ptr, ptr, ptr, ptr, ptr, ptr, ptr)
			returns (ptr);

  dcl based_ptr		ptr aligned based;
  dcl code		fixed bin (35);
  dcl identifiers_name	char (ct -> identifier.length)
			based (ct -> identifier.name);

  dcl probe_error_		entry options (variable);
  dcl probe_et_$syntax_error	fixed bin (35) external static;

  dcl (addr, null, unspec)	builtin;
%page;

  probe_info_ptr = P_probe_info_ptr;
  indirect = "0"b;

  dunits = 1;
  dformat = "octal";		/* defaults */

  call probe_create_reference_ (probe_info_ptr, a_ref_ptr);
				/* make a reference node */

  if ct -> token.type >= probe_info.end_token
    then call probe_error_ (probe_info_ptr, probe_et_$syntax_error);
				/* no args ! */

  if ct -> token.type = TIMES | ct -> token.type = ARROW |
       ct -> token.type = C_INDIRECTION then do;
      indirect = "1"b;
      ct = ct -> token.next;
    end;

  call probe_get_$expression (probe_info_ptr, a_ref, code);
  if code ^= 0
    then go to SOME_ERROR;

  if indirect
    then daddress = a_ref.address_ptr -> based_ptr;
    else daddress = a_ref.address_ptr;

  if there_is_more () /* have specified a format */
    then do;
      if ct -> token.type ^= NAME_TYPE
        then goto SYNTAX_ERROR;
      dformat = identifiers_name;
      ct = ct -> token.next;

      if there_is_more ()
        then do;
	call probe_get_$expression (probe_info_ptr, a_ref, code);
	if code ^= 0
	  then go to SOME_ERROR;
	if a_ref.address_ptr = null
	  then go to SYNTAX_ERROR;

	unspec (source) = "0"b;
	source.address = a_ref.address_ptr;
	source.data_type = a_ref.type;
	source.prec_or_length = a_ref.precision;

	unspec (target) = "0"b;
	target.address = addr (dunits);
	target.data_type = real_fix_bin_1_dtype;
	target.prec_or_length = 35;

	call assign_$computational_ (addr (target), addr (source), code);
	if code ^= 0
	  then go to SYNTAX_ERROR;
        end;
    end;				/* trying for format */

  if there_is_more ()		/* too many args */
    then call probe_error_ (probe_info_ptr, probe_et_$syntax_error);

  if probe_info.execute
    then
         if a_ref.cross_section
	 then call display_cross_section;
	 else call probe_display_data_ (probe_info_ptr, daddress, dformat,
		 (dunits), code);

  if code ^= 0 then do;
SOME_ERROR:
      call probe_error_ (probe_info_ptr, code);
    end;
  return;


SYNTAX_ERROR:
  call probe_error_ (probe_info_ptr, probe_et_$syntax_error);
  return;


there_is_more:
  proc () returns (bit (1) aligned);
  return (ct -> token.type < end_token);
  end there_is_more;
%page;
display_cross_section:
  proc;

  /* Cycles through the subscript range specified and displays at a pointer
   to each array element. */

  dcl Indices		(16) fixed bin;
  dcl (Base_addr, Block_ptr, Linkage_ptr, Psymbp, Stack_ptr)
			ptr;
  dcl i			fixed bin;
  dcl done		bit (1) aligned;
  dcl 1 ref_subscripts	aligned based (a_ref.subscript_ptr)
			like reference_subscripts;

  do i = 1 to ref_subscripts.number;
    Indices (i) = ref_subscripts.value (1, i);
  end;
  Base_addr = a_ref.base_addr;
  Block_ptr = a_ref.source_info_ptr -> source_info.block_ptr;
  Linkage_ptr =
       a_ref.source_info_ptr -> source_info.seg_info_ptr
       -> seg_info.linkage_ptr;
  Psymbp = a_ref.symbol_ptr;
  Stack_ptr = a_ref.source_info_ptr -> source_info.stack_ptr;

  done = "0"b;
  do while (^done);
    daddress =
         stu_$get_runtime_address (Block_ptr, Psymbp, Stack_ptr, Linkage_ptr,
         Block_ptr,
         Base_addr, addr (Indices));

    call probe_display_data_ (probe_info_ptr, daddress, dformat, (dunits),
         code);

    call probe_increment_indices_ ("0"b, Indices, ref_subscripts.value,
         ref_subscripts.number,
         done, ("0"b));
  end;
  end display_cross_section;
%page;
%include probe_info;

  /* ;;;;;;; */

%include probe_operators;

  /* ;;;;;;; */

%include probe_tokens;

  /* ;;;;;;; */

%include probe_references;

  /* ;;;;;;; */

%include probe_source_info;

  /* ;;;;;;; */

%include probe_seg_info;

  /* ;;;;;;; */

%include std_descriptor_types;

  /* ;;;;;;; */

%include computational_data;

  end probe_display_request_;




		    probe_error_.pl1                10/27/88  1244.0r w 10/27/88  1225.3      108000



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



/****^  HISTORY COMMENTS:
  1) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

probe_error_:
  proc options (variable);

  /* *	PROBE_ERROR_
   *
   *	Prints error messages for probe subsystem, and aborts as many levels as necessary.
   *
   *	Interim kludge: probe_et_ is not a real error table; rather, values from probe_et_
   *	are guaranteed to be between 1000 and 2000, for ease of recognition.
   *
   *	Initial Version:  12 August 1974 by Jeffrey M. Broughton
   *	Modified: 8 Dec 78 by James R. Davis
   *	Modified: 9 Apr 79 By W. Olin Sibert to make it use probe_et_ instead.
   *	Modified: 06/23/79 WOS to add probe_error_$record, include request name 
   *	Modified: 03/10/80 JRD to fix off-by-one in checking error_code
   *	Modified: 01/16/85 by Steve Herbst to exit probe if doing "quit" request.
*/

  dcl message		char (132) varying;
				/* the message we will output */
  dcl ioa_message		char (300) varying;
  dcl total_message		char (400) varying;
  dcl prefix_string		char (64) varying;
  dcl type		fixed bin;
  dcl char_100		char (100) aligned;
				/* argument for convert_status_code */
  dcl based_str_lth		fixed bin (21);
  dcl based_str_ptr		pointer;
  dcl based_str		char (based_str_lth) based (based_str_ptr);
  dcl error_code		fixed bin (35);
  dcl reason		fixed bin;/* index into probe_et_ */
  dcl nargs		fixed bin;
  dcl first_arg		fixed bin;
  dcl output_switch		pointer;
  dcl (debug_sw, long_sw)	bit (1) aligned;

  dcl alp			ptr;	/* our arg list pointer */

  dcl 1 descriptor		aligned based like desc_;

  dcl 1 arg_list		based (alp) aligned,
       2 n_args		bit (17) unal,
       2 code		bit (19) unal,
       2 n_desc		bit (17) unal,
       2 fill		bit (19) unal,
       2 ptr		(1000) ptr aligned;

  dcl based_ptr		pointer aligned based;
  dcl based_fb35		fixed bin (35) based;

  dcl cu_$cl		entry (bit (1) aligned);
  dcl cu_$arg_list_ptr	entry (ptr);
  dcl com_err_		entry options (variable);
  dcl convert_status_code_	entry (fixed bin (35), char (8) aligned,
			char (100) aligned);
  dcl ioa_$ioa_switch	entry options (variable);
  dcl ioa_util_$rs_with_string
			entry (ptr, fixed bin (21), ptr, fixed bin,
			char (*) varying);

  dcl iox_$error_output	pointer external static;
  dcl probe_data_$debug_sw	bit (1) aligned external static;
  dcl probe_et_$recorded_message
			fixed bin (35) external static;

  dcl (
      WARNING		init (1), /* format and print a warning message */
      ERROR		init (2), /* print a message and goto probe_info.request_line_abort */
      SYSTEM_ERROR		init (3), /* now same as ERROR; retained for historical reasnos */
      RECORD_ONLY		init (4), /* format a message and leave it in probe_info */
      MALFUNCTION		init (5)
      ) /* format and print the message, and call the listener */
			fixed bin internal static options (constant);

  dcl whoami		char (32) internal static
			options (constant) init ("probe_error_");
  dcl MALFUNCTION_MESSAGE	char (120) internal static
			options (constant) init
			(
			"Please issue the command ""trace_stack"", and give the output to system maintenence personnel."
			);

  dcl probe_error_return	condition;

  dcl (null, addr, addrel, binary, index, rtrim, substr, length)
			builtin;

  /*  */

  type = ERROR;			/* print message, and abort request */
  goto COMMON;


probe_error_$warning:
  entry options (variable);

  type = WARNING;			/* just print message and return */
  goto COMMON;


probe_error_$system:
  entry options (variable);

  type = SYSTEM_ERROR;		/* same as probe_error_ proper, retained for compatibility */
  goto COMMON;


probe_error_$record:
  entry options (variable);

  type = RECORD_ONLY;		/* leave message in probe_info.recorded_message */
  goto COMMON;


probe_error_$malfunction:
  entry options (variable);

  type = MALFUNCTION;		/* print litany about malfunction, and get new command level */
  goto COMMON;


COMMON:
  probe_error_table_ptr = addr (probe_et_$);
  call cu_$arg_list_ptr (alp);	/* get our arglist pointer */

  nargs = binary (arg_list.n_args);
  error_code = 0;			/* default values */
  first_arg = -1;
  probe_info_ptr = null ();

  if nargs = 0 then do;		/* call probe_error_ () */
    end;				/* everything has default values */

  else if nargs = 1 then do;		/* call probe_error_ (code) */
      error_code = arg_list.ptr (1) -> based_fb35;
    end;

  else if nargs = 2 then do;		/* call probe_error_ (probe_info_ptr, code); */
      probe_info_ptr = arg_list.ptr (1) -> based_ptr;
      error_code = arg_list.ptr (2) -> based_fb35;
    end;

  else do;			/* call probe_error_ (probe_info_ptr, code, ioa_stuff); */
    probe_info_ptr = arg_list.ptr (1) -> based_ptr;
    error_code = arg_list.ptr (2) -> based_fb35;
    first_arg = 3;
  end;

  if probe_info_ptr = null () then do;	/* get some modes */
      long_sw = "1"b;
      debug_sw = probe_data_$debug_sw;
      output_switch = iox_$error_output;
    end;

    else do;			/* we have probe_info, lets use it */
      long_sw = probe_modes.error_messages = LONG_mode_type;
      if probe_modes.catch_errors
        then debug_sw = "1"b;		/* if this is on, trap all calls to probe_error_ */
      else if probe_modes.catch_error_once then do;
				/* in this case, catch only this call */
	debug_sw = "1"b;
	probe_modes.catch_error_once = "0"b;
        end;
      else debug_sw = "0"b;

      if type = WARNING
        then
	   output_switch = probe_info.output_switch;
        else output_switch = iox_$error_output;
    end;

  if error_code = 0
    then /* no error message */
         message = "";

  else if error_code = probe_et_$recorded_message then do;
				/* just print the leftover message */
      if probe_info_ptr ^= null ()
        then
	   total_message = probe_info.error_message;
        else total_message =
	        "No probe_info available to print recorded message from.";
      goto PROCESS_RECORDED_MESSAGE;
    end;

  else if error_code > 1000
       & error_code <= probe_error_table.n_messages + 1000 then do;
      reason = error_code - 1000;	/* convert to an index into probe_et_ */
      if long_sw
        then /* get a message from probe_et_ */
	   message = probe_error_table.long_message (reason);

        else do;
	if length (probe_error_table.short_message (reason)) = 0
	  then /* the short is the same as the long */
	       message = probe_error_table.long_message (reason);
	  else message = probe_error_table.short_message (reason);
				/* we want the short message */
        end;
    end;

  else do;			/* otherwise, assume it's a standard status code */
    call convert_status_code_ (error_code, (""), char_100);
    message = rtrim (char_100);	/* use long version, regardless of long_sw */
  end;

  if long_sw then do;		/* construct and output prefix "probe (value): " */
      if probe_info_ptr = null ()
        then prefix_string = "probe: ";
        else do;
	prefix_string = rtrim (probe_static_info.name);
	if (probe_info.executing_request) & (probe_info.request_name ^= "")
	  then do;
	    prefix_string = prefix_string || " (";
				/* only onclude request name if there is one */
	    prefix_string =
	         prefix_string || rtrim (probe_info.request_name);
	    prefix_string = prefix_string || ")";
	  end;
	prefix_string = prefix_string || ": ";
        end;
    end;

    else prefix_string = "";

  if index (message, "^") = 0 then do;	/* it's not an ioa_ control string, see if next arg is */
      if first_arg > 0 then do;	/* this is only possible if there are enough args to test */
	if arg_list.ptr (nargs + first_arg) -> descriptor.type_ = char_dtype
	  then do;
	    based_str_lth =
	         arg_list.ptr (nargs + first_arg) -> descriptor.precision_;
	    based_str_ptr = arg_list.ptr (first_arg);
	  end;

	else if arg_list.ptr (nargs + first_arg) -> descriptor.type_
	     = varying_char_dtype then do;
	    based_str_lth =
	         addrel (arg_list.ptr (first_arg), -1) -> based_fb35;
	    based_str_ptr = arg_list.ptr (first_arg);
	  end;

	else do;
	  based_str_lth = -1;
	  based_str_ptr = null ();
	end;

	if based_str_ptr ^= null () then do;
	    if length (message) > 0
	      then
		 message = message || " ";
	    message = message || based_str;
	    first_arg = first_arg + 1;/* take any ioa args from next arg */
	  end;
        end;
    end;

  if first_arg > 0
    then /* get ioa_string and additional cruft */
         call ioa_util_$rs_with_string (addr (substr (message, 1, 1)),
	    length (message),
	    alp, first_arg, ioa_message);
    else ioa_message = rtrim (message);

  total_message = prefix_string;	/* assemble the message into one place */
  total_message = total_message || ioa_message;

  if probe_info_ptr ^= null () then do; /* if there's a place, */
      probe_info.error_message = total_message;
				/* copy last message into probe_info */
      probe_info.error_code = error_code;
    end;

PROCESS_RECORDED_MESSAGE:
  if type ^= RECORD_ONLY
    then /* print the message, unless we're just recording */
         call ioa_$ioa_switch (output_switch, "^a", total_message);

  if debug_sw then do;		/* this causes all errors to get a new command level */
      call com_err_ (0, whoami,
	 "Debug on, calling cu_$cl. Type = ^[Warning^;Error^;System Error^;Record only^;Malfunction.^].",
	 type);
      if type = RECORD_ONLY
        then /* tell the guy what the message is gonna be */
	   call ioa_$ioa_switch (probe_info.output_switch, "Message: ^a.",
	        total_message);
      call cu_$cl ("0"b);
    end;				/* allow "start" to cause normal action */

  if type = WARNING
    then return;			/* just return, with no further ado */
  else if type = RECORD_ONLY
    then return;			/* same if just recording */

  else if type = ERROR | type = SYSTEM_ERROR then do;
      if probe_info_ptr = null () then do;
	call com_err_ (0, whoami,
	     "Cannot abort probe; no probe_info available. Returning to command level."
	     );
	goto CALL_LISTENER;
        end;

      if probe_info.executing_quit_request
        then go to probe_info.abort_probe_label;
        else goto probe_info.abort_line_label;
				/* goto to the global abort label */
    end;

  else do;			/* it was a malfunction */
    call ioa_$ioa_switch (output_switch, MALFUNCTION_MESSAGE);
    call com_err_ (0, whoami, "Returning to command level.");
    goto CALL_LISTENER;
  end;

CALL_LISTENER:
  on probe_error_return goto RETURN_ANYWAY;
				/* set up a trap for this */

  call cu_$cl (^debug_sw);

  call com_err_ (0, whoami, "Illegal return. Returning to command level.");
  goto CALL_LISTENER;

RETURN_ANYWAY:
  return;

  /*  */

%include probe_error_table;

  /* ;;;;;;; */

%include probe_info;

  /* ;;;;;;; */

%include probe_static_info;

  /* ;;;;;;; */

%include probe_modes;

  /* ;;;;;;; */

%include descriptor;

  /* ;;;;;;; */

%include std_descriptor_types;

  end;				/* probe_error_ external procedure */




		    probe_et_.alm                   10/24/88  1616.2rew 10/24/88  1354.1       14256



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

" HISTORY COMMENTS:
"  1) change(88-10-18,WAAnderson), approve(88-10-18,MCR7952),
"     audit(88-10-18,JRGray), install(88-10-24,MR12.2-1184):
"     Probe source archive split. Part of C-Probe support.
"                                                      END HISTORY COMMENTS


"
"	Error table for new probe
"
"	Created (version 0) 04/08/79 W. Olin Sibert
"
"	This version is just an interim kludge to get the error codes out of
"	pl1 include files and remove the necessity for keeping the numbers
"	consistent. It will be converted to be a real error table when the
"	version 2 error table macros becoma available.
"

	name	probe_et_

	set	error_number,1
	use	messages

	macro	ec
	segdef	&1
&1:	vfd	36/error_number+1000
	vfd	36/&l2
	aci	@&2@,40
	vfd	36/&l3
	aci	@&3@,108
	set	error_number,error_number+1
	&end

	include	probe_et_

	set	error_number,error_number-1

	use	header
	vfd	36/error_number

	use	messages
	use	header

	join	/text/header,messages

	end




		    probe_eval_.pl1                 11/11/88  1554.4rew 11/11/88  1541.3      282069



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

/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

/****^  HISTORY COMMENTS:
  1) change(87-06-18,RWaters), approve(87-06-18,MCR7687), audit(87-06-24,Huen),
     install(87-07-15,MR12.1-1040):
     Probe error #110: correctly decode lengths of char (*) parameters.
  2) change(88-05-31,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Extracted a chunk of code in the main body of the program and made
     it into an internal procedure called 'do_subscripts'. This was done
     because the code may now be executed in two different locations.
     Changed code so it accepts the first subscript of a two dimensional
     character array. This facilitates the printing of character strings
     by row. Of course both subscripts may be supplied, but that implies
     only a single character is desired.
  3) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
  4) change(88-09-28,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added code that allows pointers to be referenced with subscripts.
     If the pointer points to character data and subrange is specified,
     the values will be displayed in string format. Any other data type
     will be displayed in array format.
  5) change(88-10-28,WAAnderson), approve(88-10-28,MCR7952),
     audit(88-10-31,RWaters), install(88-11-11,MR12.2-1210):
     Added code to evaluate character pointers as decribed in the MTB.
     
     Consider the following declaration:
     
      char *ptr;
     
     The following are possible references to the pointer 'ptr' and the
     manner in which the reference is interpreted by probe:
     
     *ptr      - refers to a single character at the address specified
                 by the contents of 'ptr'.
      ptr      - refers to the address in 'ptr'.
      ptr[]    - refers to the contiguous series of characters beginning
                 with the character specified by the address in 'ptr'
                 and ending with the first occurence of a null.
      ptr[N]   - refers to the single character whose address is computed
                 by taking the contents of 'ptr' and adding N bytes to that
                 address.
      ptr[N:M] - refers to the characters from ptr+N to ptr+M where
                 N and M are byte offsets.
                                                   END HISTORY COMMENTS */

probe_eval_$evaluate:
  proc (P_probe_info_ptr, P_reference, P_switches, P_value_wanted, P_code);

  /* given a reference_node, and some info about how to evaluate it, get a pointer to its storage,
   and its symbol node - for use by get_value only

   modified 13 Sept 79 JRD
   modified 19 Feb 80 JRd for probe variables */
  /* Changed to accept first 3 bits of P_switches 08/26/81 S. Herbst */
  /* Changed to test explicit/implicit qualifiers before indirecting 09/18/81 S. Herbst */
  /* Fixed 'symbol' request to not check for null qualifier 08/11/82 S. Herbst */
  /* Fixed references to program-declared external procedures 09/22/82 S. Herbst */
  /* Modified June 83 JMAthane for PASCAL  :
   - replaced when necessary references to runtime_symbol structure by calls to runtime_symbol_info_ subroutine.
   - modified to know types.
   - modified to add "builtin" bit in reference structure. */
  /* Added version string to runtime_symbol_info_ structures 10/06/83 S. Herbst */
  /* Fixed to translate "-" to "_" in COBOL identifiers before looking up in symbol table 09/20/84 Steve Herbst */
  /* Fixed to special-case address of a varying string parameter 02/27/85 Steve herbst */
  /* Fixed to correctly decode lengths of char (*) parameters 05/21/87 by RWaters */


  dcl P_probe_info_ptr	ptr parameter;
  dcl 1 P_reference		structure aligned like reference_node parameter;
  dcl P_switches		bit (36) aligned parameter;
  dcl P_value_wanted	bit (1) aligned parameter;
  dcl P_code		fixed bin (35) parameter;

  dcl CLASS_PARAMETER	fixed bin int static options (constant)
			init (8);

  dcl switches		bit (36);
  dcl want_external_sw	bit (1) unaligned defined (switches) pos (1);
  dcl default_external_sw	bit (1) unaligned defined (switches) pos (2);
  dcl default_offset_zero_sw	bit (1) unaligned defined (switches) pos (3);

  dcl 1 ref_subscripts	aligned like reference_subscripts
			based (P_reference.subscript_ptr);
  dcl 1 ref_arg_list	aligned like reference_arg_list
			based (P_reference.argument_list);
  dcl 1 ref_source_info	aligned like source_info
			based (P_reference.source_info_ptr);
  dcl 1 sub_refs		aligned like subscript_reference_ptrs
			aligned based (P_reference.subscript_refs_ptr);

  dcl 1 subscript		aligned based like reference_node;
				/* dummy for subscript */

  dcl 1 type_info		like runtime_type_info;
  dcl 1 address_info	like runtime_address_info;

  dcl code		fixed bin (35);
  dcl ext_name		char (256) varying;
  dcl containing_block	pointer;	/* to block in which symbol found */
  dcl (i, j)		fixed bin (35);
  dcl tp			pointer;
  dcl sub			pointer;
  dcl dimensions		fixed bin;/* how many dims the symbol has */
  dcl real_bounds		(2, 16) fixed bin (24);
  dcl temp		(2) fixed bin (35);
  dcl steps		fixed bin;
  dcl translated_name	char (256) unaligned varying;

  dcl (
      probe_et_$bad_section,
      probe_et_$bad_subscript,
      probe_et_$not_based,
      probe_et_$no_address,
      probe_et_$null_ptr,
      probe_et_$recorded_message,
      probe_et_$wrong_dims
      )			fixed bin (35) external static;

  dcl ioa_$ioa_switch	entry options (variable);
  dcl probe_operate_$infix	entry (ptr, char (1) aligned,
			1 structure aligned like reference_node,
			1 structure aligned like reference_node,
			1 structure aligned like reference_node,
			fixed bin (35));

  dcl stu_$find_runtime_symbol
			entry (pointer, char (*), pointer, fixed bin)
			returns (pointer);
  dcl stu_$get_runtime_address
			entry (ptr, ptr, ptr, ptr, ptr, ptr, ptr)
			returns (ptr);
  dcl probe_get_c_address_
			entry (ptr, fixed bin (6) unsigned, ptr, ptr)
			returns (ptr);
  dcl stu_$get_implicit_qualifier
			entry (ptr, ptr, ptr, ptr, ptr) returns (ptr);

  dcl probe_request_mgr_$find_builtin
			entry (ptr, char (*),
			entry () options (variable), ptr,
			fixed bin (35));
  dcl builtin_entry		entry variable options (variable);
  dcl probe_variable_mgr_$find_variable
			entry (ptr, ptr, fixed bin (35));

  dcl probe_check_ptr_$indirectable
			entry (ptr, fixed bin (35));
  dcl probe_error_$record	entry options (variable);
  dcl probe_find_procedure_	entry (ptr, char (*), bit (36) aligned, ptr,
			fixed bin (35));
  dcl probe_array_bounds_	entry (ptr, ptr, 1 aligned like reference_node,
			1 aligned like source_info, ptr, fixed bin (35))
			returns ((2, 16) fixed bin (24));
  dcl probe_stack_trace_$find_previous_invocation
			entry (ptr, ptr, fixed bin);
  dcl probe_stack_trace_$find_block_frame
			entry (ptr, ptr);

  dcl probe_invoke_$function	entry (pointer, 1 aligned like reference_node,
			1 aligned like reference_node, fixed bin (35));
  dcl probe_cv_stu_code_	entry (fixed bin (35));


  dcl new_size		fixed bin;
  dcl (first_sub, replace_sub)
			fixed bin;
  dcl special_entry		bit (1);
  dcl make_this_ref_node_a_constant
			bit (1);
  dcl must_add_in_ptr_subscript
			bit (1);

  dcl (abs, addr, addrel, convert, divide, fixed, index, mod, null,
      substr, translate, unspec)
			builtin;
				/**/

  probe_info_ptr = P_probe_info_ptr;
  switches = P_switches;
  P_code = 0;

  if P_reference.constant then do;	/* fill in information */
      tp = P_reference.constant_token_ptr;
				/* get pointer to token containing constant */
      P_reference.address_ptr = tp -> constant.data_ptr;
      P_reference.descriptor = tp -> constant.data_type;
      P_reference.type = divide (tp -> constant.data_type, 2, 17, 0);
      P_reference.type_ptr = null;
      P_reference.packed = (mod (P_reference.descriptor, 2) = 1);
      P_reference.precision = tp -> constant.scale_and_precision;
      return;
    end;

  if ^probe_info.flags.execute then do; /* just syntax checking */
      if P_reference.n_arguments > 0
        then /* may be, can't tell till execute time */
	   P_reference.function = "1"b;
      return;
    end;

  /* could optimize some builtins and probe variables by checking for leading
   % or $ in name, since no user variable could have such a thing.
*/

  if P_reference.path
    then go to GET_EXTERNAL;

  if ^P_reference.have_generation then do;
      ref_source_info = current_source;
      ref_source_info.stmnt_map_entry_index = 0;
				/* haven't found the line yet */
    end;

  if probe_info.language_type = COBOL_lang_type
    then translated_name = translate (P_reference.name, "_", "-");
    else translated_name = P_reference.name;

  P_reference.symbol_ptr =
       stu_$find_runtime_symbol (ref_source_info.block_ptr, (translated_name),
       containing_block, steps);

  if P_reference.symbol_ptr ^= null then do;
				/* symbol found */

      type_info.version = RUNTIME_TYPE_INFO_VERSION_1;

      call runtime_symbol_info_$type (P_reference.symbol_ptr,
	 addr (type_info), code);
      if code ^= 0
        then go to SOME_ERROR;

      address_info.version = RUNTIME_ADDRESS_INFO_VERSION_1;

      call runtime_symbol_info_$address (P_reference.symbol_ptr,
	 addr (address_info), code);
      if code ^= 0
        then go to SOME_ERROR;

      P_reference.type = type_info.type;
      P_reference.type_ptr = type_info.type_addr;
      P_reference.packed = type_info.packed;
      P_reference.descriptor = type_info.type * 2;

      if type_info.packed
        then P_reference.descriptor = P_reference.descriptor + 1;

      if data_type_info_$info (P_reference.type).computational
	 | probe_info.language_type = PASCAL_lang_type
        then P_reference.precision =
	        decode (type_info.size, type_info.size_is_encoded);

      if type_info.scale ^= 0		/* does type have a scale */
        then addr (P_reference.precision) -> encoded_precision.scale
	        = type_info.scale;


      if P_reference.type = ext_procedure_runtime_dtype then do;
	if probe_info.language_type = PASCAL_lang_type then do;
	  end;
	  else go to GET_EXTERNAL;
        end;


      /* get proper stack frame and generation */

      if P_reference.type = ext_entry_runtime_dtype then do;
				/* entry, found in root block, want son */
	containing_block =
	     addrel (containing_block,
	     containing_block -> runtime_block.son);
	steps = steps - 1;
        end;

      if ref_source_info.block_ptr ^= containing_block then do;
				/* symbol found in father block */
	ref_source_info.block_ptr = containing_block;
				/* remember correct frame */
	if ref_source_info.stack_ptr ^= null
	  then
	    do i = 1 to steps;	/* chase display to get correct frame */
	    if (probe_info.language_type = C_lang_type)
	      then
		 ref_source_info.stack_ptr =
		      ref_source_info.stack_ptr -> frame.back;
	      else
		 ref_source_info.stack_ptr =
		      ref_source_info.stack_ptr -> frame.display;
	  end;
	  else call probe_stack_trace_$find_block_frame (probe_info_ptr,
		  addr (ref_source_info));
        end;			/* entry ptr is diff., leave others to handle it */

      /* User wants N'th previous invocation of this variable -
   This is only meaningful for automatic storage,
   although I suppose one could define a meaning for controlled,
   and involves searching the stack from here back.
   It is used with static types (labels, entries) as a convenient way to specify a block,
   which is allowed in a generation. i.e. v foo [label[-4]]
*/
      if P_reference.invocation_level > 0
        then if P_reference.type >= label_constant_runtime_dtype
	        & P_reference.type <= ext_procedure_runtime_dtype
	     then P_reference.precision = P_reference.invocation_level;
				/* must be [label[-N]] */
	     else call probe_stack_trace_$find_previous_invocation (
		     probe_info_ptr,
		     P_reference.source_info_ptr,
		     (1 + abs (P_reference.invocation_level)));


      /* Based variable - either have explicit ptr or must get implicit one */

      if address_info.class = 3
        then /* based variable */
	   if P_reference.base_addr = null then do;
				/* no explicit address */
	       P_reference.base_addr = stu_$get_implicit_qualifier
		  (ref_source_info.block_ptr, P_reference.symbol_ptr,
		  ref_source_info.stack_ptr,
		  (ref_source_info.seg_info_ptr -> seg_info.linkage_ptr),
		  ref_source_info.block_ptr);
	       if probe_info.request_name ^= "symbol" then do;
		 call probe_check_ptr_$indirectable (P_reference
		      .base_addr, code);
		 if code ^= 0 then do;
		     if code = probe_et_$null_ptr
		       then call probe_error_$record (probe_info_ptr,
			       0, "Implicit qualifier ^a is null.",
			       qualifier_name (P_reference.symbol_ptr));
		       else call probe_error_$record (probe_info_ptr,
			       code, "Implicit qualifier ^a = ^w ^w",
			       qualifier_name (P_reference.symbol_ptr),
			       substr (unspec (P_reference.base_addr),
			       1, 36),
			       substr (unspec (P_reference.base_addr),
			       37, 36));
		     go to RECORDED_MESSAGE;
		   end;
	         end;
	     end;
	     else ;		/* have addr already */
      else if P_reference.base_addr ^= null then do;
				/* not based, but has ptr ?!? */
	call probe_error_$record (probe_info_ptr, probe_et_$not_based,
	     P_reference.name);
	goto RECORDED_MESSAGE;	/* leave, and let our caller decide what to do */
        end;

      if ^P_value_wanted then do;
	P_reference.address_ptr = P_reference.base_addr;
	return;
        end;

      special_entry = "0"b;

      goto SKIPPER;

add_c_dims:
  entry (P_probe_info_ptr, P_reference, P_switches, P_value_wanted, P_code,
       original_class);

      dcl original_class	    fixed bin (6) unsigned parameter;

      P_code = 0;
      switches = P_switches;
      probe_info_ptr = P_probe_info_ptr;

      special_entry = "1"b;

SKIPPER:

      dimensions = runtime_symbol_info_$array_dims (P_reference.symbol_ptr);

      must_add_in_ptr_subscript = "0"b;
      if P_reference.n_subscripts > dimensions
        then do;			/* cant all be subscripts, hope they're args */
	if (probe_info.language_type = C_lang_type
	     & P_reference.type = pointer_dtype) then do;
	    must_add_in_ptr_subscript = "1"b;
	  end;
	  else
	       P_reference.function = "1"b;
        end;

      make_this_ref_node_a_constant = "0"b;
      ref_subscripts.number = dimensions;
      if dimensions > 0 then do;
	real_bounds = probe_array_bounds_ (probe_info_ptr,
	     P_reference.symbol_ptr, P_reference, ref_source_info,
	     P_reference.base_addr, code);
	if code ^= 0
	  then goto SOME_ERROR;	/* something wrong with the array bounds */

	if P_reference.n_subscripts < dimensions then do;
				/* too few */
	    if P_reference.n_subscripts = 0 then do;
				/* assume ref to whole aray as cross-section */
	        P_reference.cross_section = "1"b;
	        ref_subscripts.value = real_bounds;
				/* ahhh... PL/I ! */

	        /* possible hazard:  We have set up subscripts, but no subsidiary reference_nodes exists.
   sub_refs are all null.  This should not be a  problem, as there is no other reason to
   look at the sub_refs
*/
	      end;		/* assuming ref to whole */
				/* Time to handle C strings. A C string is actually a 2 dim array. We want
   to print out all the elements of the specified row. */

	    else if (probe_info.language_type = C_lang_type &
	         P_reference.type = 21 &
	         P_reference.n_subscripts = 1 &
	         dimensions = 2) then do;
	        sub_refs.ptr (1, 2) = null ();
	        call do_subscripts;
	        ref_subscripts.value (1, 2) = 0;
	        P_reference.n_subscripts = 2;
	        P_reference.precision = 256;
	        make_this_ref_node_a_constant = "1"b;
	      end;
	    else do;		/* have at least one, but not enough -fail */
	      call probe_error_$record (probe_info_ptr, 0,
		 "^a needs ^d subscripts", P_reference.name, dimensions);
	      goto RECORDED_MESSAGE;
	    end;
	  end;			/* too few subscripts case */
	  else call do_subscripts;	/* have proper number */

	if ref_source_info.block_ptr -> runtime_block.fortran
	  then /* must reverse subscript array */
	    do i = 1 to divide (dimensions, 2, 17, 0);
	    temp (1) = ref_subscripts.value (1, i);
	    temp (2) = ref_subscripts.value (2, i);
	    ref_subscripts.value (1, i) =
	         ref_subscripts.value (1, dimensions + 1 - i);
	    ref_subscripts.value (2, i) =
	         ref_subscripts.value (2, dimensions + 1 - i);
	    ref_subscripts.value (1, dimensions + 1 - i) = temp (1);
	    ref_subscripts.value (2, dimensions + 1 - i) = temp (2);
	  end;
        end;

      /* Now that we have the subscripts and the base ptr and the stack frame, it is possible to
   get the address of the symbol itself
*/

      if data_type_info_$info (P_reference.type).type
        then
	   P_reference.address_ptr = null;
        else do;
	if (special_entry | P_reference.address_ptr ^= null ())
	  then
	       P_reference.address_ptr =
		  probe_get_c_address_ (P_reference.address_ptr,
		  original_class,
		  P_reference.symbol_ptr,
		  addr (ref_subscripts.value));
	  else
	       P_reference.address_ptr =
		  stu_$get_runtime_address (ref_source_info.block_ptr,
		  P_reference.symbol_ptr,
		  ref_source_info.stack_ptr,
		  (ref_source_info.seg_info_ptr -> seg_info.linkage_ptr),
		  ref_source_info.block_ptr, P_reference.base_addr,
		  addr (ref_subscripts.value));


	if (must_add_in_ptr_subscript) then do;
	    new_size = 0;

	    if (fixed (P_reference.symbol_ptr -> runtime_symbol.ndims)
	         < P_reference.n_subscripts) then do;
	        begin;

		dcl (suber1, suber2)        fixed bin;
		dcl temp_inx	        fixed bin;
		dcl temp_ptr	        ptr;

		temp_ptr = P_reference.symbol_ptr;
		do while (fixed (temp_ptr -> runtime_symbol.type)
		     = pointer_dtype |
		     fixed (temp_ptr -> runtime_symbol.type)
		     = c_typeref_dtype);
		  temp_ptr =
		       addrel (temp_ptr,
		       fixed (temp_ptr -> runtime_symbol.son));
		end;

		if (fixed (temp_ptr -> runtime_symbol.type) = char_dtype)
		  then do;
		    first_sub =
		         fixed (P_reference.symbol_ptr
		         -> runtime_symbol.ndims) + 1;
		    replace_sub = 0;
		    do temp_inx = first_sub to P_reference.n_subscripts;

		      replace_sub = replace_sub + 1;
		      suber1 = 0;
		      suber2 = 0;

		      begin;
		        dcl based_s_int	      fixed bin (35)
					      based (sub_refs
					      .ptr (1, temp_inx)
					      -> subscript
					      .address_ptr);
		        dcl based_l_int	      fixed bin (71)
					      based (sub_refs
					      .ptr (1, temp_inx)
					      -> subscript
					      .address_ptr);
		        dcl based_str	      char (sub_refs
					      .ptr (1, temp_inx)
					      -> subscript.precision
					      + 1)
					      based (sub_refs
					      .ptr (1, temp_inx)
					      -> subscript
					      .address_ptr);
		        if (sub_refs.ptr (1, temp_inx) -> subscript.type
			   = real_fix_dec_9bit_ls_dtype)
			then

			     suber1 = convert (suber1, based_str);
		        else if (sub_refs.ptr (1, temp_inx)
			   -> subscript.type = real_fix_bin_1_dtype)
			then
			     suber1 = convert (suber1, based_s_int);
		        else if (sub_refs.ptr (1, temp_inx)
			   -> subscript.type = real_fix_bin_2_dtype)
			then
			     suber1 = convert (suber1, based_l_int);
		      end;

		      if (sub_refs.ptr (2, temp_inx) ^= null ()) then do;
			begin;
			  dcl based_s_int		fixed
						bin (35)
						based (sub_refs
						.ptr (2, temp_inx)
						-> subscript
						.address_ptr);
			  dcl based_l_int		fixed
						bin (71)
						based (sub_refs
						.ptr (2, temp_inx)
						-> subscript
						.address_ptr);
			  dcl based_str		char (sub_refs
						.ptr (2, temp_inx)
						-> subscript
						.precision + 1)
						based (sub_refs
						.ptr (2, temp_inx)
						-> subscript
						.address_ptr);
			  if (sub_refs.ptr (2, temp_inx)
			       -> subscript.type
			       = real_fix_dec_9bit_ls_dtype)
			    then

			         suber2 = convert (suber2, based_str);
			  else if (sub_refs.ptr (2, temp_inx)
			       -> subscript.type = real_fix_bin_1_dtype)
			    then
			         suber2 = convert (suber2, based_s_int);
			  else if (sub_refs.ptr (2, temp_inx)
			       -> subscript.type = real_fix_bin_2_dtype)
			    then
			         suber2 = convert (suber2, based_l_int);
			end;
			sub_refs.ptr (1, replace_sub) =
			     sub_refs.ptr (1, temp_inx);
			sub_refs.ptr (2, replace_sub) =
			     sub_refs.ptr (2, temp_inx);
		        end;
		      P_reference.n_subscripts = replace_sub;
		      if (suber2 > suber1)
		        then
			   new_size = suber2 - suber1 + 1;
		        else new_size = 1;
		    end;
		  end;
	        end;
	      end;
	    call probe_operate_$infix (P_probe_info_ptr, "+", P_reference,
	         sub_refs.ptr (1, 1) -> subscript, P_reference, code);
	    P_reference.precision = new_size;
	    P_reference.flags.c_sub_c_ptr = "1"b;
	  end;

	if P_reference.address_ptr = null () then do;
				/* failure */
	    call probe_error_$record (probe_info_ptr, probe_et_$no_address,
	         P_reference.name);
	    goto RECORDED_MESSAGE;	/* but only if we wanted it in the first place */
	  end;

	if address_info.class = CLASS_PARAMETER
	     & /* special-case varying string parameter: */
	     (type_info.type = varying_bit_dtype
	     | type_info.type = varying_char_dtype)
	  then
	       /* parameter ptr points to string portion */
	       /* make it point to the length word */
	       P_reference.address_ptr =
		  addrel (P_reference.address_ptr, -1);
        end;

      if (make_this_ref_node_a_constant) then do;
	if (P_reference.c_symbol_ptr = null ())
	  then
	       P_reference.symbol_ptr = null ();
	P_reference.flags.cross_section = "0"b;
	P_reference.flags.constant = "1"b;
	P_reference.optional_info.n_subscripts = 0;
	P_reference.optional_info.n_arguments = 0;
        end;
      if P_reference.function then do;
	if P_reference.n_subscripts - P_reference.n_arguments ^= dimensions
	  then do;
	    call probe_error_$record (probe_info_ptr, probe_et_$wrong_dims,
	         P_reference.name);
	    goto RECORDED_MESSAGE;
	  end;

	if P_reference.type ^= entry_dtype
	     & P_reference.type ^= int_entry_runtime_dtype
	     & P_reference.type ^= ext_entry_runtime_dtype
	     & P_reference.type ^= ext_procedure_runtime_dtype then do;

	    call probe_error_$record (probe_info_ptr, probe_et_$wrong_dims,
	         P_reference.name);
	    goto RECORDED_MESSAGE;
	  end;

	if P_reference.cross_section
	  then goto BAD_CROSS_SECTION;
	ref_arg_list.number = P_reference.n_arguments;
	do i = 1 to P_reference.n_arguments;
	  ref_arg_list.node (i) = sub_refs.ptr (1, dimensions + i);
	end;

	if ^want_external_sw
	  then call probe_invoke_$function (probe_info_ptr, P_reference,
		  P_reference, P_code);
	return;
        end;
      return;

    end;


  if steps = -4 | steps = -1 then do;

      /* Symbol not found - but it may be a probe variable, or a builtin reference or a function call to an external entry */


      /* first look for probe variable */

      call probe_variable_mgr_$find_variable (probe_info_ptr,
	 addr (P_reference), code);
      if code = 0
        then
	   return;

      /* next try for a builtin */

      call probe_request_mgr_$find_builtin (probe_info_ptr,
	 (P_reference.name), builtin_entry, (null), code);
      if code = 0 then do;
	call builtin_entry (probe_info_ptr, addr (P_reference), code);
	if code ^= 0
	  then goto SOME_ERROR;
	P_reference.builtin = "1"b;
	return;
        end;


      /* that didn't work, so try for an external */

      if ^default_external_sw & index (P_reference.name, "$") = 0
        then go to NOT_FOUND;
GET_EXTERNAL:
      ref_source_info.entry_ptr = null ();
      call probe_find_procedure_ (probe_info_ptr, (P_reference.name),
	 (switches), addr (ref_source_info), (0));
      P_reference.address_ptr = ref_source_info.entry_ptr;
CHECK_EXTERNAL:
      if P_reference.address_ptr ^= null then do;

	P_reference.flags.constant = "1"b;
	if P_reference.n_arguments ^= P_reference.n_subscripts then do;
	    call probe_error_$record (probe_info_ptr, 0,
	         "The external entry ^a may not be subscripted",
	         P_reference.name);
	    goto RECORDED_MESSAGE;
	  end;
	if P_reference.n_arguments > 0 | P_reference.function then do;
	    P_reference.function = "1"b;
				/* just in case */
	    ref_arg_list.number = P_reference.n_arguments;
	    do i = 1 to P_reference.n_arguments;
	      ref_arg_list.node (i) = sub_refs.ptr (1, i);
	    end;
	  end;
	else if P_reference.invocation_level < 0
	  then P_reference.precision = P_reference.invocation_level;
	P_reference.type = ext_procedure_runtime_dtype;
				/* external procedure */
	P_reference.descriptor = ext_procedure_runtime_dtype * 2;
	if ^want_external_sw
	  then /* want a value of a function, not an entry ref for call */
	       call probe_invoke_$function (probe_info_ptr, P_reference,
		  P_reference, P_code);
	return;
        end;

    end;				/* symbol not declared */


  /* fall through - hopeless symbol */

NOT_FOUND:
  code = steps;			/* need a fixed bi (35) */
  call probe_cv_stu_code_ (code);
  call probe_error_$record (probe_info_ptr, code, P_reference.name);
  goto RECORDED_MESSAGE;


BAD_CROSS_SECTION:			/* general exit for bad cross sections */
  code = probe_et_$bad_section;
  goto SOME_ERROR;


RECORDED_MESSAGE:			/* general exit when we have recorded a message */
  code = probe_et_$recorded_message;
  goto SOME_ERROR;

SOME_ERROR:			/* general error exit */
  P_code = code;
  return;				/* end of main code for probe_eval_ */

do_subscripts:
  proc;

  do j = 1 to 1 + fixed (P_reference.cross_section, 1, 0);
    do i = 1 to dimensions;
      sub = sub_refs.ptr (j, i);
				/* presumably top of _n:_m */
      if sub = null
        then
	   ref_subscripts.value (j, i) = ref_subscripts.value (1, i);
				/* convert to fixed bin(24) */
        else do;
	if sub -> subscript.cross_section
	  then
	       goto BAD_CROSS_SECTION;
	if sub -> subscript.star_extent
	  then
	       ref_subscripts.value (j, i) = real_bounds (j, i);
	  else do;
	    ref_subscripts (j, i).value = convert_subscript (sub);
	    if ref_subscripts.value (j, i) < real_bounds (1, i) |
	         ref_subscripts.value (j, i) > real_bounds (2, i)
	      then
		 call ioa_$ioa_switch (probe_info.output_switch,
		      "subscript ^d outside range (^d:^d)",
		      i,
		      real_bounds (1, i),
		      real_bounds (2, i));
	  end;
        end;
    end;
  end;

  end do_subscripts;

convert_subscript:
  proc (refp) returns (fixed bin (24));

  /* given a pointer to a reference_node that is to be used in a subscript, convert its
   value to fixed bin (24), suitable for addressing the array --- or die trying */

  dcl refp		ptr parameter;

  dcl subv		fixed bin (24);
  dcl 1 subref		aligned like reference_node based (refp);

  dcl 1 eprec		aligned like encoded_precision;
  dcl (
      1 tar_str,
      1 src_str
      )			aligned like computational_data;

  dcl assign_$computational_	entry (ptr, ptr, fixed bin (35));

  dcl unspec		builtin;

  dcl code		fixed bin (35);


  tar_str.address = addr (subv);
  tar_str.data_type = real_fix_bin_1_dtype;
  tar_str.flags = "0"b;
  tar_str.prec_or_length = 24;
  tar_str.scale = 0;

  unspec (eprec) = unspec (subref.precision);

  src_str.address = subref.address_ptr;
  src_str.data_type = subref.type;
  src_str.flags = "0"b;
  src_str.flags.packed = subref.flags.packed;
  src_str.prec_or_length = eprec.prec;
  src_str.scale = eprec.scale;

  call assign_$computational_ (addr (tar_str), addr (src_str), code);

  if code ^= 0 then do;
      call probe_error_$record (probe_info_ptr, probe_et_$bad_subscript,
	 subref.name);
      goto RECORDED_MESSAGE;
    end;
  return (subv);

  end convert_subscript;

decode:
  proc (value, encoded) returns (fixed bin (35));

  dcl value		fixed bin (35);
  dcl encoded		bit (1);

  dcl stu_$decode_runtime_value_extended
			entry (fixed bin (35), ptr, ptr, ptr, ptr, ptr,
			ptr, fixed bin (35)) returns (fixed bin (35));
  dcl result		fixed bin (35);
  dcl stu_$decode_runtime_value
			entry (fixed bin (35), ptr, ptr, ptr, ptr, ptr,
			fixed bin (35)) returns (fixed bin (35));

  if ^encoded
    then
         return (value);

  if data_type_info_$info (P_reference.type).computational
    then
         result =
	    stu_$decode_runtime_value (P_reference.symbol_ptr
	    -> runtime_symbol.size, ref_source_info.block_ptr,
	    ref_source_info.stack_ptr,
	    (ref_source_info.seg_info_ptr -> seg_info.linkage_ptr),
	    P_reference.base_addr, P_reference.symbol_ptr, code);
    else /* PASCAL extended encoded  */
         result =
	    stu_$decode_runtime_value_extended (P_reference.precision,
	    ref_source_info.block_ptr,
	    ref_source_info.stack_ptr,
	    (ref_source_info.seg_info_ptr -> seg_info.linkage_ptr),
	    ref_source_info.block_ptr, P_reference.base_addr,
	    P_reference.symbol_ptr, code);

  if code ^= 0
    then go to SOME_ERROR;
  return (result);
  end decode;

qualifier_name:
  proc (P_ptr) returns (char (256) varying);

  dcl (P_ptr, p)		ptr;
  dcl name		char (256) varying;

  /* Note that we don't call here runtime_symbol_info_ : there are no based variables in PASCAL */

  p = addrel (P_ptr, P_ptr -> runtime_symbol.location);
  name = addrel (p, p -> runtime_symbol.name) -> acc.string;
  do while (fixed (p -> runtime_symbol.level, 6) > 1);
				/* print fathers */
    p = addrel (p, p -> runtime_symbol.father);
    name = addrel (p, p -> runtime_symbol.name) -> acc.string || "." || name;
  end;
  return (name);

  end qualifier_name;


  /*	INCLUDE FILES	*/

%include probe_lang_types;
%include probe_info;

  /* ;;;;;;; */

%include computational_data;

  /* ;;;;;;; */

%include probe_references;

  /* ;;;;;;; */

%include probe_source_info;

  /* ;;;;;;; */

%include probe_tokens;

  /* ;;;;;;; */

%include runtime_symbol;

  /* ;;;;;;; */


%include acc;

  /* ;;;;;;; */


%include encoded_precision;

  /* ;;;;;;; */

%include std_descriptor_types;

  /* ;;;;;;; */

%include stu_frame;

%include probe_seg_info;

%include data_type_info_;

%include runtime_symbol_info_;
  end;				/* probe_evaluate_ external procedure */





		    probe_expr_requests_.pl1        11/11/88  1554.4r w 11/11/88  1545.0      189171



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



/****^  HISTORY COMMENTS:
  1) change(88-05-18,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added the call to 'probe_print_c_attr_' in the symbol_request entry.
  2) change(88-05-27,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added code that allows for C indirection on the lefthand side of the
     assignment statement of the 'let_request'.
  3) change(88-06-10,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Changed 'boolean_expr' (called from the 'if_request' entry) to verify
     the conditional C operators == and != are used instead of the PL/1
     conditional operator = and ^=.
  4) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

probe_expr_requests_:
  proc ();


  call probe_error_$malfunction ();	/* dummy entry */

  call reject_next_argument ();	/* just so it's referenced */


  /*   Implements the following requests:

	call
	if
	let
	symbol
	value
	while
*/
  /*
   Modified 3 Sept 79 JRD
   Modified 20 Feb 80 JRD probe variables in symbol request */
  /* Added algol68 typing to 'symbol' request 09/23/82 S. Herbst */
  /* Modified June 83 JMAthane to add PASCAL typing to 'symbol' request */
  /* Changed "let" to allow := in place of = in Pascal mode 07/27/83 S. Herbst */
  /* Changed to call display_data_$for_probe instead of obsolete probe_print_value_ 08/02/83 Olin Sibert */
  /* Fixed "if" to parse line only if conditional is true 08/22/83 S. Herbst */
  /* Changed if request to allow "if BOOLEAN:" syntax 04/05/84 S. Herbst */


  dcl P_probe_info_ptr	pointer parameter;

  dcl code		fixed bin (35);

  dcl based_str_ptr		pointer;
  dcl based_str_lth		fixed bin (21);
  dcl based_str		char (based_str_lth) based (based_str_ptr);

  dcl (ref_1_ptr, ref_2_ptr)	pointer;
  dcl 1 ref_1		aligned like reference_node based (ref_1_ptr);
				/* temporary reference nodes */
  dcl 1 ref_2		aligned like reference_node based (ref_2_ptr);

  dcl 1 type_info		like runtime_type_info;

  dcl (
      probe_et_$bad_constant,
      probe_et_$recorded_message,
      probe_et_$bad_predicate,
      probe_et_$noarg,
      probe_et_$syntax_error,
      probe_et_$misused_equal,
      probe_et_$misused_not_equal,
      probe_et_$too_many_args
      )			fixed bin (35) external static;

  dcl display_data_$for_probe entry (ptr, 1 aligned like reference_node,
			fixed bin (35));
  dcl probe_assign_value_	entry (ptr, 1 aligned like reference_node,
			1 aligned like reference_node, fixed bin (35));
  dcl probe_compare_reference_
			entry (ptr, bit (18) aligned,
			1 aligned like reference_node,
			1 aligned like reference_node, fixed bin (35))
			returns (bit (1) aligned);
  dcl probe_create_reference_ entry (ptr, ptr);
  dcl probe_error_		entry options (variable);
  dcl probe_error_$malfunction
			entry options (variable);
  dcl probe_get_$expression	entry (ptr, 1 aligned like reference_node,
			fixed bin (35));
  dcl probe_get_$reference	entry (ptr, 1 aligned like reference_node,
			fixed bin (35));
  dcl probe_get_$request_list entry (ptr, ptr, fixed bin (21), fixed bin (35))
			;
  dcl probe_get_$value	entry (ptr, 1 aligned like reference_node,
			bit (36) aligned, fixed bin (35));
  dcl probe_invoke_$subroutine
			entry (ptr, 1 aligned like reference_node,
			fixed bin (35));
  dcl probe_listen_$check_line
			entry (ptr, ptr, fixed bin (21), fixed bin (35))
			;
  dcl probe_listen_$interpret_line
			entry (ptr, ptr, fixed bin (21), fixed bin (35))
			;
  dcl probe_print_pascal_$attr
			entry (ptr, ptr, bit (1) aligned,
			fixed bin (35));
  dcl probe_print_algol68_attr_
			entry (ptr, ptr, bit (1) aligned,
			fixed bin (35));
  dcl probe_print_pl1_attr_	entry (ptr, ptr, bit (1) aligned,
			fixed bin (35));
  dcl probe_print_c_attr_	entry (ptr, ptr, bit (1) aligned,
			fixed bin (35));
  dcl probe_print_cobol_attr_ entry (ptr, ptr, bit (1) aligned,
			fixed bin (35));
  dcl probe_print_fortran_attr_
			entry (ptr, ptr, bit (1) aligned,
			fixed bin (35));
  dcl probe_variable_mgr_$find_variable
			entry (ptr, ptr, fixed bin (35));
  dcl probe_variable_mgr_$list_var_ptr
			entry (ptr, ptr unal, fixed bin (35));
  dcl stu_$find_runtime_symbol
			entry (ptr, char (*), ptr, fixed bin)
			returns (ptr);
  dcl stu_$get_runtime_address
			entry (ptr, ptr, ptr, ptr, ptr, ptr, ptr)
			returns (ptr);

  dcl (addr, addrel, fixed, null)
			builtin;
%page;
RECORDED_MESSAGE:
  code = probe_et_$recorded_message;
  go to SOME_ERROR;


SYNTAX_ERROR:			/* general-purpose error exit */
  call probe_error_ (probe_info_ptr, probe_et_$syntax_error);
  go to MAIN_RETURN;


SOME_ERROR:			/* general for error code type errors */
  call probe_error_ (probe_info_ptr, code);
				/* never returns */
  go to MAIN_RETURN;		/* just in case */


MAIN_RETURN:
  return;				/* only such exit from this procedure */


value_request:
  entry (P_probe_info_ptr);

  /* *	Prints the value of a variable or expression */

  call setup (1);

  call require_argument ();

  call probe_get_$expression (probe_info_ptr, ref_1, code);
  if code ^= 0
    then go to SOME_ERROR;

  if probe_info.ct -> token.type = NAME_TYPE then do;
      if current_identifier_name = "data"
	 & probe_info.language_type = C_lang_type
        then
	   code = 1;
      probe_info.ct = probe_info.ct -> token.next;
    end;

  call reject_argument ();		/* nothing after this */

  if probe_info.flags.execute then do;
      call display_data_$for_probe (probe_info_ptr, ref_1, code);
      if code ^= 0
        then go to SOME_ERROR;
    end;

  go to MAIN_RETURN;		/* end of code for $value_request entry */
%page;
let_request:
  entry (P_probe_info_ptr);

  dcl c_indirect_count	fixed bin;
  dcl not_done_indirection	bit (1);
  dcl ptr_overlay		based ptr;

  /* *	Assigns a new value to a variable */

  code = 0;

  call setup (2);

  c_indirect_count = 0;
  not_done_indirection = "1"b;

  do while (not_done_indirection);
    if probe_info.ct -> token.type < probe_info.token_info.end_token
         & probe_info.ct -> token.type = C_INDIRECTION then do;
        c_indirect_count = c_indirect_count + 1;
        probe_info.ct = probe_info.ct -> token.next;
      end;
      else not_done_indirection = "0"b;
  end;

  call require_argument ();

  call probe_get_$value (probe_info_ptr, ref_1, "000000000000"b3, code);

  if code ^= 0
    then go to SOME_ERROR;

  if (ref_1.symbol_ptr ^= null ()) then do;
      if (fixed (ref_1.symbol_ptr -> runtime_symbol.type) = c_typeref_dtype)
        then do;
	do while (fixed (ref_1.symbol_ptr -> runtime_symbol.type)
	     = c_typeref_dtype);
	  ref_1.symbol_ptr =
	       addrel (ref_1.symbol_ptr,
	       fixed (ref_1.symbol_ptr -> runtime_symbol.son, 17));
	end;
	if (fixed (ref_1.symbol_ptr -> runtime_symbol.type) = c_enum_dtype)
	  then do;
	    ref_1.type = real_fix_bin_1_dtype;
	    ref_1.precision = 35;
	  end;
	  else do;
	    ref_1.type =
	         fixed (ref_1.symbol_ptr -> runtime_symbol.type, 35);
	    ref_1.precision =
	         fixed (ref_1.symbol_ptr -> runtime_symbol.size, 35);
	    ref_1.flags.packed =
	         ref_1.symbol_ptr -> runtime_symbol.bits.packed;
	  end;
        end;
    end;

  do while (c_indirect_count > 0);
    c_indirect_count = c_indirect_count - 1;
    if ref_1.symbol_ptr -> runtime_symbol.son ^= "0"b then do;
        ref_1.symbol_ptr =
	   addrel (ref_1.symbol_ptr,
	   fixed (ref_1.symbol_ptr -> runtime_symbol.son));
        ref_1.type = fixed (ref_1.symbol_ptr -> runtime_symbol.type);
        ref_1.address_ptr = ref_1.address_ptr -> ptr_overlay;
        ref_1.precision = ref_1.symbol_ptr -> runtime_symbol.size;
      end;
  end;

  if probe_info.ct -> operator.type ^= EQUALS &
       (probe_info.language_type ^= PASCAL_lang_type
       | probe_info.ct -> operator.type ^= PASCAL_ASSIGN)
    then
         call probe_error_ (probe_info_ptr, probe_et_$syntax_error,
	    "Usage: let <value> = <expression>");

  call bump_ct ();			/* get the next token */
  call require_argument ();

  call probe_get_$expression (probe_info_ptr, ref_2, code);
				/* get value for assignment */
  if code ^= 0
    then go to SOME_ERROR;

  call reject_argument ();		/* nothing after this */

  if probe_info.flags.execute then do;	/* do it! */
      call probe_assign_value_ (probe_info_ptr, ref_1, ref_2, code);
      if code ^= 0
        then go to SOME_ERROR;	/* print the message */
    end;

  go to MAIN_RETURN;		/* end of code for $let_request entry */
%page;
symbol_request:
  entry (P_probe_info_ptr);

  /* *	Prints information about a symbol */

  dcl sb_long_sw		bit (1) aligned;

  call setup (1);

  call require_argument ();
  call probe_get_$reference (probe_info_ptr, ref_1, code);
  if code ^= 0
    then go to SOME_ERROR;

  if ref_1.flags.constant & ref_1.type ^= ext_procedure_runtime_dtype then do;
      code = probe_et_$bad_constant;
      go to SOME_ERROR;
    end;

  if probe_info.ct -> token.type >= probe_info.end_token
    then
         sb_long_sw = "0"b;		/* clearly, no options specified */

    else do;			/* otherwise, check for options */
      if probe_info.ct -> token.type ^= NAME_TYPE
        then go to SYNTAX_ERROR;

      based_str_ptr = probe_info.ct -> identifier.name;
      based_str_lth = probe_info.ct -> identifier.length;

      if based_str = "long" | based_str = "lg"
        then
	   sb_long_sw = "1"b;
      else if based_str = "brief" | based_str = "bf"
        then
	   sb_long_sw = "0"b;
      else go to SYNTAX_ERROR;	/* Unrecognized option */

      call bump_ct ();		/* get the next token */
      call reject_argument ();	/* not at end yet? */
    end;				/* of checking for options */

  if probe_info.flags.execute
    then if ref_1.flags.probe_variable
	 then do;
	   call probe_variable_mgr_$list_var_ptr (probe_info_ptr,
	        ref_1.probe_var_info_ptr, code);
	   if code ^= 0
	     then go to SOME_ERROR;
	 end;
	 else do;
	   if probe_info.language_type = FORTRAN_lang_type
	     then call probe_print_fortran_attr_ (probe_info_ptr,
		     addr (ref_1), sb_long_sw, (0));
	   else if probe_info.language_type = COBOL_lang_type
	     then call probe_print_cobol_attr_ (probe_info_ptr,
		     addr (ref_1), sb_long_sw, (0));

	   else if probe_info.language_type = PASCAL_lang_type
	     then call probe_print_pascal_$attr (probe_info_ptr,
		     addr (ref_1), sb_long_sw, (0));
	   else if probe_info.language_type = ALGOL68_lang_type
	     then call probe_print_algol68_attr_ (probe_info_ptr,
		     addr (ref_1), sb_long_sw, (0));
	   else if probe_info.language_type = PL1_lang_type
	     then call probe_print_pl1_attr_ (probe_info_ptr, addr (ref_1),
		     sb_long_sw, (0));
	   else call probe_print_c_attr_ (probe_info_ptr, addr (ref_1),
		   sb_long_sw, (0));
	 end;			/* program vars */

  go to MAIN_RETURN;
%page;
call_request:
  entry (P_probe_info_ptr);

  /* *	This fellow calls an external procedure. Sorry, no internal procedure calls
   *	yet, though our experts are working around the clock to bring them to you */

  call setup (1);			/* need one reference node this time */

  call require_argument ();		/* must specify something to call, natch */

  call probe_get_$value (probe_info_ptr, ref_1, "110"b, code);
				/* get the thing to call */
  if code ^= 0
    then go to SOME_ERROR;

  call reject_argument ();		/* can't have anything folowing the argument list */

  if probe_info.execute then do;	/* do it */
      call probe_invoke_$subroutine (probe_info_ptr, ref_1, code);
      if code ^= 0
        then go to SOME_ERROR;
    end;

  go to MAIN_RETURN;		/* end of code for the call request */
%page;
while_request:
  entry (P_probe_info_ptr);

  /* *	The while request executes a set of probe requests for as long as the specified condition is true */


  dcl conditional_expr_ptr	ptr;	/* to the start of conditional expr tokens */
  dcl after_ptr		ptr;	/* to restore ct */


  dcl comparison_result	bit (1) aligned;
  dcl requests_ptr		pointer;
  dcl requests_lth		fixed bin (21);


  call setup (2);
  call require_argument ();

  conditional_expr_ptr = probe_info.ct;

  comparison_result = boolean_expr (conditional_expr_ptr);
  if comparison_result & probe_info.execute then do;

      call common_conditional_munch ();

      after_ptr = probe_info.ct;
      do while (comparison_result);
        call probe_listen_$interpret_line (probe_info_ptr, requests_ptr,
	   requests_lth, code);
        if code ^= 0
	then go to SOME_ERROR;
        comparison_result = boolean_expr (conditional_expr_ptr);
      end;
      probe_info.ct = after_ptr;
      if code ^= 0
        then go to SOME_ERROR;
    end;
    else call skip_line ();

  go to MAIN_RETURN;


if_request:
  entry (P_probe_info_ptr);

  /* The if request executes a set of probe requests once, if the   specified condition is true */


  call setup (2);

  call require_argument ();		/* can't just say 'while' */

  comparison_result = boolean_expr ((probe_info.ct));

  call common_conditional_munch ();

  if comparison_result & probe_info.execute then do;

      call probe_listen_$interpret_line (probe_info_ptr, requests_ptr,
	 requests_lth, code);
      if code ^= 0
        then go to SOME_ERROR;
    end;
  else if probe_info.setting_break then do;
      call probe_listen_$check_line (probe_info_ptr, requests_ptr,
	 requests_lth, code);
      if code ^= 0
        then go to SOME_ERROR;
    end;
  else call skip_line ();

  go to MAIN_RETURN;
%page;
boolean_expr:
  proc (exp_begin) returns (bit (1) aligned);


  dcl exp_begin		ptr parameter;

  dcl operation		bit (18) aligned;
  dcl result		bit (1) aligned;

  dcl b1al		bit (1) aligned based;
  dcl b1unal		bit (1) unaligned based;

  /* must set up probe_info.ct for sake of probe_get_$expression */


  probe_info.ct = exp_begin;
  call require_argument ();
  call probe_get_$expression (probe_info_ptr, ref_1, code);
  if code ^= 0
    then go to ERR_IN_BOOLEAN_EXPR;

  operation = probe_info.ct -> operator.type;
  if probe_info.language_type = C_lang_type then do;
      if operation = EQUALS
        then
	   call probe_error_ (probe_info_ptr, probe_et_$misused_equal);
      else if operation = C_EQUAL
        then
	   operation = EQUALS;
      else if operation = NOT_EQUALS
        then
	   call probe_error_ (probe_info_ptr, probe_et_$misused_not_equal);
      else if operation = C_NOT_EQUAL
        then
	   operation = NOT_EQUALS;
    end;
  if operation < LESS_THAN | operation > NOT_LESS_THAN
    then
         if operation ^= COLON
	 then
BAD_PRED:
	   call probe_error_ (probe_info_ptr, probe_et_$bad_predicate);
	 else do;			/* might be "if BOOLEAN: " */
	   if ^probe_info.execute then do;
				/* don't have type yet */
	       call probe_variable_mgr_$find_variable (probe_info_ptr,
		  addr (ref_1), code);
	       if code ^= 0 then do;	/* not a probe variable */
		 ref_1.symbol_ptr = stu_$find_runtime_symbol
		      (probe_info.ptr_to_current_source
		      -> source_info.block_ptr,
		      (ref_1.name), null, 0);
		 if ref_1.symbol_ptr = null
		   then go to BAD_PRED;
				/* no such variable */

		 type_info.version = RUNTIME_TYPE_INFO_VERSION_1;
		 call runtime_symbol_info_$type (ref_1.symbol_ptr,
		      addr (type_info), code);
		 if code ^= 0
		   then go to BAD_PRED;
		 ref_1.type = type_info.type;
	         end;
	     end;

	   if ref_1.type = bit_dtype then do;
	       if probe_info.execute
	         then
		    if ref_1.packed
		      then return ((ref_1.address_ptr -> b1unal));
		      else return ((ref_1.address_ptr -> b1al));
	         else return ("0"b);
	     end;
	     else go to BAD_PRED;
	 end;

  call bump_ct ();			/* skip over the relational operator */
  call require_argument ();
  call probe_get_$expression (probe_info_ptr, ref_2, code);
  if code ^= 0
    then go to ERR_IN_BOOLEAN_EXPR;

  if probe_info.execute
    then result =
	    probe_compare_reference_ (probe_info_ptr, operation, ref_1,
	    ref_2, code);
    else result = "0"b;
  if code ^= 0
    then go to ERR_IN_BOOLEAN_EXPR;
  return (result);
ERR_IN_BOOLEAN_EXPR:
  go to SOME_ERROR;
  end boolean_expr;
%page;
common_conditional_munch:
  proc;


  if probe_info.ct -> operator.type ^= COLON
    then /* must have a colon here, but print a sensible message */
         call probe_error_ (probe_info_ptr, 0,
	    "The relational expression and the requests to be executed must be separated by a colon."
	    );

  call bump_ct ();			/* skip over the colon */

  call require_argument ();

  call probe_get_$request_list (probe_info_ptr, requests_ptr, requests_lth,
       code);
  if code ^= 0
    then
         go to SOME_ERROR;

  call reject_argument ();		/* nothing may follow the request line */


  end common_conditional_munch;
%page;
setup:
  proc (P_n_references);

  /* *	This procedure sets up the request variables, and initializes as many
   *	reference nodes and associated data as the request has requested */

  dcl P_n_references	fixed bin;


  probe_info_ptr = P_probe_info_ptr;	/* copy the global parameter */

  if P_n_references > 0
    then /* initialize a reference node */
         call probe_create_reference_ (probe_info_ptr, ref_1_ptr);

  if P_n_references > 1
    then /* initialize another one */
         call probe_create_reference_ (probe_info_ptr, ref_2_ptr);

  if P_n_references > 2
    then /* but this is too much */
         call probe_error_$malfunction (probe_info_ptr, 0,
	    "Too many reference nodes requested: ^d", P_n_references);

  return;

  end setup;
%page;
reject_argument:
  proc ();

  /* *	This procedure simply calls probe_error_ if the current token is not the
   *	end of the token chain -- it is called by requests which have processed all
   *	expected arguments and want to barf if there are any extras */

  if probe_info.ct -> token.type < probe_info.end_token
    then
         call probe_error_ (probe_info_ptr, probe_et_$too_many_args);
  return;

  end reject_argument;


reject_next_argument:
  proc ();


  /* *	This is just like reject_argument, except that it tests whether there are any
   *	argument tokens AFTER the current one, rather than starting with the current one */

  if probe_info.ct -> token.next = null ()
    then
         call probe_error_ (probe_info_ptr, probe_et_$too_many_args);

  if probe_info.ct -> token.next -> token.type < probe_info.end_token
    then
         call probe_error_ (probe_info_ptr, probe_et_$too_many_args);
  return;

  end reject_next_argument;


require_argument:
  proc ();


  /* *	This is just like reject_argument, except that it barfs if there are not
   *	any more arguments */

  if probe_info.ct -> token.type >= probe_info.end_token
    then
         call probe_error_ (probe_info_ptr, probe_et_$noarg);
  return;

  end require_argument;
%page;
skip_line:
  proc;

  dcl prev_ct		ptr init (null);


  do probe_info.ct = probe_info.ct repeat (probe_info.ct -> token.next)
       while (probe_info.ct ^= null);
    prev_ct = probe_info.ct;
    if probe_info.ct -> token.type = end_token
      then go to SKIP_RETURN;
  end;
SKIP_RETURN:
  probe_info.ct = prev_ct;
  return;

  end skip_line;

bump_ct:
  proc ();

  /* *	This procedure makes probe_info.ct point at the next token. */

  probe_info.ct = probe_info.ct -> token.next;

  if probe_info.ct = null ()
    then go to SYNTAX_ERROR;		/* some protection against mistakes */

  return;

  end bump_ct;
%page;
%include probe_info;
%page;
%include probe_break_slot;
%page;
%include probe_info_constants;
%page;
%include probe_lang_types;
%page;
%include probe_operators;
%page;
%include probe_references;
%page;
%include probe_seg_info;
%page;
%include probe_source_info;
%page;
%include probe_tokens;
%page;
%include runtime_symbol;
%page;
%include runtime_symbol_info_;
%page;
%include statement_map;
%page;
%include std_descriptor_types;


  end probe_expr_requests_;




		    probe_fault_handler_.pl1        10/27/88  1244.0r w 10/27/88  1224.9       38277



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



/****^  HISTORY COMMENTS:
  1) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

probe_fault_handler_:
  proc (P_probe_info_ptr);

  /* *	This procedure is invoked when it appears that there was a fault caused by an
   *	invalid pointer. It decides whether the condition probably was caused by a bad
   *	pointer, calling probe_error_ if so, or continuing to signal if not.
   *
   *	Written by Olin Sibert
   *	Modified 10/09/79 by JRDavis to say where fault happened. */
  /* Added null_pointer to list of handled conditions 01/15/85 Steve Herbst */
  /* Changed to quit probe after handling if condition occurred during quit request 01/15/85 Steve Herbst */


  dcl P_probe_info_ptr	pointer parameter;

  dcl idx			fixed bin;
  dcl code		fixed bin (35);

  dcl 1 cond_info		aligned like condition_info automatic;

  dcl storage_condition_count fixed bin internal static init (0);
				/* to limit the number of these */

  dcl com_err_		entry options (variable);
  dcl cu_$cl		entry (bit (1) aligned);
  dcl continue_to_signal_	entry (fixed bin (35));
  dcl find_condition_info_	entry (ptr, ptr, fixed bin (35));
  dcl probe_error_		entry options (variable);

  dcl POINTER_FAULTS	(13) char (32) internal static
			options (constant) init
			("fault_tag_1",
			"fault_tag_3",
			"no_read_permission",
			"no_write_permission",
			"not_in_read_bracket",
			"not_in_write_bracket",
			"null_pointer",
			"out_of_bounds",
			"seg_fault_error",
			"storage",
			"packed_pointer_fault",
			"lot_fault",
			"isot_fault");
  dcl STORAGE_CONDITION	char (32) internal static
			options (constant) init ("storage");

  dcl (addr, hbound, null)
			builtin;
%page;
  probe_info_ptr = P_probe_info_ptr;

  call find_condition_info_ (null, addr (cond_info), code);
  if code ^= 0 then do;
      call probe_error_ (probe_info_ptr, code, "In pointer error handler.");
      return;
    end;

  if ^probe_static_info.no_handle_faults_sw
    then
      do idx = 1 to hbound (POINTER_FAULTS, 1);
      if cond_info.condition_name = POINTER_FAULTS (idx) then do;
				/* One of ours */
	if cond_info.condition_name = STORAGE_CONDITION
	  then /* special handling */
	       storage_condition_count = storage_condition_count + 1;
	if storage_condition_count > 2 then do;
				/* warn the user */
	    call com_err_ (0, probe_static_info.name,
	         "Storage condition occurred. Shorten stack and restart.");
	    call cu_$cl ("0"b);
	    storage_condition_count = 0;
	  end;
	  else do;
	    call probe_error_ (probe_info_ptr, 0,
	         "Condition ""^a"" occurred ^[in lower ring^] at ^p. Possible invalid pointer.",
	         cond_info.condition_name,
	         cond_info.flags.crawlout,
	         cond_info.user_loc_ptr);
	  end;
	if probe_info.executing_quit_request
	  then go to probe_info.abort_probe_label;
	  else return;
        end;
    end;				/* of loop checking fault names */

continue_to_signal:
  call continue_to_signal_ ((0));	/* not one of ours, see who else wants it */
  return;
%page;
%include probe_info;
%page;
%include probe_static_info;
%page;
%include condition_info;


  end probe_fault_handler_;




		    probe_find_location_.pl1        10/27/88  1244.0r w 10/27/88  1224.9      133929



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



/****^  HISTORY COMMENTS:
  1) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

probe_find_location_:
  procedure
       (P_probe_info_ptr, P_seg_info_ptr, P_file_number, P_line,
       P_statement_number, P_switches, P_map_element, P_index);

  /* This routine is used to search the statement map for a line designated by file, line, and
   stmt offset. If not found and dont_guess_sw (in P_switches) is OFF, it tries to make a guess.

   Initial Version:  15 August 1974 by Jeffrey M. Broughton
   Converted to probe 4.0, 05/18/79 W. Olin Sibert */
  /* Changed to respect position 4 of P_switches, dont_guess_sw */
  /* Changed to see it's in the middle of a statement 10/29/81 S. Herbst */
  /* Fixed to recognize when it unexpectedly re-enters part of program before desired line 10/25/82 S. Herbst */
  /* Fixed high guess to be last line of programn, not last stmt in map 02/10/84 S. Herbst */

  dcl (
      P_probe_info_ptr	pointer,
      P_seg_info_ptr	pointer,	/* to info about contianing program */
      P_file_number		fixed bin,/* file number of desired statement */
      P_line		fixed bin,/* and line number */
      P_statement_number,		/* and statement offset in line */
      P_switches		bit (36) aligned,
      P_map_element		pointer,	/* to map entry best fitting the above */
      P_index		fixed bin
      )			parameter;/* index of this entry */

  dcl switches		bit (36) unaligned;
  dcl want_external_sw	bit (1) unaligned defined (switches) pos (1);
  dcl default_external_sw	bit (1) unaligned defined (switches) pos (2);
  dcl default_offset_zero_sw	bit (1) unaligned defined (switches) pos (3);
  dcl dont_guess_sw		bit (1) unaligned defined (switches) pos (4);

  dcl file_entry		bit (72) aligned;
				/* file number, in statement map format */
  dcl statement_entry	bit (72) aligned;
				/* file, line, and statement numbers */

  dcl state		fixed bin;/* current state of scan for statement */
  dcl checked_sw		bit (1) aligned;
				/* ON if checked_multi_line has been called */

  dcl this_statement	bit (72) aligned;
				/* file, line, stmt. offset of current stmt. */
  dcl last_statement	bit (72) aligned;
				/* ditto, of last stmt. in _s_a_m_e file */
  dcl end_statement		bit (72) aligned;
				/* of statement expected to end proc */
  dcl low_guess		bit (72) aligned;
				/* of last stmt. before one wanted */
  dcl high_guess		bit (72) aligned;
				/* of next statement found above */
  dcl guess_statement	bit (72) aligned;
				/* to check guess before returning it */

  dcl i			fixed bin;/* index in map of current stmt. being scanned */
  dcl highest_line		fixed bin;/* highest line number of any stmt so far */
  dcl highest_line_index	fixed bin;/* statement index corresponding to this line */
  dcl this_line		fixed bin;/*  line number of current statement */

  dcl last		fixed bin;/* of last stmt. in same file */
  dcl proc_end_stmt		fixed bin;/* of stmt. expected to end procedure */
  dcl low			fixed bin;/* of one for low_guess */
  dcl high		fixed bin;/* of one for high_guess */

  dcl map_size		fixed bin;/* size of this array */
  dcl map_ptr		pointer;
  dcl 1 map_array		(map_size) aligned like statement_map
			based (map_ptr);
				/* overlay for entire statement map */

  dcl 1 result_source_info	aligned like source_info;

  dcl probe_line_number_$proc entry (ptr, 1 aligned like source_info)
			returns (char (64));
  dcl probe_source_segment_$get_file_ptr
			entry (ptr, ptr, fixed bin) returns (ptr);
  dcl probe_error_$warning	entry options (variable);

  dcl probe_et_$stmt_guess	fixed bin (35) external static;

  dcl file_mask		bit (72) aligned internal static
			options (constant)
			initial ("000000776000000000000000"b3);
				/* masks out file number of statement map */
  dcl statement_mask	bit (72) aligned internal static
			options (constant)
			initial ("000000777777777000000000"b3);
				/* mask out file, line, and statement numbers */

  dcl (addr, bit, fixed, null, string, substr)
			builtin;
				/*  */

  /* Check that we have something to work with */

  probe_info_ptr = P_probe_info_ptr;
  switches = P_switches;
  map_ptr = P_seg_info_ptr -> seg_info.statement_map_ptr;

  if map_ptr = null
    then goto fail;			/* if non-null will assume that we have other info too */

  /* Get size of statement map for this program */

  map_size = P_seg_info_ptr -> seg_info.map_size;
				/* get maximum index */

  /* Make source id for statement desired. purpose is fast comparision */

  file_entry = (18)"0"b || bit (fixed (P_file_number, 8, 0));
				/* put file number into desired format */
  statement_entry = file_entry | (26)"0"b || bit (fixed (P_line, 14, 0)) ||
       bit (fixed (P_statement_number, 5, 0));

  /* Handle boundary conditions for search */

  low_guess, last_statement = string (map_array (1)) & statement_mask;
				/* before every thing else in map */
  highest_line, highest_line_index, last, low = 1;
  high_guess, end_statement = statement_mask;
				/* greater than any element of map */
  state = 1;			/* initially scanning before statement */
  checked_sw = "0"b;		/* call check_multi_line once, after line number is passed */

  /* Search entire map for element, but keep track of topology for guess. */

  do i = 1 to map_size;
    if (string (map_array (i)) & file_mask) = file_entry then do;
				/* only look in same file as statement */

        this_line = fixed (map_array (i).line);
        if this_line > highest_line then do;
	  highest_line = this_line;
	  highest_line_index = i;
	end;

        this_statement = string (map_array (i)) & statement_mask;
				/* record source id of current statement */
        if this_statement = statement_entry then do;
				/* found it, no further work needed */
GOT_LINE:
	  P_index = i;		/* return info */
	  P_map_element = addr (map_array (i));
	  return;
	end;
        else if this_statement < last_statement
	then /* have entered relocated internal procedure */
	     goto before_last (state);
        else if this_statement > statement_entry
	then /* found one after one we want */
	     goto after (state);
        else if this_statement >= end_statement
	then /* have reached end of int proc being skipped */
	     goto end_proc (state);
        else do;
	if this_statement < statement_entry then do;
				/* must have re-entered part before desired stmt */
	    state = 1;		/* treat this like end of internal proc */
	    end_statement = statement_mask;
	  end;
	go to common;
        end;

        /* State 1: In a region of statements before one wanted.  Can be either main program, or
   internal procedure that we are assuming contains the statement. */

after (1):
        call check_multi_line ();

        /* Have been scanning region before, so we have found a gap, remember where
   it is and continue looking for an internal proc containing statement. */

        low = last;
        low_guess = last_statement;	/* remember one before stmt. */
        if this_statement < high_guess then do;
				/* and this one, if it is a better approx. */
	  high = i;
	  high_guess = this_statement;
	end;
        state = 3;			/* now scanning region after */
        goto common;

before_last (1):

        /* Have entered internal procedure before region before statement.  This implies
   that all of procedure is before statement, so skip it, but remeber where end
   caller was in case it is really the end. */

        proc_end_stmt = last;
        end_statement = last_statement; /* caller's last statement */
        state = 2;			/* skip state */
        goto common;

end_proc (1):

        /* Should not occur. Should be caught by after or finish case. */

        goto finish (1);		/* really don't care */

        /* State 2: Skipping an internal procedure before statement. */

after (2):

        /* Found one after the statement; this implies that we have reentered main code.
   The situation is:  | main1 | proc(s) | main2 | with a source ordering of
   proc(s) < main1 < stmt. < main2.  Take guess as in state 1. */

        low = proc_end_stmt;
        low_guess = end_statement;	/* stmt. before one wanted, last in caller */
        end_statement = statement_mask; /* reset */
        state = 3;			/* are in region after now */
        goto common;

before_last (2):

        /* Found another internal procedure before even where we are.  Just ignore it. */

        goto common;

end_proc (2):

        /* Have reached code beyond end of procedure, reenter main code sequence, and
   continue scan. */

        end_statement = statement_mask; /* reset */
        state = 1;
        goto common;

        /* State 3:  Scanning statements after the desired one;  looking for internal procedures
   this region that may contain the statement. */

after (3):

        /* Nothing new, just proceed */

        goto common;

before_last (3):

        /* Entering internal procedure before region being scanned.	Check if it may contain
   statement. */

        if this_statement > high_guess
	then /* proc. after statement */
	     goto common;		/* cannot contain statement */
        else if this_statement < low_guess
	then /* proc before gap where statement was to be */
	     goto common;

        /* This procedure is in the gap, we may assume that the statement is here (for instance,
   an end statement generating no code).  So continue scan for statement or another one
   after. */

        state = 1;			/* just like the start, expect to find one before */
        last = low;
        last_statement = low_guess;	/* last one before desired one anyway */
        i = i - 1;			/* reprocess, this may be after */
        goto next;			/* have set last ourselves */

end_proc (3):

        /* Should not happen. */

        goto finish (3);

        /* Common:  record the last statement for next time around */

common:
        last = i;
        last_statement = this_statement;
      end;

next:
  end;

  call check_multi_line ();

  /* All of map has been scanned.  The precise statement has not been found. So make a
   guess depending on how we got here. */

  if dont_guess_sw
    then go to fail;

  goto finish (state);

finish (1):

  /* We could get here if no file containing the statement was found,  If one was, then
   we were scanning a region before the desired statement, so we should pick the last
   statement in that region */

  if (last_statement & file_mask) ^= file_entry
    then goto fail;			/* either one found, in which case last in th
						   at file, or didn't, last in file 0 */

  guess_statement = string (map_array (last)) & statement_mask;
  if guess_statement > statement_entry
    then P_index = last;
				/* guess later in map is also later line in source */
    else P_index = highest_line_index;	/* else use last line in source */
  P_map_element = addr (map_array (highest_line_index));
				/* highest_line_index in region */
  goto make_guess;

finish (2):

  /* We were skipping an internal procedure before statement, so use end of caller */

  P_index = proc_end_stmt;
  P_map_element = addr (map_array (proc_end_stmt));
  goto make_guess;

finish (3):

  /* In region after statement, and we have made a guess.  Statement is probably non-
   executable (e.g. begin, do, end).  We have a greater interested in making a
   quick begin block entry, which users may specify by line number to get a block,
   work right, so guess one after recorded guess.  This is also compatable with
   debug */

  guess_statement = string (map_array (high)) & statement_mask;
  if guess_statement > statement_entry
    then P_index = high;
				/* guess later in map is also later line in source */
    else P_index = highest_line_index;	/* else use last line in source */
  P_map_element = addr (map_array (highest_line_index));
				/* want one following low guess */

make_guess:
  result_source_info.seg_info_ptr = P_seg_info_ptr;
  result_source_info.stmnt_map_entry_index = P_index;
  call probe_error_$warning (probe_info_ptr, probe_et_$stmt_guess,
       probe_line_number_$proc (probe_info_ptr, result_source_info));
  return;

fail:
  P_index = -1;
  P_map_element = null;		/* nothing found */
  return;
%page;
check_multi_line:
  proc;

  /* This procedure sees whether the previous statement spans more than one line,
   and whether it includes P_line. If so, the statement is found. */

  dcl (j, len, line_count, prev_line, start)
			fixed bin (21);
  dcl filep		ptr;
  dcl source_overlay	char (1044480 /* max chars in a segment */)
			based (filep);
  dcl NL			char (1) int static options (constant) init ("
");

  if checked_sw
    then
         return;			/* already called this; must be end of program */
  checked_sw = "1"b;

  if i = 1
    then
         return;			/* first line in program */

  prev_line = fixed (map_array (i - 1).line);
  start = fixed (map_array (i - 1).start);
  len = fixed (map_array (i - 1).length);

  if start = 0
    then
         return;

  /* Count number of lines in prev statement */

  filep =
       probe_source_segment_$get_file_ptr (probe_info_ptr,
       probe_info.ptr_to_current_source, P_file_number);
  if filep = null
    then
         return;			/* give up */

  line_count = 1;

  do j = start to start + len - 2;	/* don't look at the end char */
    if substr (source_overlay, j, 1) = NL
      then line_count = line_count + 1;
  end;

  if prev_line + line_count > P_line then do;
      i = i - 1;			/* the previous line is the right one */
      go to GOT_LINE;
    end;

  end check_multi_line;

  /*  */

%include probe_info;

  /* ;;;;;;; */

%include statement_map;

  /* ;;;;;;; */

%include probe_seg_info;

  /* ;;;;;;; */

%include probe_source_info;

  /* ;;;;;;; */

%include runtime_symbol;

  end;				/* probe_find_location_ external procedure */




		    probe_find_procedure_.pl1       10/27/88  1244.0rew 10/27/88  1222.0      110277



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


/****^  HISTORY COMMENTS:
  1) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
  2) change(88-10-21,WAAnderson), approve(88-10-21,MCR7952),
     audit(88-10-24,RWaters), install(88-10-27,MR12.2-1194):
     Modified code to implement a C feature. If the user specifes 'seg' instead
     of 'seg$main', probe will now assume the user wants 'seg$main' if no
     statement map is found for 'seg'.  This is not particularily elegant
     because it will try using the 'seg$main' convention for any object,
     regardless of the compiler used to generate the object.  There was a
     problem getting back the error code 'probe_et_$no_map' from
     'probe_seg_info_' when no statement map existed.  To make the
     necessary change to 'probe_seg_info_' , the probe_info.entry_method'
     was set to 1, to act as a flag. Other modules affected to implement
     this feature are 'probe_command_' and 'probe_seg_info_'. The include
     'probe_info.incl.pl1' was modified to include the new file
     'retry_using_main'.
                                                   END HISTORY COMMENTS */

/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

probe_find_procedure_:
  proc (P_probe_info_ptr, P_procedure_name, P_switches, P_sourcep, P_code);

  /* given a name, get a source_info for it */
  /* Changed to accept all kinds of virtual entries 09/11/81 S. Herbst */
  /* Changed to suppress foo|0 msg unless entry point specified, use component base if bound 09/21/81 S. Herbst */
  /* Changed refname warning to include the path that the refname DOES refer to 10/18/82 S. Herbst */
  /* Fixed bug that uses initiated copy despite pathname specified 05/02/84 S. Herbst */

  dcl P_probe_info_ptr	ptr parameter;
  dcl P_procedure_name	char (*) parameter;
				/* may be refname, abspathname or relpathname */
  dcl P_switches		bit (36) aligned parameter;
  dcl P_sourcep		ptr parameter;
  dcl P_code		fixed bin (35) parameter;

  dcl switches		bit (36);
  dcl want_external_sw	bit (1) unaligned defined (switches) pos (1);
  dcl default_external_sw	bit (1) unaligned defined (switches) pos (2);
  dcl default_offset_zero_sw	bit (1) unaligned defined (switches) pos (3);

  dcl (segp, unique_refname_ptr)
			ptr;
  dcl assume_ref		bit (1) aligned;
				/* did give explicit path or are we using ref name */
  dcl (actual_dn, dir_name)	char (168);
				/* name of containing dir */
  dcl pathname		char (210);
  dcl (actual_en, entry_name, refname, segname, unique_refname)
			char (32);
  dcl entry_point		char (32);
  dcl explicit_entry_sw	bit (1) aligned;
  dcl code		fixed bin (35);
  dcl offset		fixed bin (18) unsigned;
  dcl offset_string		char (32);
  dcl sourcep		ptr;	/* to source_ptr we'll build */
  dcl hp			ptr;	/* to symbol_header */

  dcl probe_seg_info_	entry (ptr, ptr, fixed bin (35)) returns (ptr);
  dcl probe_stack_trace_$find_proc_frame
			entry (ptr, ptr, ptr, fixed bin);
  dcl probe_error_$record	entry options (variable);
  dcl probe_error_$warning	entry options (variable);

  dcl component_info_$name	entry (ptr, char (32) aligned, ptr,
			fixed bin (35));
  dcl cv_oct_check_		entry (char (*), fixed bin (35))
			returns (fixed bin);
  dcl stu_$get_map_index	entry (ptr, fixed bin (18) unsigned, fixed bin,
			ptr);
  dcl stu_$find_containing_block
			entry (ptr, fixed bin (18) unsigned)
			returns (ptr);
  dcl expand_pathname_	entry (char (*), char (*), char (*),
			fixed bin (35));
  dcl hcs_$fs_get_path_name	entry (ptr, char (*), fixed bin, char (*),
			fixed bin (35));
  dcl hcs_$initiate		entry (char (*), char (*), char (*),
			fixed bin (1), fixed bin (2), ptr,
			fixed bin (35));
  dcl pathname_		entry (char (*), char (*)) returns (char (168));
  dcl hcs_$make_ptr		entry (ptr, char (*), char (*), ptr,
			fixed bin (35));
  dcl term_$single_refname	entry (char (*), fixed bin (35));
  dcl unique_chars_		entry (bit (*)) returns (char (15));

  dcl (
      probe_et_$recorded_message,
      probe_et_$no_map,
      error_table_$namedup,
      error_table_$no_ext_sym
      )			fixed bin (35) external static;

  dcl (addr, after, before, fixed, index, null, ptr, rel, search)
			builtin;
				/*  */

  probe_info_ptr = P_probe_info_ptr;
  sourcep = P_sourcep;
  switches = P_switches;

  offset_string = "";
  unique_refname_ptr = null;

  if search (P_procedure_name, "<>") ^= 0 then do;
				/* must be a path name */
      assume_ref = "0"b;
      if index (P_procedure_name, "$") ^= 0 then do;
	explicit_entry_sw = "1"b;
	pathname = before (P_procedure_name, "$");
	entry_point = after (P_procedure_name, "$");
        end;
      else if index (P_procedure_name, "|") ^= 0 then do;
	explicit_entry_sw = "1"b;
	pathname = before (P_procedure_name, "|");
	entry_point = "";
	offset_string = after (P_procedure_name, "|");
        end;
      else do;
        explicit_entry_sw = "0"b;
        pathname = P_procedure_name;
        entry_point = "";
      end;

      call expand_pathname_ (pathname, dir_name, entry_name, code);
      if code ^= 0 then do;
	call probe_error_$record (probe_info_ptr, code, "^a",
	     P_procedure_name);
	goto RECORDED_MESSAGE;
        end;

      segname = entry_name;
      if entry_point = ""
        then
	   entry_point = entry_name;

      call hcs_$initiate (dir_name, segname, entry_point, 0, 0, segp, code);
      if segp = null () then do;
CANT_INITIATE:
	call probe_error_$record (probe_info_ptr, code, "^a^[>^]^a^[$^a^]",
	     dir_name, (dir_name ^= ">"), segname, (segname ^= entry_point),
	     entry_point);
	goto RECORDED_MESSAGE;
        end;
      if code = error_table_$namedup then do;
				/* reference name already in use */
	unique_refname = unique_chars_ ("0"b);
	call hcs_$initiate (dir_name, segname, unique_refname, 0, 0,
	     unique_refname_ptr, code);
	if unique_refname_ptr = null
	  then go to CANT_INITIATE;
	call probe_error_$warning (probe_info_ptr, 0,
	     "Warning: ^a is not the initiated version of ^a",
	     pathname_ (dir_name, segname), segname);
        end;
    end;				/* pathname */

    else do;			/* assume ref name */
      assume_ref = "1"b;
      if index (P_procedure_name, "$") ^= 0 then do;
	explicit_entry_sw = "1"b;
	segname = before (P_procedure_name, "$");
	entry_point = after (P_procedure_name, "$");
	if entry_point = ""
	  then
	       entry_point = segname;
        end;
      else if index (P_procedure_name, "|") ^= 0 then do;
	explicit_entry_sw = "1"b;
	pathname = before (P_procedure_name, "|");
	entry_point = "";
	offset_string = after (P_procedure_name, "|");
        end;
      else do;
        explicit_entry_sw = "0"b;
        segname = P_procedure_name;
        entry_point = P_procedure_name;
      end;
    end;				/* of getting ref name */

  /* now segname and entry_point are set, so lets try to find the
   specific entry in mind. */

  if offset_string ^= "" then do;	/* path|N */
      segp = ptr (segp, cv_oct_check_ (offset_string, code));
      if code ^= 0 then do;
	call probe_error_$record (probe_info_ptr, code, "Bad offset ^a",
	     offset_string);
	go to RECORDED_MESSAGE;
        end;
    end;
    else do;
      if unique_refname_ptr ^= null
        then refname = unique_refname;
        else refname = segname;

      call hcs_$make_ptr (null (), refname, entry_point, segp, code);
      if code = error_table_$no_ext_sym & default_offset_zero_sw then do;
				/* warn user, and use whole seg */
	call hcs_$make_ptr (null (), refname, "", segp, (0));
	if segp ^= null then do;
	    call component_info_$name (segp, (segname), addr (ci), code);
	    if code = 0
	      then
		 if ci.text_start ^= null & ci.text_start ^= segp then do;
		     if explicit_entry_sw
		       then call probe_error_$warning
			       (probe_info_ptr, 0,
			       "Entry point ^a not found in segment ^a. Using base of component instead.",
			       entry_point, segname);
		     segp = ci.text_start;
		     go to CHECK_REFNAME;
		   end;

	    if explicit_entry_sw
	      then call probe_error_$warning (probe_info_ptr, 0,
		      "Entry point ^a not found in segment ^a. Using ^a|0 instead.",
		      entry_point, segname, segname);
	  end;
        end;
    end;

  if unique_refname_ptr ^= null
    then
         call term_$single_refname (unique_refname, (0));

  if segp = null () then do;
      call probe_error_$record (probe_info_ptr, code, "^a^[$^a^]",
	 segname, (segname ^= entry_point), entry_point);
      goto RECORDED_MESSAGE;
    end;
CHECK_REFNAME:
  if assume_ref
    then
      begin;
      ;				/* must check it for plausibility */
      dcl seg_uid		    bit (36) aligned;
      dcl 1 status_branch_auto    aligned like status_branch;


      dcl get_wdir_		    entry () returns (char (168));
      dcl hcs_$get_uid_seg	    entry (ptr, bit (36) aligned,
			    fixed bin (35));
      dcl hcs_$status_long	    entry (char (*), char (*), fixed bin (1),
			    ptr, ptr, fixed bin (35));

      status_ptr = addr (status_branch_auto);
				/* see of copy in wdir is same one as picked up by */
      dir_name = get_wdir_ ();	/* call to hcs_$make_ptr */
      call hcs_$status_long (dir_name, segname, 1, status_ptr, (null ()),
	 code);
      if code = 0 & status_branch.type = Segment then do;
	call hcs_$get_uid_seg (segp, seg_uid, code);
	if code = 0
	  then
	       if seg_uid ^= status_branch.uid then do;
				/* it's not the same */
		 call hcs_$fs_get_path_name (segp, actual_dn, 0,
		      actual_en, code);
		 call probe_error_$warning (probe_info_ptr, 0,
		      "Warning: Reference name ""^a"" does not refer to  ^a^[^/^-It refers to ^a^]",
		      segname, pathname_ (dir_name, segname), code = 0,
		      pathname_ (actual_dn, actual_en));
	         end;
        end;			/* of checking for sameness */
    end;

  /* now look for frame */

  call probe_stack_trace_$find_proc_frame (probe_info_ptr, sourcep, segp, 1);

  if sourcep -> source_info.stack_ptr = null () then do;
				/* not active */
      sourcep -> source_info.entry_ptr = segp;
				/* must find out about it ourseleves */
      sourcep -> source_info.instruction_ptr = null;
				/* not active */

      probe_info.entry_method = 1;

      sourcep -> source_info.seg_info_ptr =
	 probe_seg_info_ (probe_info_ptr, segp, code);

/* Check for the statement map. If not present we'll try seg$main */

      if code = probe_et_$no_map then do;
         probe_info.retry_using_main = 1;
         code = 0;
         goto MAIN_RETURN;
       end;

      if code ^= 0 
        then goto MAIN_RETURN;

      offset = fixed (rel (segp), 18);
      hp = sourcep -> source_info.seg_info_ptr -> seg_info.symbol_header_ptr;

      call stu_$get_map_index (hp, offset,
	 sourcep -> source_info.stmnt_map_entry_index, null);

      sourcep -> source_info.block_ptr =
	 stu_$find_containing_block (hp, offset);
    end;				/* doing it ourselves */

  code = 0;			/* all done */
  goto MAIN_RETURN;


RECORDED_MESSAGE:
  code = probe_et_$recorded_message;
  goto MAIN_RETURN;


MAIN_RETURN:
  P_code = code;
  return;

  /*  */

%include probe_source_info;

  /* ;;;;;;; */

%include probe_seg_info;

  /* ;;;;;;; */

%include probe_info;

  /* ;;;;;;; */


%include component_info;

  /* ;;;;;;; */

%include status_structures;
%include probe_lang_types;


  end;				/* external procedure probe_find_procedure_ */




		    probe_get_.alm                  10/24/88  1616.3rew 10/24/88  1354.1       16056



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

" HISTORY COMMENTS:
"  1) change(88-10-18,WAAnderson), approve(88-10-18,MCR7952),
"     audit(88-10-18,JRGray), install(88-10-24,MR12.2-1184):
"     Probe source archive split. Part of C-Probe support.
"                                                      END HISTORY COMMENTS


"
"	TRANSFER VECTOR for probe_get_
"
"	Miscellaneous entries for extracting things from the token chain
"
"	Created: 05/06/79 WOS
"	Modified: 8 Sept 79 by JRD to delete useless probe_get_$name
"	Modified: 22 Sept 79 JRD
"	Added $decimal 12/19/81 S. Herbst
"

	macro	transfer
	entry	&1
&1:	tra	&2
	&end

	transfer	expression,probe_get_expr_$probe_get_expr_

	transfer	value,probe_get_value_$value
	transfer	reference,probe_get_value_$reference

	transfer	line,probe_get_line_$probe_get_line_
	transfer	generation,probe_get_generation_$probe_get_generation_

	transfer	pathname,probe_get_misc_$pathname
	transfer	object,probe_get_misc_$object

	transfer	integer,probe_get_misc_$integer
	transfer	decimal,probe_get_misc_$decimal

	transfer	io_switch,probe_get_misc_$io_switch

	transfer	control_arg,probe_get_misc_$control_arg

	transfer	request_list,probe_get_misc_$request_list

	end




		    probe_get_c_address_.pl1        10/24/88  1616.4rew 10/24/88  1340.8       31257



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


/****^  HISTORY COMMENTS:
  1) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Written as part of C-Probe support.
                                                   END HISTORY COMMENTS */

/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

probe_get_c_address_:
  proc (the_addr, original_class, symbol_pt, subs_pt) returns (ptr);

  dcl the_addr		ptr parameter;
  dcl original_class	fixed bin (6) unsigned parameter;
  dcl symbol_pt		ptr parameter;
  dcl subs_pt		ptr parameter;

  dcl sym_pt		ptr init (symbol_pt);

  dcl data_ptr		ptr;	/* hold address as we calculate it */
  dcl bo			fixed bin (35);
				/* bit offset of data */
  dcl subscript		(n_dims) fixed bin based (subs_pt);
				/* the subscripts supplied */
  dcl 1 address_info	like runtime_address_info;
  dcl code		fixed bin (35);
  dcl sum			fixed bin (35);
				/* holds array offset as calc'ed */
  dcl subs_x		fixed bin;/* index into subscripts */

  dcl (addr, null, convert)	builtin;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

  address_info.version = RUNTIME_ADDRESS_INFO_VERSION_1;
  address_info.units = 1;
  address_info.location =
       convert (address_info.location, the_addr -> its_unsigned.offset);
  address_info.offset_is_encoded = "0"b;
  address_info.use_digit = 0;
  address_info.offset =
       convert (address_info.offset, the_addr -> its_unsigned.bit_offset);
  address_info.class = original_class;

  data_ptr = the_addr;

  bo = convert (bo, address_info.offset);

  n_dims = runtime_symbol_info_$array_dims (sym_pt);
  if (n_dims > 0) & (subs_pt ^= null) then do;
      begin;
        dcl 1 array_info	      like runtime_array_info;

        array_info.version = RUNTIME_ARRAY_INFO_VERSION_1;
        call runtime_symbol_info_$array (sym_pt, addr (array_info), code);
        if code ^= 0
	then return (null);
        sum = 0;
        do subs_x = 1 to n_dims;
	sum = sum
	     + (subscript (subs_x) * array_info.bounds.multiplier (subs_x));
        end;
        bo = bo + sum;
      end;
    end;				/* subscript hacking */
  return (bitrel (data_ptr, (bo)));
no:
  return (null ());
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

bitrel:
  proc (P_ptr, P_bit_offset) returns (ptr);
  dcl P_ptr		ptr parameter;
  dcl P_bit_offset		fixed bin (24) parameter;

  dcl 1 str		aligned based (P_ptr),
       2 filler		unal bit (P_bit_offset),
       2 target		unal bit (1);

  if P_bit_offset < 0
    then goto no;
  return (addr (str.target));
  end bitrel;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
%page;
%include runtime_symbol_info_;
%page;
%include its;

  end probe_get_c_address_;




		    probe_get_expr_.pl1             09/21/89  1242.4rew 09/21/89  1240.6      159219



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



/****^  HISTORY COMMENTS:
  1) change(88-05-25,WAAnderson), approve(88-10-18,MCR7952),
     audit(88-10-18,JRGray), install(88-10-24,MR12.2-1184):
     Added the internal procedures 'account_for_c_indirection' and
     'trace_c_indirection' to handle the C_INDIRECTION operator.The
     C_INDIRECTION operator and the TIMES operator are both represented
     graphically by the * character.
  2) change(88-05-27,WAAnderson), approve(88-10-18,MCR7952),
     audit(88-10-18,JRGray), install(88-10-24,MR12.2-1184):
     Added support for the AMPERSAND operator in 'get_factor'.
  3) change(88-06-13,WAAnderson), approve(88-10-18,MCR7952),
     audit(88-10-18,JRGray), install(88-10-24,MR12.2-1184):
     Modified 'get_bexpr' to handle the C_LEFT_SHIFT and C_RIGHT_SHIFT
     operators.
  4) change(88-09-07,WAAnderson), approve(88-10-18,MCR7952),
     audit(88-10-18,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
  5) change(88-11-30,WAAnderson), approve(88-12-05,MECR0006),
     audit(88-12-02,JRGray), install(88-12-05,MR12.2-1220):
     Added code to ensure probe chases the linked list of runtime_symbol
     structures whose head runtime_symbol structure is of type c_typeref_dtype
     ONLY when the program being probed has been generated by the C compiler.
     Prior to this change, Pascal enumerated types were being confused with
     c_typeref_dtypes, resulting in an infinite loop.
  6) change(89-09-18,WAAnderson), approve(89-09-18,MCR8042),
     audit(89-09-18,JRGray), install(89-09-21,MR12.3-1070):
     See above.  Closing out MECR006.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

probe_get_expr_:
  proc (P_probe_info_ptr, P_reference, P_code);

  /* This marvel can not only get expressions, it can get expressions using
   precedence ! Written at 6AM after an all-nighter, and is no doubt a crock

   JRDavis 13 Fri July 79

   Well, it was close...

   Modified 13 Nov 79 JRD

   BEXP := EXP << EXP
   EXP := TERM [+ TERM]...
   TERM := FACTOR [* FACTOR]...
   FACTOR := VALUE | (EXP)

   where <<, + or * can also be >>, - or /,% respectively, and "..."
   denotes arbitrary number of repitions of the stuff in the brackets,
   and a VALUE is what probe_get_$value returns.
*/
  /* * 09 Sep 81, S.Herbst:
    *    Fixed to handle "v (2+2)" and print better errmsg for "v -1|0".
    * ?? Jun 83, JMAthane:
    *    To know PASCAL array indices between brackets.
    * ?? Apr 88, Hinatsu:
    *    To add C operators "% << >>".
    *  */

  dcl (
      P_probe_info_ptr	ptr,
      1 P_reference		aligned like reference_node,
      P_code		fixed bin (35)
      )			parameter;

  dcl code		fixed bin (35);
  dcl pre_op_code		char (1) aligned;
  dcl saved_ct		ptr;

  dcl probe_create_reference_$init
			entry (ptr, ptr);
  dcl probe_builtins_$addr_builtin
			entry (ptr, ptr, fixed bin (35));
  dcl probe_operate_$infix	entry (ptr, char (1) aligned,
			1 structure aligned like reference_node,
			1 structure aligned like reference_node,
			1 structure aligned like reference_node,
			fixed bin (35));
  dcl probe_operate_$prefix	entry (ptr, char (1) aligned,
			1 structure aligned like reference_node,
			1 structure aligned like reference_node,
			fixed bin (35));

  dcl (
      probe_et_$recorded_message,
      probe_et_$bad_section,
      probe_et_$bad_expression
      )			fixed bin (35) external static;

  dcl probe_error_$record	entry options (variable);

  dcl (addr, addrel, fixed, null)
			builtin;
  dcl c_indirect_count	(40) fixed bin;
  dcl c_indirect_ix		fixed bin;
  dcl ptr_overlay		ptr based;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

account_for_c_indirection:
  proc ();

  dcl not_done_indirection	bit (1);

  if probe_info.language_type ^= C_lang_type  then return;
  c_indirect_ix = c_indirect_ix + 1;
  c_indirect_count (c_indirect_ix) = 0;
  not_done_indirection = "1"b;
  do while (not_done_indirection);
    if probe_info.ct -> token.type < probe_info.token_info.end_token
         & probe_info.ct -> token.type > OPERATOR_TYPE then do;
        if probe_info.ct -> token.type = C_INDIRECTION then do;
	  c_indirect_count (c_indirect_ix) =
	       c_indirect_count (c_indirect_ix) + 1;
	  probe_info.ct = probe_info.ct -> token.next;
	end;
	else not_done_indirection = "0"b;
      end;
      else not_done_indirection = "0"b;
  end;
  probe_info.ct = probe_info.ct -> token.prev;

  end account_for_c_indirection;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

trace_c_indirection:
  proc (ref_node_ptr);

  dcl ref_node_ptr		ptr;
  dcl 01 temp_ref		aligned like reference_node
			based (ref_node_ptr);

  if probe_info.language_type ^= C_lang_type then return;
  if (c_indirect_ix <= 0)
    then return;
  do while (c_indirect_count (c_indirect_ix) > 0);
    c_indirect_count (c_indirect_ix) = c_indirect_count (c_indirect_ix) - 1;
    if temp_ref.symbol_ptr -> runtime_symbol.son ^= "0"b then do;
        temp_ref.symbol_ptr =
	   addrel (temp_ref.symbol_ptr,
	   fixed (temp_ref.symbol_ptr -> runtime_symbol.son));
				/* typeref */
        do while (fixed (temp_ref.symbol_ptr -> runtime_symbol.type)
	   = c_typeref_dtype);
	temp_ref.symbol_ptr =
	     addrel (temp_ref.symbol_ptr,
	     fixed (temp_ref.symbol_ptr -> runtime_symbol.son));
        end;
        temp_ref.type = fixed (temp_ref.symbol_ptr -> runtime_symbol.type);
        temp_ref.address_ptr = temp_ref.address_ptr -> ptr_overlay;
        temp_ref.precision = temp_ref.symbol_ptr -> runtime_symbol.size;
      end;
  end;
  if c_indirect_ix > 0
    then c_indirect_ix = c_indirect_ix - 1;
  end trace_c_indirection;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

  pre_op_code = "?";
  probe_info_ptr = P_probe_info_ptr;
  P_code = 0;
  code = 0;
  saved_ct = ct;
  c_indirect_ix = 0;

  if ct -> token.type >= OPERATOR_TYPE then do;
      if probe_info.ct -> token.type = PLUS
        then pre_op_code = "+";
      else if probe_info.ct -> token.type = MINUS
        then pre_op_code = "-";
      else if probe_info.ct -> token.type = AMPERSAND
	 & (probe_info.language_type = C_lang_type)
        then pre_op_code = "?";
      else if probe_info.ct -> token.type = C_INDIRECTION
	 & (probe_info.language_type = C_lang_type) then do;
	call account_for_c_indirection ();
	pre_op_code = "*";
        end;
      else if probe_info.ct -> token.type
	 ^= LEFT_PAREN /* don't confuse ( with prefix ops */
	 &
	 ^(probe_info.language_type = PASCAL_lang_type
	 & probe_info.ct -> token.type = LEFT_BRACKET)
        then do;

	code = probe_et_$bad_expression;
	goto LOSS;
        end;
      if ct -> token.type ^= LEFT_PAREN
	 & ct -> token.type ^= LEFT_BRACKET &
	 ct -> token.type ^= AMPERSAND
        then ct = ct -> token.next;
    end;
GET_EXPR:

  call get_bexpr (P_reference);
  if pre_op_code ^= "?"
    then
         if P_reference.type = pointer_dtype & c_indirect_ix = 0
	    & pre_op_code ^= "*" then do;
				/* might be -1|0, etc. */

	   pre_op_code = "?";
	   ct = saved_ct;		/* reparse with "-" as part of ptr */
	   go to GET_EXPR;
	 end;
         else if P_reference.flags.cross_section
	 then goto SECTION_LOSS;
         else if pre_op_code = "*" & c_indirect_ix > 0
	 then
	      call trace_c_indirection (addr (P_reference));

         else if probe_info.execute & pre_op_code ^= "*"
	 then
	      call probe_operate_$prefix (probe_info_ptr, pre_op_code,
		 P_reference, P_reference, code);

LOSS:

  P_code = code;
  return;

SECTION_LOSS:
  code = probe_et_$bad_section;
  goto LOSS;

SINISTER_ERROR:

  call probe_error_$record (probe_info_ptr, probe_et_$bad_expression,
       "Too many left parentheses");
  code = probe_et_$recorded_message;
  return;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

get_bexpr:
  proc (bfirst);

  dcl 1 bfirst		aligned like reference_node parameter;
  dcl 1 bsecond_ref_block	aligned like ref_block automatic;
  dcl op_code		char (1) aligned;

  call probe_create_reference_$init (probe_info_ptr, addr (bsecond_ref_block))
       ;

  call get_expr (bfirst);
  do while ((probe_info.ct -> token.type = C_LEFT_SHIFT |
       probe_info.ct -> token.type = C_RIGHT_SHIFT |
       probe_info.ct -> token.type = C_INDIRECTION) &
       probe_info.language_type = C_lang_type);

    if probe_info.ct -> token.type = C_LEFT_SHIFT
      then op_code = "<";
    else if probe_info.ct -> token.type = C_RIGHT_SHIFT
      then op_code = ">";
    if (probe_info.ct -> token.type = C_LEFT_SHIFT
         | probe_info.ct -> token.type = C_RIGHT_SHIFT)
      then
	 ct = ct -> token.next;

    if probe_info.ct -> token.type = C_INDIRECTION
      then do;
        call account_for_c_indirection ();
        ct = ct -> token.next;
      end;
    if bfirst.cross_section
      then
	 goto SECTION_LOSS;

    call get_expr (bsecond_ref_block.ref_node);
    if bsecond_ref_block.ref_node.cross_section
      then
	 goto SECTION_LOSS;

    if probe_info.execute
      then do;
        if bsecond_ref_block.ref_node.type = pointer_dtype
	then
	     call trace_c_indirection (addr (bsecond_ref_block.ref_node));
        if bfirst.type = pointer_dtype
	then
	     call trace_c_indirection (addr (bfirst));
        call probe_operate_$infix (probe_info_ptr, op_code, bfirst,
	   bsecond_ref_block.ref_node, bfirst, code);
        if code ^= 0
	then
	     goto LOSS;
      end;
  end;

  end get_bexpr;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

get_expr:
  proc (first);

  dcl 1 first		aligned like reference_node parameter;
  dcl 1 second_ref_block	aligned like ref_block automatic;
  dcl op_code		char (1) aligned;

  call probe_create_reference_$init (probe_info_ptr, addr (second_ref_block));

  call get_term (first);
  do while (probe_info.ct -> token.type = PLUS |
       probe_info.ct -> token.type = MINUS |
       probe_info.ct -> token.type = C_INDIRECTION);

    if probe_info.ct -> token.type = PLUS
      then op_code = "+";
    else if probe_info.ct -> token.type = MINUS
      then op_code = "-";
    if (probe_info.ct -> token.type = PLUS
         | probe_info.ct -> token.type = MINUS)
      then
	 ct = ct -> token.next;

    if probe_info.ct -> token.type = C_INDIRECTION
      then do;
        call account_for_c_indirection ();
        ct = ct -> token.next;
      end;

    if first.cross_section
      then
	 goto SECTION_LOSS;

    call get_term (second_ref_block.ref_node);
    if second_ref_block.ref_node.cross_section
      then
	 goto SECTION_LOSS;

    if probe_info.execute
      then do;
        if second_ref_block.ref_node.type = pointer_dtype
	then
	     call trace_c_indirection (addr (second_ref_block.ref_node));
        if first.type = pointer_dtype
	then
	     call trace_c_indirection (addr (first));
        call probe_operate_$infix (probe_info_ptr, op_code, first,
	   second_ref_block.ref_node, first, code);
        if code ^= 0
	then
	     goto LOSS;
      end;
  end;				/* otherwise loop back for another */

  end get_expr;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

get_term:
  proc (alpha);

  dcl 1 alpha		aligned like reference_node parameter;
  dcl 1 beta_ref_block	aligned like ref_block automatic;
  dcl term_op_code		char (1) aligned;

  call probe_create_reference_$init (probe_info_ptr, addr (beta_ref_block));
  call get_factor (alpha);

  do while (probe_info.ct -> token.type = TIMES |
       probe_info.ct -> token.type = SLASH |
       (probe_info.ct -> token.type = PERCENT
       & probe_info.language_type = C_lang_type));
    if probe_info.ct -> token.type = TIMES
      then term_op_code = "*";
    else if probe_info.ct -> token.type = SLASH
      then term_op_code = "/";
    else if probe_info.ct -> token.type = PERCENT
      then term_op_code = "%";

    probe_info.ct = probe_info.ct -> token.next;

    if (probe_info.ct -> token.type = C_INDIRECTION) then do;
        call account_for_c_indirection ();
        probe_info.ct = probe_info.ct -> token.next;
      end;

    if alpha.cross_section
      then
	 goto SECTION_LOSS;

    call get_factor (beta_ref_block.ref_node);
    if beta_ref_block.ref_node.cross_section
      then
	 goto SECTION_LOSS;

    if probe_info.execute
      then do;
        if beta_ref_block.ref_node.type = pointer_dtype
	then
	     call trace_c_indirection (addr (beta_ref_block.ref_node));
        if alpha.type = pointer_dtype
	then
	     call trace_c_indirection (addr (alpha));
        call probe_operate_$infix (probe_info_ptr, term_op_code, alpha,
	   beta_ref_block.ref_node, alpha, code);
        if code ^= 0
	then
	     goto LOSS;
      end;

  end;				/* looping through all consequtive TERMS */
  end get_term;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

get_factor:
  proc (val);

  dcl 1 val		aligned like reference_node parameter;
  dcl probe_get_$value	entry (ptr,
			1 structure aligned like reference_node,
			bit (36) aligned, fixed bin (35));
  dcl indir_flag		bit (1);
  dcl defer_ampersand	bit (1);
  dcl 01 sub_refs		aligned like subscript_reference_ptrs;
  dcl probe_create_reference_ entry (ptr, ptr);
  dcl temp_node_ptr		ptr;

  indir_flag = "0"b;

  if ct -> token.type = LEFT_PAREN then do;
      ct = ct -> token.next;
      if ct -> token.type >= RIGHT_PAREN
        then
	   goto SINISTER_ERROR;
      if (ct -> token.type = C_INDIRECTION)
        then
	   call account_for_c_indirection ();
      call get_expr (val);
      if code ^= 0
        then
	   goto LOSS;
      if ct -> token.type ^= RIGHT_PAREN
        then
	   goto SINISTER_ERROR;
      ct = ct -> token.next;
    end;
    else do;
      if (ct -> token.type = C_INDIRECTION) then do;
	indir_flag = "1"b;
	ct = ct -> token.next;
        end;
      if ct -> token.type = AMPERSAND then do;
	ct = ct -> token.next;
	call probe_create_reference_ (probe_info_ptr, temp_node_ptr);
	temp_node_ptr -> reference_node.name = "<<<constant>>>";
	temp_node_ptr -> reference_node.source_info_ptr =
	     val.source_info_ptr;
				/* Set the c_symbol_ptr to any non-null value because get_value will null the
   symbol_ptr field if the symbol is a char array */
	val.c_symbol_ptr = addr (val);
	defer_ampersand = "1"b;
        end;
        else defer_ampersand = "0"b;

      call probe_get_$value (probe_info_ptr, val, "000"b, code);

      if code ^= 0
        then
	   goto LOSS;
      if (val.symbol_ptr ^= null ()) then do;
	if (fixed (val.symbol_ptr -> runtime_symbol.type)
	     = c_enum_const_dtype) & probe_info.language_type = C_lang_type then do;
	    val.type = real_fix_bin_1_dtype;
	    val.precision = 35;
	    val.symbol_ptr = null ();
	  end;
	else if (fixed (val.symbol_ptr -> runtime_symbol.type)
	     = c_typeref_dtype & probe_info.language_type = C_lang_type)
	  then do;
	    do while (fixed (val.symbol_ptr -> runtime_symbol.type)
	         = c_typeref_dtype);
	      val.symbol_ptr =
		 addrel (val.symbol_ptr,
		 fixed (val.symbol_ptr -> runtime_symbol.son, 17));
	    end;
	    if (fixed (val.symbol_ptr -> runtime_symbol.type)
	         = c_enum_dtype) then do;
	        val.type = real_fix_bin_1_dtype;
	        val.precision = 35;
				/*	         val.symbol_ptr = null();*/
	      end;
	      else do;
	        val.type =
		   fixed (val.symbol_ptr -> runtime_symbol.type, 35);
	        val.precision =
		   fixed (val.symbol_ptr -> runtime_symbol.size, 35);
	        val.flags.packed =
		   val.symbol_ptr -> runtime_symbol.bits.packed;
	      end;
	  end;
        end;
      if (indir_flag)
        then
	   call trace_c_indirection (addr (val));
      else if (defer_ampersand) then do;
	sub_refs (1, 1).ptr = addr (val);
	temp_node_ptr -> reference_node.optional_info.n_subscripts = 1;
	temp_node_ptr -> reference_node.subscript_refs_ptr =
	     addr (sub_refs);
	call probe_builtins_$addr_builtin (probe_info_ptr, temp_node_ptr,
	     code);
	temp_node_ptr -> reference_node.optional_info.n_subscripts = 0;
	temp_node_ptr -> reference_node.c_symbol_ptr = val.symbol_ptr;
	val = temp_node_ptr -> reference_node;
        end;

    end;
  return;

  end get_factor;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

%include probe_info;
%page;
%include probe_references;
%page;
%include probe_ref_block;
%page;
%include probe_source_info;
%page;
%include probe_tokens;
%page;
%include probe_operators;
%page;
%include probe_lang_types;
%page;
%include std_descriptor_types;
%page;
%include runtime_symbol;

  end probe_get_expr_;




		    probe_get_generation_.pl1       11/11/88  1554.4r w 11/11/88  1544.9       46332



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



/****^  HISTORY COMMENTS:
  1) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

probe_get_generation_:
  proc (P_probe_info_ptr, P_new_source_info_ptr, P_invocation, P_code);

  /* We parse a GENERATION that is, what can go inside square brackets after the name of a variable
   we are in the business of returning a block pointer and a stack frame pointer for the
   use of somebody trying to get the value of a variable

   a GENERATION:

   level N
   -N
   LINE
   PROCEDURE

   In the case of a relative invocation (-N) we can't set the actual block or source pointers, because
   they aren't known until the symbol is resolved 8starting in the current block).  So we set P_invocation,
   and our caller looks back the specified number of invocations.
   James R. Davis 1 July 79
   last modified: 17 Oct 79 JRD
*/

  dcl (
      P_probe_info_ptr	pointer,
      P_new_source_info_ptr	ptr parameter,
				/* to source_info_ptr struc for us to fill out */
      P_invocation		fixed bin,/* relative generation interpreted by caller */
      P_code		fixed bin (35)
      )			parameter;

  dcl 1 new_source		aligned like source_info
			based (new_source_info_ptr);
  dcl new_source_info_ptr	ptr;

  dcl level		fixed bin (35);
				/* used with level _i */
  dcl inv_level		fixed bin;/* for relative invocation */
  dcl code		fixed bin (35);
  dcl saved_ct		ptr;

  dcl probe_get_$integer	entry (ptr, fixed bin (35), fixed bin (35));
  dcl probe_get_$line	entry (ptr, ptr, fixed bin, bit (36) aligned,
			fixed bin, fixed bin (35));
  dcl probe_get_$object	entry (ptr, ptr, fixed bin (35));
  dcl probe_stack_trace_$get_level
			entry (ptr, ptr, fixed bin, fixed bin);
  dcl probe_error_$record	entry options (variable);

  dcl probe_et_$recorded_message
			fixed bin (35) external static;
				/*  */
  new_source_info_ptr = P_new_source_info_ptr;
  probe_info_ptr = P_probe_info_ptr;
  P_invocation = 0;
  code = 0;
  saved_ct = probe_info.ct;

  if ct -> token.type = NAME_TYPE
       & ct -> token.next -> token.type = CONSTANT_TYPE
    then do;			/* level specified */
      if current_identifier_name ^= "level"
        then goto SYNTAX_ERROR;
      ct = ct -> token.next;
      call probe_get_$integer (probe_info_ptr, level, code);
      if code ^= 0 then do;
	call probe_error_$record (probe_info_ptr, 0,
	     "An integer must follow level in a generation.");
	goto RECORDED_MESSAGE;
        end;
      if probe_info.execute
        then
	   call probe_stack_trace_$get_level (probe_info_ptr,
	        new_source_info_ptr, (level), 0);
    end;				/* level */

  /* may be a relative invocation: -_i */

  else if ct -> token.type = MINUS then do;
      ct = ct -> token.next;
      if ct -> token.type ^= CONSTANT_TYPE
        then goto SYNTAX_ERROR;	/* must be a constant here */
      call probe_get_$integer (probe_info_ptr, level, code);
      if code ^= 0
        then goto SYNTAX_ERROR;
      new_source = current_source;
      P_invocation = level;
    end;
  else do;
    call probe_get_$line (probe_info_ptr, new_source_info_ptr, inv_level,
         "1110"b, (0), code);
    if code = 0
      then P_invocation = inv_level;
      else do;			/* OBJECT */
        call probe_get_$object (probe_info_ptr, new_source_info_ptr, code);
        if code ^= 0
	then goto SYNTAX_ERROR;
      end;			/* object */
  end;				/* line or path */


MAIN_RETURN:
  P_code = code;
  return;


SYNTAX_ERROR:
  call probe_error_$record (probe_info_ptr, 0, "Syntax error in generation");
  goto RECORDED_MESSAGE;

RECORDED_MESSAGE:
  code = probe_et_$recorded_message;
  probe_info.ct = saved_ct;
  goto MAIN_RETURN;


  /*	INCLUDE FILES	*/

%include probe_info;

  /* ;;;;;;; */

%include probe_tokens;

  /* ;;;;;;; */

%include probe_references;

  /* ;;;;;;; */

%include probe_source_info;

  /* ;;;;;;; */

%include probe_operators;

  /* ;;;;;;; */

%include std_descriptor_types;

  /* ;;;;;;; */

%include probe_seg_info;

  /* ;;;;;;; */

  end;				/* external procedure probe_get_generation_ */




		    probe_get_line_.pl1             11/11/88  1554.4r w 11/11/88  1544.7      117900



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



/****^  HISTORY COMMENTS:
  1) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

probe_get_line_:
  proc (P_probe_info_ptr, P_new_source_info_ptr, P_invocation, P_switches,
       P_data_type, P_code);

  /* parse a LINE

   that can be
   $b			current breakpint line
   $c			current_source_ptr
   NN			line NN current proc
   MM-NN			line NN in file MM
   $label			a label that resembles a number
   label(x)		label variable or constant, may be subscripted

   any of these may be followed by an optional ,s
   which is a relative displacement in statements

   james R. Davis  25 June 79
   modified last on 2 Oct 79 */
  /* Fixed to use line number in an active frame if any 08/27/81 S. Herbst */
  /* Fixed to use first instruction in component if no entrypoint 09/22/81 S. Herbst */
  /* Modified June 83 JMAthane to replace references to "runtime_symbol" structure
   by calls to "runtime_symbol_info_" subroutine. */
  /* Added version strings to runtime_symbol_info_ structures 10/06/83 S. Herbst */
  /* Fixed references of the form LINE,N (N'th stmt on line) 03/12/84 S. Herbst */


  dcl (
      P_probe_info_ptr	pointer,
      P_new_source_info_ptr	ptr,
      P_invocation		fixed bin,
      P_switches		bit (36) aligned,
      P_data_type		fixed bin,/* output: data type found */
      P_code		fixed bin (35)
      )			parameter;

  dcl switches		bit (36) unaligned;

  dcl 1 new_source_info	aligned like source_info
			based (new_source_info_ptr);
  dcl new_source_info_ptr	ptr;
  dcl first_instr_ptr	ptr;
  dcl stmt		fixed bin;
  dcl code		fixed bin (35);
  dcl saved_ct		ptr;	/* so we can restore if error */

  dcl stu_$get_map_index	entry (ptr, fixed bin (18) unsigned, fixed bin,
			ptr);
  dcl stu_$get_statement_map	entry (ptr, ptr, ptr, fixed bin);

  dcl probe_get_$integer	entry (ptr, fixed bin, fixed bin (35));

  dcl probe_error_$record	entry options (variable);

  dcl (
      probe_et_$none_active,
      probe_et_$bad_line,
      probe_et_$bad_line_syntax,
      probe_et_$recorded_message
      )			fixed bin (35) external static;

  dcl (addr, addrel, after, binary, null, rel, substr, unspec, verify)
			builtin;
%page;

  probe_info_ptr = P_probe_info_ptr;
  new_source_info_ptr = P_new_source_info_ptr;
  switches = P_switches;
  P_data_type = label_constant_runtime_dtype;
				/* true for most */
  P_code = 0;
  code = 0;

  saved_ct = probe_info.ct;		/* in case of error */

  if probe_info.ct -> token.type = CONSTANT_TYPE
    then
      begin;
      dcl file		    fixed bin;
      dcl line		    fixed bin;
      dcl probe_find_location_    entry (ptr, ptr, fixed bin, fixed bin,
			    fixed bin, bit (36) aligned, ptr, fixed bin)
			    ;

      call probe_get_$integer (probe_info_ptr, line, code);
      if code ^= 0
        then goto BAD_LINE;
      if probe_info.ct -> token.type = MINUS &
	 ^probe_info.ct -> token.leading_whitespace then do;
				/* avoid LL -bf, accept FF-LL */
	file = line;		/* FF-LL */
	call bump_ct ();
	if probe_info.ct -> token.type ^= CONSTANT_TYPE
	  then goto BAD_LINE;
	call probe_get_$integer (probe_info_ptr, line, code);
	if code ^= 0
	  then goto BAD_LINE;
        end;
        else file = 0;

      if probe_info.execute then do;
	new_source_info = current_source;
	call probe_find_location_ (probe_info_ptr,
	     (new_source_info.seg_info_ptr),
	     (file), (line), 1, (switches), (null),
	     new_source_info.stmnt_map_entry_index);
	if new_source_info.stmnt_map_entry_index = -1
	  then go to BAD_LINE_NUMBER;
        end;			/* execute */
    end;				/* LINE CASE */
  else if probe_info.ct -> token.type = NAME_TYPE then do;
      if substr (current_identifier_name, 1, 1) = "$" then do;
	if current_identifier_name = "$c"
	  then
	       if probe_info.execute
	         then new_source_info = current_source;
	         else ;		/* not executing */
	else if current_identifier_name = "$b"
	  then
	       if probe_info.execute
	         then if probe_info.break_slot_ptr = null ()
		      then do;
		        code = probe_et_$none_active;
		        goto SOME_ERROR;
		      end;
		      else new_source_info = initial_source;
				/* what caused the break */
	         else ;		/* not executing */
	else
	  begin;			/* must be $NNN FORTRAN line number */
	  dcl stu_$find_runtime_symbol
				entry (ptr, char (*), ptr,
				fixed bin (35)) returns (ptr);
	  dcl probe_cv_stu_code_	entry (fixed bin (35));
	  dcl symbp		ptr;
				/* to the symbol found */
	  dcl label_name		char (64) varying;
	  dcl DIGITS		char (10) aligned internal
				static options (constant)
				init ("0123456789");
	  dcl 1 type_info		like runtime_type_info;
	  dcl 1 address_info	like runtime_address_info;

	  label_name = after (current_identifier_name, "$");
	  if label_name = ""
	    then goto BAD_LINE;
	  if verify (label_name, DIGITS) ^= 0
	    then goto BAD_LINE;

	  if probe_info.execute then do;
	      new_source_info = current_source;
	      symbp =
		 stu_$find_runtime_symbol ((current_source.block_ptr),
		 (label_name),
		 new_source_info.block_ptr, code);
	      if symbp = null () then do;
		call probe_cv_stu_code_ (code);
		call probe_error_$record (probe_info_ptr, code,
		     label_name);
		goto RECORDED_MESSAGE;
	        end;

	      type_info.version = RUNTIME_TYPE_INFO_VERSION_1;

	      call runtime_symbol_info_$type (symbp, addr (type_info), code)
		 ;
	      if code ^= 0
	        then go to SOME_ERROR;

	      P_data_type = type_info.type;

	      if P_data_type ^= label_constant_runtime_dtype then do;
		call probe_error_$record (probe_info_ptr, 0,
		     """^a"" is not a statement label", label_name);
		goto RECORDED_MESSAGE;
	        end;

	      address_info.version = RUNTIME_ADDRESS_INFO_VERSION_1;

	      call runtime_symbol_info_$address (symbp, addr (address_info),
		 code);
	      if code ^= 0
	        then go to SOME_ERROR;

	      call stu_$get_map_index
		 ((current_source.seg_info_ptr
		 -> seg_info.symbol_header_ptr),
		 (address_info.location),
		 new_source_info.stmnt_map_entry_index, (null));

	      if new_source_info.stmnt_map_entry_index = -1 then do;
		call probe_error_$record (probe_info_ptr, 0,
		     "Could not find location for $^a", label_name);
		goto RECORDED_MESSAGE;
	        end;
	    end;			/* execute */
	end;			/* $NNN CASE */

	call bump_ct ();		/* past the $thing */
        end;			/* $ hackers */
        else
	begin;			/* some other name type - a real name */

	dcl where		        ptr;
				/* to the code referenced */
	dcl based_label	        label variable based;
	dcl 1 label_var	        aligned,
	     2 place	        ptr,
	     2 frame	        ptr;
	dcl label_vector_tv	        bit (18) aligned based;
				/* for label array */

	dcl probe_create_reference_ entry (ptr, ptr);
	dcl probe_get_$value        entry (ptr,
			        1 aligned like reference_node,
			        bit (36) aligned, fixed bin (35));
	dcl probe_seg_info_	        entry (ptr, ptr, fixed bin (35))
			        returns (ptr);


	call probe_create_reference_ (probe_info_ptr, ref_block_ptr);
	ref_block.source_info_ptr = new_source_info_ptr;

	call probe_get_$value (probe_info_ptr, ref_block.ref_node,
	     (switches), code);
	if code ^= 0
	  then goto BAD_LOCATION;

	if probe_info.execute then do;/* must get location */

	    P_data_type = ref_block.ref_node.type;

	    if ref_block.ref_node.type = label_constant_runtime_dtype
	      then do;
	        where = ref_block.ref_node.address_ptr;

	        /* label array constants are implemented as an array of tra LOC,ic  */

	        if runtime_symbol_info_$array_dims (ref_block.ref_node
		   .symbol_ptr) ^= 0
		then where = addrel (where, where -> label_vector_tv);
	      end;		/* label constant */

	    else if new_source_info.stmnt_map_entry_index > 0
	      then
		 go to GET_INVOCATION;
				/* already have line number from an active frame */

	    else if ref_block.ref_node.type = label_dtype |
	         ref_block.ref_node.type = entry_dtype then do;

	        unspec (label_var) =
		   unspec (ref_block.ref_node.address_ptr -> based_label);
	        where = label_var.place;

	        /* this could be in another segment, so must get info */

	        new_source_info.seg_info_ptr =
		   probe_seg_info_ (probe_info_ptr, where, code);
	        if code ^= 0
		then goto SOME_ERROR;
	      end;		/* label variable */
	    else if ref_block.ref_node.type = int_entry_runtime_dtype |
	         ref_block.ref_node.type = ext_entry_runtime_dtype |
	         ref_block.ref_node.type = ext_procedure_runtime_dtype
	      then
		 where = ref_block.ref_node.address_ptr;
	    else do;		/* some other dtype */
	      call probe_error_$record (probe_info_ptr, 0,
		 """^a"" is not a label or entry value",
		 ref_block.ref_node.name);
	      goto RECORDED_MESSAGE;
	    end;

	    /* now where is set up */

	    call stu_$get_map_index
	         ((new_source_info.seg_info_ptr
	         -> seg_info.symbol_header_ptr),
	         binary (rel (where)),
	         new_source_info.stmnt_map_entry_index, (null));
	    if new_source_info.stmnt_map_entry_index = -1 then do;
	        call stu_$get_statement_map
		   /* use first instruction in the component instead */
		   ((new_source_info.seg_info_ptr
		   -> seg_info.symbol_header_ptr),
		   first_instr_ptr, (null), (0));
	        if first_instr_ptr ^= null
		then new_source_info.stmnt_map_entry_index = 1;
		else do;
		  call probe_error_$record (probe_info_ptr, 0,
		       "Can't get statement map of ^a",
		       ref_block.ref_node.name);
		  goto RECORDED_MESSAGE;
		end;
	      end;
GET_INVOCATION:
	    if ref_block.ref_node.invocation_level ^= 0
				/* we were presumably called from get_generation_ */
	      then P_invocation = ref_block.ref_node.invocation_level;

	  end;			/* executeing NAME */
        end;			/* trying to get value */
    end;				/* NAME TYPE CASE */
  else goto BAD_LINE;

  /* now source_info.seg_info_ptr and stmnt_map_entry_ptr are set */

  stmt = 0;
  if probe_info.ct -> token.type = COMMA then do;


      call bump_ct ();

      /* Want the N'th statement starting at the specified line */

      if probe_info.ct -> token.type ^= CONSTANT_TYPE
        then goto BAD_LINE;
      call probe_get_$integer (probe_info_ptr, stmt, code);
      if code ^= 0 then do;
	call probe_error_$record (probe_info_ptr, 0,
	     "A relative statement number must follow the comma in a LINE. Type ""help LINE""."
	     );
	goto RECORDED_MESSAGE;
        end;
      stmt = stmt - 1;		/* convert to relative position, eg. N,1 = N */
    end;				/* COMMA hacking */

  if probe_info.ct -> token.type < OPERATOR_TYPE
    then goto BAD_LINE;

  /* now find block, stack, etc. given the above info */


  dcl probe_source_segment_$position_source
			entry (ptr, ptr, fixed bin, fixed bin (35));

  if probe_info.execute
    then call probe_source_segment_$position_source
	    (probe_info_ptr, new_source_info_ptr, stmt, code);

MAIN_RETURN:
  P_code = code;
  return;


  /* HERE ARE ERROR LABELS */

BAD_LINE:
  call probe_error_$record (probe_info_ptr, probe_et_$bad_line_syntax);
  goto RECORDED_MESSAGE;

BAD_LINE_NUMBER:
  call probe_error_$record (probe_info_ptr, probe_et_$bad_line);
  go to RECORDED_MESSAGE;

BAD_LOCATION:
  call probe_error_$record (probe_info_ptr, 0,
       "Can't get location of ^a", ref_block.ref_node.name);
  go to RECORDED_MESSAGE;

RECORDED_MESSAGE:
  code = probe_et_$recorded_message;
  goto SOME_ERROR;

SOME_ERROR:
  P_code = code;

  probe_info.ct = saved_ct;		/* restore, cause we  failed */
  return;





bump_ct:
  proc;
  probe_info.ct = probe_info.ct -> token.next;
  end bump_ct;
%page;
%include probe_info;
%page;
%include probe_operators;
%page;
%include probe_ref_block;
%page;
%include probe_references;
%page;
%include probe_seg_info;
%page;
%include probe_source_info;
%page;
%include probe_tokens;
%page;
%include runtime_symbol;
%page;
%include runtime_symbol_info_;
%page;
%include statement_map;
%page;
%include std_descriptor_types;


  end probe_get_line_;




		    probe_get_misc_.pl1             11/11/88  1554.4r w 11/11/88  1544.3      106344



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



/****^  HISTORY COMMENTS:
  1) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

probe_get_misc_:
  proc ();

  call probe_error_$malfunction ();
  return;				/* not an entry */

  /* probe_get_misc_ - to parse a variety of constructs used  in probe

   ENTRIES HERE:
   io_switch
   pathname
   object
   integer
   request_list
   control_arg

   someday: signed_integer

   Last Modified: 22 Sept 79 JRDavis to add object */
  /* Added $decimal to parse N.M into N and M 12/19/81 S. Herbst */

  dcl (
      P_probe_info_ptr	pointer,
      P_iocb_ptr		pointer,
      P_pathname		char (*) varying,
      P_source_info_ptr	ptr,	/* to source info to set */
      (P_integer, P_decimal)	fixed bin (35),
      P_line_ptr		pointer,
      P_line_lth		fixed bin (21),
      P_control_arg		char (64) varying,
      P_code		fixed bin (35)
      );

  dcl old_ct		pointer;	/* return this pointer if an attempted conversion fails */
  dcl code		fixed bin (35);

  dcl constant_string	char (probe_info.ct -> constant.precision)
			based (probe_info.ct -> constant.data_ptr);

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

  dcl (
      probe_et_$noarg,
      probe_et_$bad_expression,
      probe_et_$unbalanced_parens,
      probe_et_$bad_integer,
      probe_et_$recorded_message,
      probe_et_$syntax_error
      )			fixed bin (35) external static;


  dcl probe_error_$malfunction
			entry options (variable);

  dcl (addr, dec, divide, fixed, null, substr)
			builtin;
				/*  */

SYNTAX_ERROR:			/* general-purpose error exit */
  code = probe_et_$syntax_error;
  goto SOME_ERROR;


RECORDED_MESSAGE:
  code = probe_et_$recorded_message;
  goto SOME_ERROR;

SOME_ERROR:
  probe_info.ct = old_ct;

MAIN_RETURN:
  P_code = code;
  return;

io_switch:
  entry (P_probe_info_ptr, P_iocb_ptr, P_code);

  /* *	This entry extracts an I/O switch name from the token chain, if possible */


  dcl switchname		char (32) varying;
				/* this is local to this block */
  dcl iox_$find_iocb	entry (char (*), ptr, fixed bin (35));


  probe_info_ptr = P_probe_info_ptr;
  code = 0;

  old_ct = probe_info.ct;
  P_iocb_ptr = null ();

  if probe_info.ct -> token.type >= probe_info.end_token then do;
				/* nothing to get */
      code = probe_et_$noarg;
      goto SOME_ERROR;
    end;

  if probe_info.ct -> token.type = CONSTANT_TYPE then do;
      if probe_info.ct -> constant.data_type = (char_dtype * 2)
        then
	   switchname = constant_string;
        else goto SYNTAX_ERROR;	/* other constants useless */
    end;

    else do;
      call get_entryname (switchname, code);
      if code ^= 0
        then goto SOME_ERROR;
    end;

  if switchname = ""
    then goto SYNTAX_ERROR;

  if ct -> token.type < end_token
    then goto SYNTAX_ERROR;
  call iox_$find_iocb ((switchname), P_iocb_ptr, P_code);
  return;				/* end of code for get_io_switch entry */

  /*  */

pathname:
  entry (P_probe_info_ptr, P_pathname, P_code);

  /* *	This entry gets a pathname; that is, any number of leading "<", followed
   *	by one or  more entrynames, followed by any number of ">" entrynames */


  probe_info_ptr = P_probe_info_ptr;
  code = 0;

  old_ct = probe_info.ct;

  call get_pathname (P_pathname, code);
  if code ^= 0
    then goto SOME_ERROR;
  goto MAIN_RETURN;


control_arg:
  entry (P_probe_info_ptr, P_control_arg, P_code);

  /*  * gets a control args from the chain, if one is there */


  probe_info_ptr = P_probe_info_ptr;
  code = 0;

  old_ct = probe_info.ct;

  P_control_arg = "";
  if probe_info.ct -> token.type = MINUS
    then
         if probe_info.ct -> token.next -> token.type = NAME_TYPE
	 then
	   do;
	   call bump_ct ();		/* past the minus */
	   P_control_arg = current_identifier_name;
	   call bump_ct ();
	 end;

  P_code = 0;
  return;				/* end of code for $control arg */



integer:
  entry (P_probe_info_ptr, P_integer, P_code);

  dcl fb35_temp		fixed bin (35);


  probe_info_ptr = P_probe_info_ptr;
  code = 0;

  old_ct = probe_info.ct;

  if ^data_type_info_$info (
       divide (probe_info.ct -> constant.data_type, 2, 17, 0)).computational
    then do;
      P_code = probe_et_$bad_integer;
      return;

    end;

  call assign_ (addr (fb35_temp), 2, 35, (probe_info.ct -> constant.data_ptr),
       (probe_info.ct -> constant.data_type),
       probe_info.ct -> constant.scale_and_precision);

  P_integer = fb35_temp;
  call bump_ct ();
  P_code = 0;
  return;				/* end of code for integer */



decimal:
  entry (P_probe_info_ptr, P_integer, P_decimal, P_code);

  /* Given the number N.M, returns P_integer as N and P_decimal as M */
  /* Added as a kludge for "use level N.M" */

  dcl fdec_temp		fixed dec (6, 3);


  probe_info_ptr = P_probe_info_ptr;
  code = 0;

  if ^data_type_info_$info (
       divide (probe_info.ct -> constant.data_type, 2, 17, 0)).computational
    then do;
      P_code = probe_et_$bad_expression;
      return;
    end;

  call assign_ (addr (fdec_temp), real_fix_dec_9bit_ls_dtype * 2,
       786438 /* scale and precision of fixed dec (6, 3) */,
       (probe_info.ct -> constant.data_ptr),
       (probe_info.ct -> constant.data_type),
       probe_info.ct -> constant.scale_and_precision);

  P_integer = fdec_temp;
  fdec_temp = fdec_temp - dec (P_integer);
  P_decimal = fdec_temp * 10 ** fixed (probe_info.ct -> constant.scale);

  call bump_ct ();
  P_code = 0;
  return;

  /*  */

request_list:
  entry (P_probe_info_ptr, P_line_ptr, P_line_lth, P_code);

  /* *	This entry extracts a request line from the token chain; Such request lines
   *	are seen in breakpoint requests, etc. */

  dcl (last_token, first_token)
			pointer;
  dcl first_time		bit (1) aligned;
  dcl paren_level		fixed bin;
  dcl line_lth		fixed bin (21);
  dcl based_str		char (256) based;


  probe_info_ptr = P_probe_info_ptr;
  code = 0;

  old_ct = probe_info.ct;


  first_time = "1"b;
  paren_level = 0;
  do while ((probe_info.ct -> token.type < probe_info.end_token)
       | (paren_level > 0) | (first_time));
    if probe_info.ct -> token.type = LEFT_PAREN
      then
	 paren_level = paren_level + 1;
    else if probe_info.ct -> token.type = RIGHT_PAREN
      then
	 paren_level = paren_level - 1;
    first_time = "0"b;

    call bump_ct ();
    if probe_info.ct = null () then do; /* moby lossage */
        code = probe_et_$unbalanced_parens;
        goto SOME_ERROR;
      end;
  end;

  if paren_level < 0 then do;		/* should only happen if first token is ")" */
      code = probe_et_$unbalanced_parens;
      goto SOME_ERROR;
    end;

  first_token = old_ct;		/* get token pointers for first and last tokens */
  last_token = probe_info.ct -> token.prev;
				/* since we have advanced past it */

  if first_token -> operator.type = LEFT_PAREN then do;
				/* strip off outer pair of parens */
      first_token = first_token -> token.next;
				/* simply skip over the first token */
      if last_token -> token.type ^= RIGHT_PAREN then do;
	code = probe_et_$syntax_error;/* right paren is misplaced, as in "after: (foo; bar) baz" */
	goto SOME_ERROR;
        end;

      last_token = last_token -> token.prev;
				/* token BEFORE final paren */
    end;

  line_lth =
       (last_token -> token.next -> token.location)
       - (first_token -> token.location) + 1;
  line_lth = line_lth - 1;		/* since it now contains the final ")", reduce its length */
				/* by one to eliminate that character */
  if line_lth <= 0 then do;		/* something like "()" */
      code = probe_et_$syntax_error;
      goto SOME_ERROR;
    end;

  P_line_lth = line_lth;
  P_line_ptr = addr (substr (first_token -> token.buffer_ptr -> based_str,
       first_token -> token.location, 1));
				/* first char in string */

  P_code = 0;
  return;				/* end of code for $get_request_line entry */

object:
  entry (P_probe_info_ptr, P_source_info_ptr, P_code);

  /* Parse and return an OBJECT
   This can be a pathname or e refname of an EXTERNAL ENTRY.  We are not interested in
   internal entrypoints or procedures.  This is a Multicious thing more than a PL/I
   (or FORTRAN or COBOL or PASCAL or ALGOL) thing.

   James R. Davis 22 Sept 79
*/

  dcl obj_pathname		char (168) varying;

  dcl probe_find_procedure_	entry (ptr, char (*), bit (36) aligned, ptr,
			fixed bin (35));


  probe_info_ptr = P_probe_info_ptr;
  code = 0;
  old_ct = probe_info.ct;

  call get_pathname (obj_pathname, code);
  if code ^= 0
    then
         return;

  if probe_info.execute then do;
      call probe_find_procedure_ (probe_info_ptr, (obj_pathname), "111"b,
	 (P_source_info_ptr), code);
      if code ^= 0
        then goto SOME_ERROR;
    end;
  goto MAIN_RETURN;


  /* INTERNAL PROCEDURES */

bump_ct:
  proc;
  probe_info.ct = probe_info.ct -> token.next;
  end bump_ct;


get_pathname:
  proc (path, code);

  /* parses a pathname for the sake of $pathname and $object  */

  dcl path		char (*) varying parameter;
  dcl code		fixed bin (35) parameter;
  dcl path_entry		char (32) varying;


  path = "";
  code = 0;

  do probe_info.ct = probe_info.ct repeat probe_info.ct -> token.next
       while (probe_info.ct -> token.type = LESS_THAN);
    path = path || "<";
  end;

  call get_entryname (path_entry, code);
  if code ^= 0
    then
         return;

  path = path || path_entry;		/* this may harmlessly be null */

  do while (probe_info.ct -> token.type = GREATER_THAN);
    path = path || ">";
    probe_info.ct = probe_info.ct -> token.next;

    call get_entryname (path_entry, code);
    if code ^= 0
      then
	 return;
    path = path || path_entry;
  end;

  end get_pathname;



get_entryname:
  proc (ename, code);

  dcl ename		char (32) varying parameter;
  dcl code		fixed bin (35) parameter;


  ename = "";
  code = 0;
  do probe_info.ct = probe_info.ct repeat probe_info.ct -> token.next
       while (probe_info.ct ^= null);
    if probe_info.ct -> token.type = NAME_TYPE
      then ename = ename || current_identifier_name;
    else if probe_info.ct -> operator.type = SLASH
      then ename = ename || "/";
    else if probe_info.ct -> operator.type = PERIOD
      then ename = ename || ".";
    else if probe_info.ct -> operator.type = DOLLAR_SIGN
      then ename = ename || "$";
    else if probe_info.ct -> operator.type = COMMA
      then ename = ename || ",";
    else
         return;
  end;				/* snarfing tokens into the entryname */
  end get_entryname;

%include probe_info;
%include probe_source_info;
%include probe_seg_info;
%include probe_tokens;
%include probe_operators;
%include probe_references;

%include status_structures;
%include data_type_info_;
%include std_descriptor_types;
  end probe_get_misc_;




		    probe_get_value_.pl1            10/17/90  0822.3rew 10/17/90  0816.3      568854



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

/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */

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

/****^  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 parsing of values like <pointer_value> -> <type_identifier> when
     language is PASCAL.  Fixed bugs in parsing of array values or cross
     sections.
  2) change(88-05-30,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Changed 'get_level' so it calls 'get_c_brackets' when the language is
     C instead of 'get_parens'.  'get_c_brackets' is functionally the same
     as 'get_parens' in the sense that they both evaluate subscripts.
  3) change(88-06-01,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Changed the code in 'get_c_brackets' to accept s single pair of empty
     brackets. This allows character arrays and pointers to characters to be
     handled as strings. No type checking is done in this procedure.
  4) change(88-06-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Changed the code in 'parse_normal' to modify a reference node from being
     a pointer to a character to a string value of maxlength 256 when empty
     brackets are used.
  5) change(88-07-19,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added the procedure 'get_unqualified_c_value' to provide the same
     functionality as 'get_unqualified_value' but is specifically
     designed for the C symbol table format.
  6) change(88-07-25,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Modified 'parse_normal' and 'get_unqualified_c_value' to handle
     subscripts  within a structure.
  7) change(88-09-07,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added format control comment to make the source more readable.
  8) change(88-10-28,WAAnderson), approve(88-10-28,MCR7952),
     audit(88-10-31,RWaters), install(88-11-11,MR12.2-1210):
     Modified code to compute the complete address of a character pointer
     referenced with subscripts. Prior to this fix, only literal values could
     be used as pointer subscripts.
  9) change(90-09-20,Bubric), approve(90-10-01,MCR8211), audit(90-10-01,Itani),
     install(90-10-17,MR12.4-1044):
     Have the calls to the routine 'nothing' changed to calls to the routine
     'null_entry_'.
                                                   END HISTORY COMMENTS */

probe_get_value_:
  proc ();
  call probe_error_$malfunction ();	/* dummy entry */
  return;

  /* This routine is called to parse and interpret a reference to some data item.
   One argument is used to specify the type of reference allowed at the current point.
   It returns information about the reference in a structure called reference.
   If necessary (i.e. a cross-section reference is found), the array real_subscripts
   is filled in with the bounds (low and high).

   entries:

   $value  - gets a VARIABLE may include function  call
   $reference - a misnomer,  gets a "reference" to  a symbol node - used by "symbol" request only
   Modified JRD 15 Aug 79
   Modified JRD 5 Sep 79 - for true COBOL parsing - a great pain!
   Modified 19 Feb 80 for %probe variables */
  /* Changed to accept first 3 bits of P_switches 08/26/81 S. Herbst */
  /* Changed to understand pathnames & virtual entries 09/11/81 S. Herbst */
  /* Modified June 83 JMAthane to add "a la PASCAL" parsing */
  /* Fixed "segno|offset->var" references (constant qualifier) broken earlier 07/27/83 S. Herbst */
  /* Changed to handle Pascal cross-section by changing the reference's array bounds 08/16/83 S. Herbst */
  /* Added version strings to runtime_symbol_info_ structures 10/06/83 S. Herbst */
  /* Fixed "Qualifier ^p is null." msg to not show qualifier's qualifier 02/09/84 S. Herbst */
  /* Fixed "sb $100" to reference FORTRAN statement label 02/16/84 S. Herbst */
  /* Fixed not to automatically translate "-" to "_" in (COBOL) identifiers 09/20/84 Steve Herbst */
  /* Fixed bug in cross arrays in Pascal,
   Added parsing of <pointer_value> "->" <type_identifier> in parse_a_la_pascal.
   JMAthane June 85 */

  /*
   THIS CODE IS A BOGUS HOAX - here's why

   The concepts it implements are subtlely different from those of PL/I
   (See Chapter Six of AG94)  The kinds of reference one might be interested in are:

   a value - really a pointer to it (useful in expressions)
   a reference - a pointer to some storage (what PL/I means)
   a declaration - for the "symbol" request

   Now there is this crock want_external_sw (position 1 of P_switches)
   If it is ON, this code does not invoke a function.  This means that a reference to an external function
   that returns an entry will  return the first function, not its value.
   PL/I is very explicit on this point.  The value of a reference should depend
   only on its syntax, not on what the caller wants.

*/

  /* The syntax of a reference:
   {} enclose optional material, | separates choices
   {}* indefinite repetition of option

   REF ::= constant { -> VAR} | VAR
   VAR ::= VAR1 { -> VAR }
   VAR1 ::= LEVEL{.LEVEL}* {[generation]} {(ARGLIST)}
   LEVEL ::= NAME {SUBS}
   SUBS ::= (DIM {,DIM}*)
   DIM ::= expression | expression : expression | *

*/

  dcl (
      P_probe_info_ptr	pointer,
      1 P_reference		structure aligned like reference_node,
      P_switches		bit (36) aligned,
      P_code		fixed bin (35)
      )			parameter;

  dcl switches		bit (36);
  dcl need_to_indirect_and_make_string
			bit (1) init ("0"b);


  dcl 1 ref_arg_list	aligned based (P_reference.argument_list)
			like reference_arg_list;
  dcl 1 ref_subscripts	aligned based (P_reference.subscript_ptr)
			like reference_subscripts;
  dcl 1 ref_source_info	aligned based (P_reference.source_info_ptr)
			like source_info;
  dcl 1 sub_refs		aligned
			based (P_reference.subscript_refs_ptr)
			like subscript_reference_ptrs;

  dcl (
      UPPER		init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"),
      LOWER		init ("abcdefghijklmnopqrstuvwxyz")
      )
			char (27) aligned internal static
			options (constant);

  dcl want_value		bit (1) aligned;
				/* tells whether or not to get full address */
  dcl code		fixed bin (35);
  dcl make_lower		bit (1) aligned;

  dcl dummy_entry		entry variable;

  dcl 1 subscript		aligned based like reference_node;
				/* dummy subscript */

  dcl identifier_tokens_name	char (ct -> identifier.length)
			based (ct -> identifier.name);

  dcl id_token		char (id_ptr -> identifier.length)
			based (id_ptr -> identifier.name);

  dcl cv_entry_		entry (char (*), ptr, fixed bin (35))
			returns (entry);

  dcl probe_check_ptr_$indirectable
			entry (ptr, fixed bin (35));
  dcl probe_error_$record	entry options (variable);
  dcl probe_error_$malfunction
			entry options (variable);
  dcl probe_eval_$evaluate	entry (ptr, 1 aligned like reference_node,
			bit (36) aligned, bit (1) aligned,
			fixed bin (35));
  dcl probe_eval_$add_c_dims	entry (ptr, 1 aligned like reference_node,
			bit (36) aligned, bit (1) aligned,
			fixed bin (35), fixed bin (6) unsigned);
  dcl probe_create_reference_ entry (ptr, ptr);
  dcl probe_get_$expression	entry (pointer, 1 aligned like reference_node,
			fixed bin (35));
  dcl probe_get_$generation	entry (pointer, pointer, fixed bin,
			fixed bin (35));

  dcl (
      probe_et_$bad_locator,
      probe_et_$bad_operator,
      probe_et_$bad_pointer,
      probe_et_$dim_limit,
      probe_et_$null_ptr,
      probe_et_$recorded_message,
      probe_et_$too_long
      )			fixed bin (35) external static;

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

  dcl (addr, addrel, bin, binary, convert, divide, fixed, hbound, index)
			builtin;
  dcl (length, maxlength, null, substr, translate, unspec, verify)
			builtin;
  dcl id_ptr		ptr;
%page;
probe_get_value_$value:
  entry (P_probe_info_ptr, P_reference, P_switches, P_code);

  want_value = "1"b;
  switches = P_switches;
  need_to_indirect_and_make_string = "0"b;

  goto start;


probe_get_value_$reference:
  entry (P_probe_info_ptr, P_reference, P_code);

  want_value = "0"b;
  unspec (switches) = "0"b;
  goto start;

start:

  probe_info_ptr = P_probe_info_ptr;
  code = 0;

  P_reference.name = "";		/* initialize the variables */
  P_reference.flags = "0"b;
  P_reference.precision = 0;
  P_reference.symbol_ptr = null;
  P_reference.address_ptr = null;
  P_reference.type_ptr = null;
  P_reference.base_addr = null ();
  P_reference.have_generation = "0"b;
  P_reference.invocation_level = 0;
  P_reference.type = 0;
  P_reference.optional_info.n_subscripts = 0;
  P_reference.optional_info.n_arguments = 0;

  ref_arg_list.number = 0;
  ref_subscripts.number = 0;
  ref_source_info.block_ptr, ref_source_info.stack_ptr,
       ref_source_info.entry_ptr = null;


  if probe_info.language_type = COBOL_lang_type
       | probe_info.language_type = PASCAL_lang_type
    then make_lower = "1"b;
  else if probe_info.language_type = FORTRAN_lang_type
    then make_lower =
	    current_source.seg_info_ptr -> seg_info.bits.ignore_case;
  else make_lower = "0"b;

  if probe_info.ct -> token.type = GREATER_THAN
       | probe_info.ct -> token.type = LESS_THAN
    then
         call get_pathname ();
  else if looks_like_cobol ()
    then call parse_ala_cobol;
  else if probe_info.language_type = PASCAL_lang_type
    then
         call parse_ala_pascal;
  else call parse_normal;

SOME_ERROR:
  P_code = code;
  return;


RECORDED_MESSAGE:
  code = probe_et_$recorded_message;
  goto SOME_ERROR;


disgruntled:
  proc (ecode);
  dcl ecode		fixed bin (35) parameter;

  code = ecode;
  goto SOME_ERROR;
  end disgruntled;
%page;
parse_normal:
  proc;				/* parse a REF */

  dcl based_ptr		pointer based;
  dcl based_packed_ptr	pointer unal based;

  dcl stu_$offset_to_pointer	entry (pointer, pointer, pointer, pointer,
			pointer, pointer) returns (pointer);
  dcl probe_check_ptr_$check	entry (ptr, fixed bin (35));
  dcl 01 acc_str		based,
       02 str_len		fixed bin (9) unsigned unaligned,
       02 str_name		char (0 refer (acc_str.str_len)) unaligned;
  dcl name_ptr		ptr;
  dcl (tsp, old_addr, final_ptr)
			ptr;
  dcl offset_bits		fixed bin (6) unsigned;
  dcl offset_words		fixed bin (18) unsigned;
  dcl mod			builtin;
  dcl original_class	fixed bin (6) unsigned;

  original_class = 0;

  if probe_info.ct -> token.type = CONSTANT_TYPE then do;
      P_reference.constant = "1"b;
      P_reference.constant_token_ptr = probe_info.ct;
      P_reference.name = "<<constant>>";/* should be smart and get name ! */
      call bump_ct ();
    end;
  else if current_token.type = NAME_TYPE &
       probe_info.language_type = C_lang_type
    then
         call get_unqualified_c_reference ();
  else if current_token.type = NAME_TYPE
    then
         call get_unqualified_reference ();
  else do;			/* some operator */
    call probe_error_$record (probe_info_ptr, probe_et_$bad_operator,
         OPERATOR_VALUES (binary (substr (current_token.type, 13, 6), 17)));
    goto RECORDED_MESSAGE;
  end;

  old_addr = null ();
  do while (probe_info.ct -> token.type = ARROW &
       probe_info.language_type = C_lang_type);

    if (P_reference.address_ptr = null ())
      then
	 call probe_eval_$evaluate (probe_info_ptr, P_reference, (switches),
	      want_value,
	      code);

    if P_reference.type ^= pointer_dtype then do;
        call probe_error_$record (probe_info_ptr, 0,
	   "The -> symbol may be used only in conjuction with pointers to structures."
	   );
        goto RECORDED_MESSAGE;
      end;
    if (P_reference.symbol_ptr ^= null ()) then do;
        tsp = P_reference.symbol_ptr;
        do while ((fixed (tsp -> runtime_symbol.type) = pointer_dtype |
	   fixed (tsp -> runtime_symbol.type) = c_typeref_dtype)
	   & /* typeref */
	   tsp -> runtime_symbol.son ^= "000000"b3);
	tsp = addrel (tsp, fixed (tsp -> runtime_symbol.son));
        end;
        P_reference.symbol_ptr = null ();
        P_reference.type = 0;
        old_addr = P_reference.address_ptr;
        P_reference.address_ptr = null ();
        P_reference.type_ptr = null ();
        P_reference.base_addr = null ();
        name_ptr = addrel (tsp, fixed (tsp -> runtime_symbol.name));
        P_reference.name =
	   substr (name_ptr -> acc_str.str_name, 1,
	   name_ptr -> acc_str.str_len) || ".";
      end;

    call bump_ct ();

    if probe_info.ct -> token.type = NAME_TYPE
      then do;
        call get_unqualified_c_reference ();
        call probe_eval_$evaluate (probe_info_ptr, P_reference, (switches),
	   want_value,
	   code);

        final_ptr = old_addr -> based_ptr;
        if (P_reference.symbol_ptr ^= null ()) then do;
	  if (^P_reference.symbol_ptr -> runtime_symbol.bits.simple &
	       P_reference.symbol_ptr -> runtime_symbol.offset ^= 0)
	    then do;
	      offset_bits =
		 convert (offset_bits,
		 P_reference.symbol_ptr -> runtime_symbol.offset);
	      offset_words =
		 convert (offset_words, divide (offset_bits, 36, 17, 0));
	      offset_bits = convert (offset_bits, mod (offset_bits, 36));
	      addr (final_ptr) -> its_unsigned.offset =
		 addr (final_ptr) -> its_unsigned.offset + offset_words;
	      addr (final_ptr) -> its_unsigned.bit_offset =
		 addr (final_ptr) -> its_unsigned.bit_offset
		 + offset_bits;
	    end;
	end;
        dcl null_entry_		      entry options (variable);
        call null_entry_ ();

        P_reference.address_ptr = final_ptr;

        if (P_reference.n_subscripts > 0)
	then
	     call probe_eval_$add_c_dims (probe_info_ptr, P_reference,
		(switches), "1"b, code, original_class);

      end;
  end;

  if (old_addr ^= null ()) then do;
      code = 0;
      goto SOME_ERROR;
    end;

  do while (probe_info.ct -> token.type = ARROW &
       probe_info.language_type ^= C_lang_type);

    call probe_eval_$evaluate (probe_info_ptr, P_reference, (switches),
         want_value,
         code);

    if P_reference.constant then do;
        if P_reference.type ^= pointer_dtype
	then call disgruntled (probe_et_$bad_pointer);
        P_reference.base_addr = P_reference.address_ptr -> based_ptr;
      end;			/* constant */
      else do;
        if probe_info.execute then do;	/* we have valid data */
	  if P_reference.type = pointer_dtype
	    then if P_reference.packed
		 then P_reference.base_addr =
			 P_reference.address_ptr -> based_packed_ptr;
		 else P_reference.base_addr =
			 P_reference.address_ptr -> based_ptr;
	  else if P_reference.type = offset_dtype
	    then P_reference.base_addr = stu_$offset_to_pointer (
		    ref_source_info.block_ptr, P_reference.symbol_ptr,
		    P_reference.address_ptr, ref_source_info.stack_ptr,
		    (ref_source_info.seg_info_ptr -> seg_info.linkage_ptr)
		    , null);
	  else do;		/* other data type no good */
	    call probe_error_$record (probe_info_ptr, probe_et_$bad_locator,
	         P_reference.name);
	    goto RECORDED_MESSAGE;
	  end;
	end;			/* execute case */
	else P_reference.base_addr = null ();
				/* just syntax-checking */
      end;			/* variable case */

    if probe_info.flags.execute then do;
        call probe_check_ptr_$check (P_reference.base_addr, code);
        if code ^= 0
	then goto SOME_ERROR;

        call probe_check_ptr_$indirectable (P_reference.base_addr, code);
        if code ^= 0 then do;
	  if P_reference.constant
	    then call probe_error_$record
		    (probe_info_ptr, code, "Qualifier ^p",
		    P_reference.base_addr);
	  else if code = probe_et_$null_ptr
	    then call probe_error_$record (probe_info_ptr, 0,
		    "Qualifier ^a is null.",
		    qualifier_name (P_reference.symbol_ptr));
	  else call probe_error_$record (probe_info_ptr, code,
		  "Qualifier ^a = ^w ^w",
		  qualifier_name (P_reference.symbol_ptr),
		  substr (unspec (P_reference.base_addr), 1, 36),
		  substr (unspec (P_reference.base_addr), 37, 36));
	  go to RECORDED_MESSAGE;
	end;
      end;

    /* these could be dangerous */

    P_reference.flags = "0"b;
    P_reference.n_subscripts, P_reference.n_arguments = 0;
    P_reference.address_ptr = null ();
    P_reference.name = "";

    call bump_ct ();

    /* Now, what are we pointing to */

    if current_token.type = NAME_TYPE
      then call get_unqualified_reference ();
    else if current_token.type = CONSTANT_TYPE then do;
        call probe_error_$record (probe_info_ptr, 0,
	   "A constant cannot be based.");
        goto RECORDED_MESSAGE;
      end;
    else do;
      call probe_error_$record (probe_info_ptr, 0, "Bad syntax ""-> ^a"".",
	 OPERATOR_VALUES (binary (substr (current_token.type, 13, 6), 17)));
      goto RECORDED_MESSAGE;
    end;

  end;				/* do while loop */

  if index (P_reference.name, "$") = 1
       & probe_info.language_type = FORTRAN_lang_type &
       verify (substr (P_reference.name, 2), "0123456789 ") = 0
    then
         P_reference.name = substr (P_reference.name, 2);
  if (probe_info.language_type ^= C_lang_type
       | P_reference.address_ptr = null ())
    then
         call probe_eval_$evaluate (probe_info_ptr, P_reference, (switches),
	    want_value, code);

  /* The empty brackets mean indirection. The symbol must be a char pointer 
    though. */
  if (need_to_indirect_and_make_string) then do;
      if (P_reference.symbol_ptr = null ()) then do;
	call probe_error_$record (probe_info_ptr, 0,
	     "Could not locate the symbol ^a", P_reference.name);
	goto RECORDED_MESSAGE;
        end;
      if (P_reference.symbol_ptr -> runtime_symbol.son ^= "000000"b3 &
	 P_reference.type = pointer_dtype)
        then do;
	do while (fixed (P_reference.symbol_ptr -> runtime_symbol.type)
	     = pointer_dtype |
	     fixed (P_reference.symbol_ptr -> runtime_symbol.type)
	     = c_typeref_dtype);
	  P_reference.symbol_ptr =
	       addrel (P_reference.symbol_ptr,
	       fixed (P_reference.symbol_ptr -> runtime_symbol.son));
	end;
	if (fixed (P_reference.symbol_ptr -> runtime_symbol.type)
	     = char_dtype) then do;
	    P_reference.symbol_ptr = null ();
	    P_reference.address_ptr = P_reference.address_ptr -> based_ptr;
	    P_reference.type = char_dtype;
	    P_reference.precision = 256;
	    P_reference.flags.packed = "1"b;
	    P_reference.flags.constant = "1"b;
	    P_reference.flags.c_ptr_to_char = "1"b;
	  end;
	  else do;
	    call probe_error_$record (probe_info_ptr, 0,
	         "The empty subscript is only valid for character array references^/using pointer values through one level of indirection."
	         );
	    goto RECORDED_MESSAGE;
	  end;
        end;
      else if (P_reference.type = char_dtype
	 & fixed (P_reference.symbol_ptr -> runtime_symbol.ndims) > 0)
        then do;
	P_reference.symbol_ptr = null ();
	P_reference.precision = 256;
	P_reference.flags.packed = "1"b;
	P_reference.flags.constant = "1"b;
        end;
      else do;
        call probe_error_$record (probe_info_ptr, 0,
	   "The empty subscript is only valid for character array references^/using pointer values through one level of indirection."
	   );
        goto RECORDED_MESSAGE;
      end;
      need_to_indirect_and_make_string = "0"b;
    end;

  return;

get_unqualified_c_reference:
  proc ();

  dcl temp_created		bit (1);
  dcl (t_ref, s_ptr)	ptr;
  dcl name_ptr_2		ptr;
  dcl old_addr		ptr;
  dcl offset_bits		fixed bin (6) unsigned;
  dcl offset_words		fixed bin (18) unsigned;

  call get_level ();

  temp_created = "0"b;
  old_addr = null ();

  do while (probe_info.ct -> token.type = PERIOD);

    if ^temp_created then do;
        call probe_create_reference_ (probe_info_ptr, t_ref);
        t_ref -> reference_node.optional_info.subscript_ptr =
	   P_reference.optional_info.subscript_ptr;
        t_ref -> reference_node.optional_info.argument_list =
	   P_reference.optional_info.argument_list;
        t_ref -> reference_node.optional_info.n_subscripts =
	   P_reference.optional_info.n_subscripts;
        t_ref -> reference_node.optional_info.n_arguments =
	   P_reference.optional_info.n_arguments;
        t_ref -> reference_node.subscript_refs_ptr =
	   P_reference.subscript_refs_ptr;
        temp_created = "1"b;
      end;

    t_ref -> reference_node.name = id_token;

    call probe_eval_$evaluate (probe_info_ptr, t_ref -> reference_node,
         (switches), want_value, code);

    if original_class = 0 & t_ref -> reference_node.symbol_ptr ^= null ()
      then
	 original_class =
	      convert (original_class,
	      t_ref -> reference_node.symbol_ptr
	      -> runtime_symbol.address.class);

    code = 0;

    if (old_addr = null ())
      then do;
        old_addr = t_ref -> reference_node.address_ptr;
        P_reference.address_ptr = old_addr;
      end;

    s_ptr = t_ref -> reference_node.symbol_ptr;

    if (s_ptr ^= null ()) then do;
        if fixed (s_ptr -> runtime_symbol.type) = c_typeref_dtype then do;
				/* typeref */
	  do while (fixed (s_ptr -> runtime_symbol.type) = c_typeref_dtype);
	    s_ptr = addrel (s_ptr, fixed (s_ptr -> runtime_symbol.son));
	  end;
	  P_reference.name =
	       substr (P_reference.name, 1,
	       length (P_reference.name) - length (id_token));
	  name_ptr_2 = addrel (s_ptr, fixed (s_ptr -> runtime_symbol.name));
	  P_reference.name =
	       substr (name_ptr_2 -> acc_str.str_name, 1,
	       name_ptr_2 -> acc_str.str_len);
	end;
      end;

    P_reference.name = P_reference.name || ".";
    call bump_ct ();
    if probe_info.ct -> token.type ^= NAME_TYPE then do;
        call probe_error_$record (probe_info_ptr, 0,
	   "A name must follow a ""."" in a structure qualified reference");
        goto RECORDED_MESSAGE;
      end;

    P_reference.optional_info.n_subscripts = 0;
    P_reference.optional_info.n_arguments = 0;

    call get_level ();

    call probe_eval_$evaluate (probe_info_ptr, P_reference, (switches),
         want_value, code);

    code = 0;

    s_ptr = P_reference.symbol_ptr;

    if s_ptr = null () then do;
        call probe_error_$record (probe_info_ptr, 0,
	   "Could not locate the symbol.");
        goto RECORDED_MESSAGE;
      end;
    if (^s_ptr -> runtime_symbol.bits.simple &
         s_ptr -> runtime_symbol.offset ^= 0) then do;
        offset_bits = convert (offset_bits, s_ptr -> runtime_symbol.offset);

        offset_words =
	   convert (offset_words, divide (offset_bits, 36, 17, 0));
        offset_bits = convert (offset_bits, mod (offset_bits, 36));
        addr (old_addr) -> its_unsigned.offset =
	   addr (old_addr) -> its_unsigned.offset + offset_words;
        addr (old_addr) -> its_unsigned.bit_offset =
	   addr (old_addr) -> its_unsigned.bit_offset + offset_bits;
      end;

    P_reference.address_ptr = old_addr;

    if (P_reference.n_subscripts > 0)
      then
	 call probe_eval_$add_c_dims (probe_info_ptr, P_reference,
	      (switches), "1"b, code, original_class);
  end;

  /* we are end of structure ref or simple ref */

  if probe_info.ct -> token.type = LEFT_BRACKET then do;
      call bump_ct ();

      call probe_get_$generation (probe_info_ptr, P_reference.source_info_ptr,
	 P_reference.invocation_level, code);
      if code ^= 0
        then goto SOME_ERROR;

      if probe_info.ct -> operator.type ^= RIGHT_BRACKET
        then do;
	call probe_error_$record (probe_info_ptr, 0,
	     "Syntax error in generation of ^a", P_reference.name);
	goto RECORDED_MESSAGE;
        end;

      P_reference.have_generation = "1"b;
      call bump_ct ();		/* past the ] */

    end;

  /* an arglist would go here */

  end get_unqualified_c_reference;

get_unqualified_reference:
  proc ();

  call get_level ();

  do while (probe_info.ct -> token.type = PERIOD);
    P_reference.name = P_reference.name || ".";
    call bump_ct ();
    if probe_info.ct -> token.type ^= NAME_TYPE then do;
        call probe_error_$record (probe_info_ptr, 0,
	   "A name must follow a ""."" in a structure qualified reference");
        goto RECORDED_MESSAGE;
      end;
    call get_level ();
  end;

  /* we are end of structure ref or simple ref */

  if probe_info.ct -> token.type = LEFT_BRACKET then do;
      call bump_ct ();

      call probe_get_$generation (probe_info_ptr, P_reference.source_info_ptr,
	 P_reference.invocation_level, code);
      if code ^= 0
        then goto SOME_ERROR;

      if probe_info.ct -> operator.type ^= RIGHT_BRACKET
        then do;
	call probe_error_$record (probe_info_ptr, 0,
	     "Syntax error in generation of ^a", P_reference.name);
	goto RECORDED_MESSAGE;
        end;

      P_reference.have_generation = "1"b;
      call bump_ct ();		/* past the ] */

    end;

  /* an arglist would go here */

  if make_lower
    then P_reference.name = translate (P_reference.name, LOWER, UPPER);
  end get_unqualified_reference;


get_level:
  proc ();

  id_ptr = probe_info.ct;

  if length (P_reference.name) + length (identifier_tokens_name)
       > maxlength (P_reference.name)
    then call disgruntled (probe_et_$too_long);

  P_reference.name = P_reference.name || identifier_tokens_name;
  call bump_ct ();

  if probe_info.ct -> token.type = LEFT_PAREN
    then call get_parens;
  else if (probe_info.ct -> token.type = LEFT_BRACKET &
       probe_info.language_type = C_lang_type)
    then
         call get_c_brackets ();

  end get_level;

  end parse_normal;
%page;
qualifier_name:
  proc (P_ptr) returns (char (256) varying);

  dcl (P_ptr, p)		ptr;
  dcl name		char (256) varying;


  p = P_ptr;
  name = addrel (p, p -> runtime_symbol.name) -> acc.string;
  do while (fixed (p -> runtime_symbol.level, 6) > 1);
				/* print fathers */
    p = addrel (p, p -> runtime_symbol.father);
    name = addrel (p, p -> runtime_symbol.name) -> acc.string || "." || name;
  end;
  return (name);

  end qualifier_name;
%page;
parse_ala_cobol:
  proc;


  P_reference.name = identifier_tokens_name;
  call bump_ct ();			/* past the name */
  do while (cobol_connector ((probe_info.ct)));
    call bump_ct ();
    if probe_info.ct -> token.type ^= NAME_TYPE then do;
        call probe_error_$record (probe_info_ptr, 0,
	   "Syntax error - a name is needed after ""of"" or ""in""");
        goto RECORDED_MESSAGE;
      end;

    if length (P_reference.name) + length (".")
         + length (identifier_tokens_name) >
         maxlength (P_reference.name)
      then call disgruntled (probe_et_$too_long);

    P_reference.name = "." || P_reference.name;
    P_reference.name = identifier_tokens_name || P_reference.name;

    call bump_ct ();		/* past the name */

  end;				/* do-while comma loop */

  P_reference.name = translate (P_reference.name, LOWER, UPPER);

  if probe_info.ct -> token.type = LEFT_PAREN then do;
      call bump_ct ();		/* past the ( */
      call get_dim ();		/* first subscript */
      do while (probe_info.ct -> token.type = COMMA);
        call bump_ct ();
        call get_dim ();
      end;

      if probe_info.ct -> token.type ^= RIGHT_PAREN then do;
	call probe_error_$record (probe_info_ptr, 0,
	     "Syntax error in subscript list");
	goto RECORDED_MESSAGE;
        end;
      call bump_ct ();
    end;				/* subscript hacking */
  call probe_eval_$evaluate (probe_info_ptr, P_reference, (switches),
       want_value, code);
  end parse_ala_cobol;
%page;
parse_ala_pascal:
  proc;				/* parse a PASCAL REF */

  /* This procedure parses reference to a PASCAL variable and to a PASCAL constant set.
   It works as the compiler works: If the reference is composed of more than
   one symbol, it looks for the first name in the symbol table (done in probe_eval_)
   and after, uses the attributes of this symbol to analyse the following symbols.
   No abbreviation (as in PL/1, where reference to a field of a record may
   be sufficient) is allowed: "v a" trying to get the value of "b.a"
   will return "symbol a not declared" ("not found" would be better..).
   excepted if we are in a "with b" block..

*/
  dcl based_ptr		pointer based;
  dcl based_packed_ptr	pointer unal based;

  dcl size		builtin;
  dcl (first_ref, next_ref,
      first_type_ptr, next_type_ptr)
			ptr;
  dcl (first_type, next_type,
      first_value, next_value)
			fixed bin (35);
  dcl field_ptr		ptr;
  dcl got_args		bit (1) init ("0"b);
  dcl (Block_ptr,
      Base_addr,
      Linkage_ptr,
      Stack_ptr)		ptr;
  dcl 1 type_info		like runtime_type_info;
  dcl (low, mult, new_high, new_low)
			fixed bin (35);
  dcl probe_pascal_$real_type entry (fixed bin (35), ptr, fixed bin (35), ptr)
			;
  dcl stu_$find_runtime_symbol
			entry (ptr, char (*) aligned, ptr, fixed bin)
			returns (ptr);
  dcl probe_pascal_$indice_id entry (fixed bin (35), ptr, fixed bin (35))
			returns (char (32) varying);
  dcl probe_pascal_$indice_value
			entry (ptr, ptr, fixed bin (35), fixed bin (35),
			ptr, fixed bin (35));
  dcl probe_invoke_$function	entry (ptr, 1 aligned like reference_node,
			1 aligned like reference_node);
  dcl subp		ptr;
  dcl found_ptr		ptr;
  dcl steps		fixed bin;
  dcl new_name		char (32) varying;
  dcl element_name		char (256) varying;
  dcl i			fixed bin;
  dcl bit_offset		fixed bin (35);
  dcl current_indice	fixed bin;
  dcl array_type_ptr	ptr;
  dcl 1 p			based,
       2 p1		bit (30) unal,
       2 ftag		bit (6) unal,
       2 p2		bit (36) unal;


  type_info.version = RUNTIME_TYPE_INFO_VERSION_1;
  if probe_info.ct -> token.type = CONSTANT_TYPE then do;
      P_reference.constant = "1"b;
      P_reference.constant_token_ptr = probe_info.ct;
      P_reference.name = "<<constant>>";/* should be smart and get name ! */
      call bump_ct ();
      call probe_eval_$evaluate (probe_info_ptr, P_reference, (switches),
	 want_value, code);
      if current_token.type = ARROW
        then
	   if P_reference.type = pointer_dtype
	     then
		if probe_info.execute
		  then go to arrow_found_execute;
		  else go to arrow_found_check;
      goto SOME_ERROR;
    end;

  if ^probe_info.execute then do;	/* just probe syntax checking */
      if current_token.type = NAME_TYPE then do;
				/* PASCAL identifier */
	P_reference.name = identifier_tokens_name;
	call bump_ct ();
	if current_token.type = LEFT_PAREN then do;
	    call get_parens;
	    got_args = "1"b;
	  end;
	call probe_eval_$evaluate (probe_info_ptr, P_reference, (switches),
	     want_value, code);
	if code ^= 0
	  then go to SOME_ERROR;
continue_to_check:
	if ^got_args then do;
	    if current_token.type = LEFT_PAREN then do;
	        call get_parens;
	        got_args = "1"b;
	      end;
	  end;
	if got_args
	  then go to end_of_parsing;
	;			/* no more after parens */
	if current_token.type = LEFT_BRACKET then do;
next_indice:
	    call probe_pascal_$indice_value (probe_info_ptr, next_ref,
	         next_value, next_type,
	         next_type_ptr, code);
	    if code ^= 0
	      then go to SOME_ERROR;
	    if current_token.type = COMMA then do;
	        call bump_ct ();
	        go to next_indice;
	      end;
	    if current_token.type ^= LEFT_BRACKET then do;
	        call probe_error_$record (probe_info_ptr, 0,
		   "Syntax error in array indices : Comma or left bracket expected."
		   );
	        go to RECORDED_MESSAGE;
	      end;
	    call bump_ct ();
	    go to continue_to_check;
	  end;
	if (current_token.type = PASCAL_ARROW) |
	     (current_token.type = ARROW) then do;
arrow_found_check:
	    call bump_ct ();
	    go to continue_to_check;
	  end;
	if current_token.type = PERIOD then do;
	    call bump_ct ();
	    if current_token.type ^= NAME_TYPE then do;
	        call probe_error_$record (probe_info_ptr, 0,
		   "Syntax error : Field name expected after period.");
	        go to RECORDED_MESSAGE;
	      end;
	    call bump_ct ();
	    go to continue_to_check;
	  end;
        end;
      else if current_token.type = LEFT_BRACKET then do;
				/* set */
next_elem:
	call probe_pascal_$indice_value (probe_info_ptr, next_ref,
	     next_value, next_type,
	     next_type_ptr, code);
	if code ^= 0
	  then go to SOME_ERROR;
	if current_token.type = COMMA then do;
	    call bump_ct ();
	    go to next_elem;
	  end;
	if current_token.type ^= LEFT_BRACKET then do;
	    call probe_error_$record (probe_info_ptr, 0,
	         "Syntax error in set value : Comma or left bracket expected."
	         );
	    go to RECORDED_MESSAGE;
	  end;
	call bump_ct ();
        end;
    end;

  else if current_token.type = NAME_TYPE then do;
      P_reference.name = identifier_tokens_name;
      call bump_ct ();

      if current_token.type = LEFT_PAREN then do;
	call get_parens;
	got_args = "1"b;
        end;

      call probe_eval_$evaluate (probe_info_ptr, P_reference, (switches),
	 want_value, code);
      if code ^= 0
        then go to SOME_ERROR;
      if P_reference.builtin | P_reference.function then do;
	got_args = "0"b;
	P_reference.n_subscripts = 0;
        end;

      Block_ptr = P_reference.source_info_ptr -> source_info.block_ptr;
      Stack_ptr = P_reference.source_info_ptr -> source_info.stack_ptr;
      Linkage_ptr =
	 P_reference.source_info_ptr -> source_info.seg_info_ptr
	 -> seg_info.linkage_ptr;
      Base_addr = P_reference.base_addr;

continue_to_parse:
      if ^got_args then do;
	if current_token.type = LEFT_PAREN then do;
	    call get_parens;
	    got_args = "1"b;
	  end;
        end;
      if got_args
        then
	   if P_reference.type_ptr ^= null then do;

	       type_info.version = RUNTIME_TYPE_INFO_VERSION_1;

	       call runtime_symbol_info_$type (P_reference.type_ptr,
		  addr (type_info), code);
	       if code ^= 0
	         then go to SOME_ERROR;

	       if type_info.type ^= pascal_procedure_type_dtype
	         then go to not_a_proc;
	       if type_info.base_type ^= 0 then do;
				/* function */
		 if want_value then do;
				/* evaluate it */
		     call probe_invoke_$function (probe_info_ptr,
			P_reference, P_reference);
		   end;
		 P_reference.symbol_ptr = null;
		 P_reference.type = type_info.base_type;
		 P_reference.type_ptr = type_info.base_type_addr;
		 P_reference.precision = type_info.size;
	         end;
	       got_args = "0"b;
	     end;
	     else do;
not_a_proc:
	       call probe_error_$record (probe_info_ptr, 0,
		  "^a is not a procedure.", P_reference.name);
	       go to RECORDED_MESSAGE;
	     end;
      if current_token.type = LEFT_BRACKET then do;
				/* array indices */
	call bump_ct ();
	if P_reference.type_ptr ^= null then do;
	    if P_reference.type_ptr -> pascal_symbol_node_header.array_info
	      then do;
	        n_dims =
		   runtime_symbol_info_$array_dims (P_reference.type_ptr);
	        P_reference.packed =
		   P_reference.type_ptr
		   -> pascal_symbol_node_header.packed;
	        bit_offset = 0;
	        element_name = P_reference.name;
	        P_reference.cross_section =
		   is_cross_section ((probe_info.ct));
	        if P_reference.cross_section
		then P_reference.n_subscripts,
			P_reference.n_arguments, ref_subscripts.number =
			0;
	        do;
		dcl 1 array_info	        like runtime_array_info;
		array_info.version = RUNTIME_ARRAY_INFO_VERSION_1;
		array_type_ptr = P_reference.type_ptr;
		current_indice = 0;
continue_subarray:
		if P_reference.cross_section
		  then P_reference.n_subscripts,
			  P_reference.n_arguments,
			  ref_subscripts.number =
			  ref_subscripts.number + n_dims;
		call runtime_symbol_info_$array (array_type_ptr,
		     addr (array_info), code);
		if code ^= 0
		  then go to SOME_ERROR;
		do i = 1 to n_dims;
		  if P_reference.cross_section then do;
		      call probe_create_reference_ (probe_info_ptr, subp);
		      sub_refs.ptr (1, i + current_indice) = subp;
		      if current_token.type = TIMES then do;
				/* star extent */
			subp -> subscript.flags.star_extent = "1"b;
			subp -> subscript.name =
			     "<<star extent low bound>>";
			call probe_create_reference_ (probe_info_ptr,
			     subp);
			sub_refs.ptr (2, i + current_indice) = subp;
			subp -> subscript.flags.star_extent = "1"b;
			subp -> subscript.name =
			     "<<star extent high bound>>";
			ref_subscripts.value (1, i + current_indice) =
			     decode (array_info.bounds (i).lower,
			     array_info.bounds (i).lower_is_encoded,
			     P_reference.type_ptr);
			ref_subscripts.value (2, i + current_indice) =
			     decode (array_info.bounds (i).upper,
			     array_info.bounds (i).upper_is_encoded,
			     P_reference.type_ptr);
			call bump_ct ();
			go to next_dim;
		        end;
		    end;
		  call get_indice_value ();
		  if P_reference.cross_section then do;
		      subp -> reference_node = next_ref -> reference_node;
		      new_low = next_value;
		      if current_token.type = COLON then do;
			call bump_ct ();
			call get_indice_value ();
			call probe_create_reference_ (probe_info_ptr,
			     subp);
			sub_refs.ptr (2, i + current_indice) = subp;
			subp -> reference_node =
			     next_ref -> reference_node;
			new_high = next_value;
			if new_high < new_low then do;
			    call probe_error_$record (probe_info_ptr, 0,
			         "Invalid range specification ^a..^a",
			         probe_pascal_$indice_id (array_info (i)
			         .subscript_type,
			         array_info (i).subscript_type_addr,
			         new_low),
			         probe_pascal_$indice_id (array_info (i)
			         .subscript_type,
			         array_info (i).subscript_type_addr,
			         new_high));
			    go to RECORDED_MESSAGE;
			  end;
		        end;
		        else do;
			new_high = new_low;
			sub_refs.ptr (2, i + current_indice) = null;
		        end;
		      ref_subscripts.value (1, i + current_indice) =
			 new_low;
		      ref_subscripts.value (2, i + current_indice) =
			 new_high;
		    end;
		    else do;
		      mult =
			 convert_units (mult, (array_info.array_units));
		      bit_offset = bit_offset + mult * (next_value - low);
		    end;
		  new_name =
		       probe_pascal_$indice_id (array_info.bounds (i)
		       .subscript_type,
		       array_info.bounds (i).subscript_type_addr,
		       next_value);
		  if length (element_name) + 1 + length (new_name) >
		       maxlength (element_name)
		    then call disgruntled (probe_et_$too_long);
		  if i = 1
		    then element_name = element_name || "[" || new_name;
		    else element_name = element_name || "," || new_name;
next_dim:
		  if i = n_dims then do;
		      if current_token.type = RIGHT_BRACKET then do;
			call bump_ct ();
			if length (element_name)
			     = maxlength (element_name)
			  then
			       call disgruntled (probe_et_$too_long);
			if ^P_reference.cross_section
			  then P_reference.name = element_name || "]";
		        end;
		        else do;
			call probe_error_$record (probe_info_ptr, 0,
			     "Right bracket expected after ""^a""",
			     element_name);
			go to RECORDED_MESSAGE;
		        end;
		    end;
		    else do;
		      if current_token.type = COMMA then do;
			call bump_ct ();
		        end;
		        else do;
			call probe_error_$record (probe_info_ptr, 0,
			     "Comma expected after ""^a""",
			     element_name);
			go to RECORDED_MESSAGE;
		        end;
		    end;
		end;


get_indice_value:
  proc;


  call probe_pascal_$indice_value (probe_info_ptr, next_ref, next_value,
       next_type,
       next_type_ptr, code);
  if code ^= 0
    then go to SOME_ERROR;
  call probe_pascal_$real_type (array_info.bounds (i).subscript_type,
       array_info.bounds (i).subscript_type_addr,
       array_info.bounds (i).subscript_type,
       array_info.bounds (i).subscript_type_addr);
  if next_type ^= array_info.bounds (i).subscript_type
       | next_type_ptr ^= array_info.bounds (i).subscript_type_addr then do;
      call probe_error_$record (probe_info_ptr, 0,
	 "Incorrect type of value in array indices.");
      go to RECORDED_MESSAGE;
    end;
  low = decode (array_info.bounds (i).lower,
       array_info.bounds (i).lower_is_encoded, P_reference.type_ptr);
  mult = decode (array_info.bounds (i).multiplier,
       array_info.bounds (i).multiplier_is_encoded, P_reference.type_ptr);
  if next_value < low | next_value > decode (array_info.bounds (i).upper,
       array_info.bounds (i).upper_is_encoded, P_reference.type_ptr) then do;
      call probe_error_$record (probe_info_ptr, 0,
	 "Array indice out of bounds.");
      go to RECORDED_MESSAGE;
    end;
  end get_indice_value;

	        end;
	        if ^P_reference.cross_section then do;
		  P_reference.address_ptr =
		       bitrel (P_reference.address_ptr, bit_offset);

		  type_info.version = RUNTIME_TYPE_INFO_VERSION_1;

		  call runtime_symbol_info_$type (P_reference.type_ptr,
		       addr (type_info), code);
		  if code ^= 0
		    then go to SOME_ERROR;

		  P_reference.type = type_info.base_type;
		  P_reference.type_ptr = type_info.base_type_addr;
		  P_reference.precision = type_info.size;
		end;
		else do;
		  if (current_token.type = PASCAL_ARROW)
		       | (current_token.type = LEFT_PAREN)
		       | (current_token.type = PERIOD) then do;
no_more_specs:
		      call probe_error_$record (probe_info_ptr, 0,
			 "No more specification allowed after subarray description."
			 );
		      go to RECORDED_MESSAGE;
		    end;
		  if current_token.type = LEFT_BRACKET then do;
		      call bump_ct ();
		      call runtime_symbol_info_$type (array_type_ptr,
			 addr (type_info), code);
		      if code ^= 0
		        then go to SOME_ERROR;
		      array_type_ptr = type_info.base_type_addr;
		      current_indice = current_indice + n_dims;
		      if array_type_ptr ^= null
		        then
			   n_dims =
			        runtime_symbol_info_$array_dims (
			        array_type_ptr);
		        else n_dims = 0;
		      if n_dims = 0
		        then go to no_more_specs;
		        else go to continue_subarray;
		    end;
		end;
	        go to continue_to_parse;
	      end;
	      else go to not_an_array;
	  end;
	  else do;
not_an_array:
	    call probe_error_$record (probe_info_ptr, 0,
	         "^a is not an array", P_reference.name);
	    go to RECORDED_MESSAGE;
	  end;
        end;
      if probe_info.ct -> token.type = ARROW then do;
arrow_found_execute:
	if P_reference.type ^= pointer_dtype /* probe pointer variable */
	  then do;
	    if P_reference.type ^= pascal_user_defined_type_instance_dtype
	      then do;
bad_locator:
	        call probe_error_$record (probe_info_ptr, 0,
		   "Given locator is not a pointer.");
	        go to RECORDED_MESSAGE;
	      end;
	    type_info.version = RUNTIME_TYPE_INFO_VERSION_1;
	    call runtime_symbol_info_$type (P_reference.type_ptr,
	         addr (type_info), code);
	    if code ^= 0
	      then go to SOME_ERROR;
	    if type_info.type ^= pascal_typed_pointer_type_dtype
	      then go to bad_locator;
	  end;
	if P_reference.address_ptr ^= null
	  then
	       if want_value then do;
		 if ((P_reference.type = pointer_dtype)
		      & (P_reference.packed)) |
		      (P_reference.precision = 36)
		   then
		        P_reference.address_ptr =
			   P_reference.address_ptr -> based_packed_ptr;
		   else
		        P_reference.address_ptr =
			   P_reference.address_ptr -> based_ptr;
		 if P_reference.address_ptr = null then do;
		     call probe_error_$record (probe_info_ptr, 0,
			"Given locator is null.");
		     go to RECORDED_MESSAGE;
		   end;
	         end;
	call bump_ct ();
	if current_token.type ^= NAME_TYPE then do;
	    call probe_error_$record (probe_info_ptr, 0,
	         "Type identifier expected after arrow.");
	    go to RECORDED_MESSAGE;
	  end;
	P_reference.type_ptr =
	     stu_$find_runtime_symbol (Block_ptr, (current_identifier_name),
	     found_ptr, steps);
	if P_reference.type_ptr = null then do;
	    if current_identifier_name = "integer" then do;
	        P_reference.type = pascal_integer_dtype;
	        P_reference.precision = 35;
	      end;
	    else if current_identifier_name = "real" then do;
	        P_reference.type = pascal_real_dtype;
	        P_reference.precision = 63;
	      end;
	    else if current_identifier_name = "boolean" then do;
	        P_reference.type = pascal_boolean_dtype;
	        P_reference.precision = 36;
	      end;
	    else if current_identifier_name = "char" then do;
	        P_reference.type = pascal_char_dtype;
	        P_reference.precision = 36;
	      end;
	    else do;
	      call probe_error_$record (probe_info_ptr, 0,
		 "Symbol ^a not found.", current_identifier_name);
	      go to RECORDED_MESSAGE;
	    end;
	  end;
	  else do;
	    call runtime_symbol_info_$type (P_reference.type_ptr,
	         addr (type_info), code);
	    if code ^= 0
	      then go to SOME_ERROR;
	    if (type_info.type = pascal_typed_pointer_type_dtype)
	         | (type_info.type = pascal_user_defined_type_dtype)
	         | (type_info.type = pascal_set_dtype)
	         | (type_info.type = pascal_record_type_dtype)
	         | (type_info.type = pascal_record_file_type_dtype) then do;
	        P_reference.type = pascal_user_defined_type_instance_dtype;
	        if type_info.type = pascal_typed_pointer_type_dtype
		then
		     P_reference.precision = 72;
				/* supposed non packed */
		else P_reference.precision = 0;
	      end;
	    else if type_info.type = pascal_enumerated_type_dtype then do;
	        P_reference.type = pascal_enumerated_type_instance_dtype;
	        P_reference.precision = 36;
	      end;
	    else do;
	      call probe_error_$record (probe_info_ptr, 0,
		 "^a is not a type.", current_identifier_name);
	      go to RECORDED_MESSAGE;
	    end;
	  end;
	P_reference.name = "(" || current_identifier_name || ")";
	P_reference.symbol_ptr = null;
	call bump_ct ();
	go to continue_to_parse;
        end;
      else
	 if current_token.type = PASCAL_ARROW then do;
	if P_reference.type_ptr ^= null then do;
	    if P_reference.type_ptr -> pascal_symbol_node_header.type =
	         pascal_typed_pointer_type_dtype then do;
				/* variable pointer */
	        if P_reference.address_ptr ^= null
		then
		     if want_value then do;
		         if P_reference.precision = 36
			 then
			      P_reference.address_ptr =
				 P_reference.address_ptr
				 -> based_packed_ptr;
			 else
			      P_reference.address_ptr =
				 P_reference.address_ptr -> based_ptr;
		         if P_reference.address_ptr = null then do;
			   call probe_error_$record (probe_info_ptr, 0,
			        "Pointer ^a is null.", P_reference.name)
			        ;
			   go to RECORDED_MESSAGE;
			 end;
		       end;

	        call runtime_symbol_info_$type (P_reference.type_ptr,
		   addr (type_info), code);
	        if code ^= 0
		then go to SOME_ERROR;

	        P_reference.symbol_ptr = null;
	        P_reference.type = type_info.base_type;
	        P_reference.type_ptr = type_info.base_type_addr;
	        P_reference.precision = type_info.size;
	        P_reference.name = P_reference.name || "^";
	        call bump_ct ();
	        go to continue_to_parse;
	      end;
	    else if P_reference.type_ptr -> pascal_symbol_node_header.type =
	         pascal_record_file_type_dtype then do;
				/* file window */

	        type_info.version = RUNTIME_TYPE_INFO_VERSION_1;

	        call runtime_symbol_info_$type (P_reference.type_ptr,
		   addr (type_info), code);
	        if code ^= 0
		then go to SOME_ERROR;

	        P_reference.type = type_info.base_type;
	        P_reference.type_ptr = type_info.base_type_addr;
	        go to file_window_join;
	      end;
	    else go to not_a_ptr;
	  end;
	else if P_reference.type = pascal_text_file_dtype then do;
				/* text file window */
	    P_reference.type = pascal_char_dtype;
	    P_reference.precision = 36;
	    P_reference.type_ptr = null;
file_window_join:
	    P_reference.symbol_ptr = null;
	    P_reference.name = P_reference.name || "^";
	    if P_reference.address_ptr ^= null then do;
	        if P_reference.address_ptr -> p.ftag ^= "43"b3
		   | P_reference.address_ptr -> based_ptr = null
		then
		     P_reference.address_ptr = null;
		else
		     P_reference.address_ptr =
			addrel (P_reference.address_ptr -> based_ptr,
			window_place_in_pascal_fsb);
	      end;
	    call bump_ct ();
	    go to continue_to_parse;
	  end;
	else do;
not_a_ptr:
	  call probe_error_$record (probe_info_ptr, 0,
	       "^a is neither a file nor a typed pointer.",
	       P_reference.name);
	  go to RECORDED_MESSAGE;
	end;
        end;
      if current_token.type = PERIOD then do;
				/* PASCAL field expected */
	call bump_ct ();
	if current_token.type ^= NAME_TYPE then do;
no_field_name:
	    call probe_error_$record (probe_info_ptr, 0,
	         "A field name must follow the "".""");
	    go to RECORDED_MESSAGE;
	  end;
	if P_reference.type_ptr ^= null then do;
	    if P_reference.type_ptr -> pascal_symbol_node_header.type
	         = pascal_record_type_dtype then do;
	        field_ptr = runtime_symbol_info_$son (P_reference.type_ptr);
	        call scan_record (field_ptr, (want_value));
	      end;
	      else go to not_a_record;
	  end;
	else if P_reference.type = pascal_record_type_dtype then do;
	    field_ptr = runtime_symbol_info_$son (P_reference.symbol_ptr);
	    call scan_record (field_ptr, "0"b);
	  end;
	else do;
not_a_record:
	  call probe_error_$record (probe_info_ptr, 0,
	       "^a is not a record", P_reference.name);
	  go to RECORDED_MESSAGE;
	end;
	call probe_error_$record (probe_info_ptr, 0,
	     "^a is not a field of ^a", identifier_tokens_name,
	     P_reference.name);
	go to RECORDED_MESSAGE;
        end;			/* field of record */
    end;				/* identifier */

  else if current_token.type = LEFT_BRACKET then do;
				/* PASCAL set */
      P_reference.type = pascal_user_defined_type_instance_dtype;
      allocate pascal_symbol_node_header in (expression_area)
	 set (P_reference.type_ptr);
      unspec (P_reference.type_ptr -> pascal_symbol_node_header) = "0"b;
      P_reference.type_ptr -> pascal_symbol_node_header.type =
	 pascal_set_dtype;
      allocate pascal_set in (expression_area) set (P_reference.address_ptr);
      P_reference.precision = size (pascal_set);
      P_reference.packed = "0"b;
      P_reference.name = "<<set>>";
      P_reference.descriptor = 0;

      P_reference.address_ptr -> pascal_set = "0"b;

      call bump_ct ();

      if current_token.type = RIGHT_BRACKET then do;
				/* empty set */
	call bump_ct ();
	go to end_of_parsing;
        end;

      call probe_pascal_$indice_value (probe_info_ptr, first_ref, first_value,
	 first_type, first_type_ptr, code);
      if code ^= 0
        then go to SOME_ERROR;
      call fill_set (first_value, first_ref);

      do while (current_token.type = COMMA);
        call bump_ct ();
        call probe_pascal_$indice_value (probe_info_ptr, next_ref, next_value,
	   next_type,
	   next_type_ptr, code);
        if code ^= 0
	then go to SOME_ERROR;
        if (first_type ^= next_type)
	   | (first_type_ptr ^= next_type_ptr) then do;
	  call probe_error_$record (probe_info_ptr, 0,
	       "Types of elements of set do not match.");
	  go to RECORDED_MESSAGE;
	end;
        call fill_set (next_value, next_ref);
      end;

      if current_token.type ^= RIGHT_BRACKET then do;
	call probe_error_$record (probe_info_ptr, 0,
	     "Error in set description.");
	go to RECORDED_MESSAGE;
        end;

      call bump_ct ();
      go to end_of_parsing;
    end;				/* PASCAL <<set>> */

end_of_parsing:
  return;
%page;
  /* Procedures internal to parse_ala_pascal */

bitrel:
  proc (P_ptr, P_bit_offset) returns (ptr);
  dcl P_ptr		ptr parameter;
  dcl P_bit_offset		fixed bin (35) parameter;

  dcl 1 str		unaligned based (P_ptr),
       2 filler		unal bit (P_bit_offset),
       2 target		unal bit (1);

  if P_bit_offset < 0
    then return (null);
  return (addr (str.target));

  end bitrel;


convert_units:
  proc (value, unit_code) returns (fixed bin (35));

  dcl value		fixed bin (35) parameter;
				/* offset in raw */
  dcl unit_code		fixed bin (2) parameter unsigned;


  goto units_case (unit_code);

units_case (0):
  return (value * bits_per_word);	/* word */
units_case (1):
  return (value);			/* bit */
units_case (2):
  return (value * bits_per_character);	/* char */
units_case (3):
  return (value * bits_per_half);	/* halfword */

  end convert_units;


decode:
  proc (value, encoded, symbp) returns (fixed bin (35));

  dcl value		fixed bin (35);
  dcl encoded		bit (1);
  dcl symbp		ptr;

  dcl ptr			builtin;
  dcl stu_$decode_runtime_value_extended
			entry (fixed bin (35), ptr, ptr, ptr, ptr, ptr,
			ptr, fixed bin (35)) returns (fixed bin (35));
  dcl result		fixed bin (35);

  if ^encoded
    then return (value);
    else do;
      result =
	 stu_$decode_runtime_value_extended (value, Block_ptr, Stack_ptr,
	 Linkage_ptr,
	 ptr (Block_ptr, 0), Base_addr, symbp, code);
      if code ^= 0
        then go to SOME_ERROR;
      return (result);
    end;

  end decode;


fill_set:
  proc (val, ref_ptr);

  dcl val			fixed bin (35);
  dcl ref_ptr		ptr;

  if val >= pascal_max_set_size then do;
      call probe_error_$record (probe_info_ptr, 0,
	 "Value of ^a is out of PASCAL set range.",
	 ref_ptr -> reference_node.name);
      go to RECORDED_MESSAGE;
    end;
  substr (P_reference.address_ptr -> pascal_set, val + 1, 1) = "1"b;

  end fill_set;


is_cross_section:
  proc (P_ct) returns (bit (1));

  dcl (P_ct, ct)		ptr;

  do ct = P_ct repeat (ct -> current_token.next) while (ct ^= null);
    if ct -> current_token.type = RIGHT_BRACKET
      then return ("0"b);
    if ct -> current_token.type = C_INDIRECTION
         | ct -> current_token.type = TIMES | ct -> current_token.type = COLON
      then return ("1"b);
  end;
  return ("0"b);

  end is_cross_section;


scan_record:
  proc (FIELD_PTR, EXECUTE);

  dcl FIELD_PTR		ptr;
  dcl EXECUTE		bit (1);

  dcl prev_ptr		ptr;
  dcl i			fixed bin;

  prev_ptr = null;
  call scan_fields (FIELD_PTR);
  if prev_ptr ^= null then do;
      n_variants = runtime_symbol_info_$n_variants (prev_ptr);
      if n_variants ^= 0
        then
	begin;
	dcl 1 variant_info	        like runtime_variant_info;

	variant_info.version = RUNTIME_VARIANT_INFO_VERSION_1;

	call runtime_symbol_info_$variant (prev_ptr, addr (variant_info),
	     code);
	if code ^= 0
	  then go to SOME_ERROR;

	do i = 1 to n_variants;
	  call scan_record (variant_info.case (i).brother_addr, EXECUTE);
	end;
        end;
    end;
  return;

scan_fields:
  proc (FIELD_P);

  dcl FIELD_P		ptr;

  dcl name_ptr		ptr;
  dcl 1 type_info		like runtime_type_info;
  dcl 1 address_info	like runtime_address_info;

  do while (FIELD_P ^= null);
    name_ptr = runtime_symbol_info_$name (FIELD_P);
    if name_ptr ^= null then do;
        if name_ptr -> acc.string = identifier_tokens_name then do;
	  if (length (P_reference.name) + 1 + name_ptr -> acc.num_chars) >
	       maxlength (P_reference.name)
	    then call disgruntled (probe_et_$too_long);
	  P_reference.name =
	       P_reference.name || "." || identifier_tokens_name;

	  type_info.version = RUNTIME_TYPE_INFO_VERSION_1;

	  call runtime_symbol_info_$type (FIELD_P, addr (type_info), code);
	  if code ^= 0
	    then go to SOME_ERROR;

	  if EXECUTE then do;

	      address_info.version = RUNTIME_ADDRESS_INFO_VERSION_1;

	      call runtime_symbol_info_$address (FIELD_P,
		 addr (address_info), code);
	      if code ^= 0
	        then go to SOME_ERROR;

	      P_reference.address_ptr = bitrel (P_reference.address_ptr,
		 convert_units (
		 decode (address_info.offset,
		 address_info.offset_is_encoded, FIELD_P),
		 bin (address_info.units, 2)));
	    end;
	  P_reference.type = type_info.type;
	  P_reference.type_ptr = type_info.type_addr;
	  P_reference.packed = type_info.packed;
	  P_reference.precision = type_info.size;
	  P_reference.symbol_ptr = FIELD_P;
	  call bump_ct ();
	  go to continue_to_parse;
	end;
      end;
    prev_ptr = FIELD_P;
    FIELD_P = runtime_symbol_info_$brother (FIELD_P);
  end;
  end scan_fields;

  end scan_record;

  end parse_ala_pascal;
%page;
  /* COMMON SUBROUTINES FOR DIFFERENT STYLES OF PARSING */

add:
  proc (P_str);

  dcl P_str		char (*);

  if length (P_reference.name) + length (P_str) > maxlength (P_reference.name)
    then
         call disgruntled (probe_et_$too_long);

  P_reference.name = P_reference.name || P_str;

  end add;


get_dim:
  proc;

  /* we parse a dim - that may be

   DIM ::= expression | expression:expression | *

   global import P_reference, sub_refs, ct

*/

  dcl subp		ptr;
  dcl sub_no		fixed bin;

  if P_reference.n_subscripts >= hbound (sub_refs.ptr, 2)
    then call disgruntled (probe_et_$dim_limit);

  sub_no, P_reference.n_subscripts = P_reference.n_subscripts + 1;
  P_reference.n_arguments = P_reference.n_arguments + 1;

  call probe_create_reference_ (probe_info_ptr, subp);
  sub_refs.ptr (1, sub_no) = subp;

  if (ct -> token.type = TIMES | ct -> token.type = C_INDIRECTION)
       & ^P_reference.path then do;
				/* star extent */
      subp -> subscript.flags.star_extent = "1"b;
      subp -> subscript.name = "<<star extent low bound>>";
      call probe_create_reference_ (probe_info_ptr, subp);
      sub_refs.ptr (2, sub_no) = subp;
      subp -> subscript.flags.star_extent = "1"b;
      subp -> subscript.name = "<<star extent high bound>>";
      call bump_ct ();
      P_reference.cross_section = "1"b;
    end;

    else do;
      call probe_get_$expression (probe_info_ptr, subp -> reference_node,
	 code);
      if code ^= 0
        then goto SOME_ERROR;

      if probe_info.ct -> operator.type = COLON then do;
	call probe_create_reference_ (probe_info_ptr, subp);
	sub_refs.ptr (2, sub_no) = subp;
	call bump_ct ();
	call probe_get_$expression (probe_info_ptr, subp -> reference_node,
	     code);
	if code ^= 0
	  then goto SOME_ERROR;
	P_reference.cross_section = "1"b;
        end;
        else sub_refs.ptr (2, sub_no) = null ();
    end;				/* non-* case */

  end get_dim;


get_parens:
  proc ();

  call bump_ct ();			/* past the ( */
  if probe_info.ct -> operator.type = RIGHT_PAREN then do;
				/* () */
      call bump_ct ();
      P_reference.function = "1"b;	/* it is () */
    end;
    else do;
      call get_dim ();		/* first subscript */
      do while (probe_info.ct -> token.type = COMMA);
				/* DO=UNTIL */
        call bump_ct ();		/* past comma, or first paren */
        call get_dim ();
      end;			/* do until no comma loop */

      if probe_info.ct -> operator.type ^= RIGHT_PAREN then do;
	call probe_error_$record (probe_info_ptr, 0,
	     "Syntax error in subscript/argument list");
	goto RECORDED_MESSAGE;
        end;
      call bump_ct ();		/* past  the ) */
    end;				/* non - null subscript/arg list loop */

  end get_parens;


get_c_brackets:
  proc ();

  dcl not_end_of_dims	bit (1);


  call bump_ct ();			/* past the [ */
				/* One empty subscript is allowed if the symbol is a char ptr in C */
  if (probe_info.ct -> token.type = RIGHT_BRACKET)
    then
         need_to_indirect_and_make_string = "1"b;
    else call get_dim ();
  not_end_of_dims = "1"b;
  do while (not_end_of_dims);
    if (probe_info.ct -> token.type = RIGHT_BRACKET) then do;
        call bump_ct ();
        if (probe_info.ct -> token.type = LEFT_BRACKET) then do;
	  call bump_ct ();
	  if (probe_info.ct -> token.type = RIGHT_BRACKET) then do;
				/*	      call probe_error_$record (probe_info_ptr, 0,
		 "Only the first subscript of a character array referenced using^/ a pointer value may be empty."
		 );
	      goto RECORDED_MESSAGE;*/
	    end;
	    else call get_dim ();
	end;
	else not_end_of_dims = "0"b;
      end;
      else do;
        call probe_error_$record (probe_info_ptr, 0,
	   "Syntax error in subscript/argument list");
        goto RECORDED_MESSAGE;
      end;
  end;

  end get_c_brackets;


get_pathname:
  proc ();


  do while (probe_info.ct -> token.type = GREATER_THAN
       | probe_info.ct -> token.type = LESS_THAN |
       probe_info.ct -> token.type = PERIOD
       | probe_info.ct -> token.type = DOLLAR_SIGN |
       probe_info.ct -> token.type = OR_BAR);

    if probe_info.ct -> token.type = GREATER_THAN
      then call add (">");
    else if probe_info.ct -> token.type = LESS_THAN
      then call add ("<");
    else if probe_info.ct -> token.type = PERIOD
      then call add (".");
    else if probe_info.ct -> token.type = DOLLAR_SIGN
      then call add ("$");
    else call add ("|");

    call bump_ct ();

    if probe_info.ct -> token.type >= probe_info.end_token
      then go to GOT_PATH;
    else if probe_info.ct -> token.type ^= NAME_TYPE then do;
        call probe_error_$record (probe_info_ptr, error_table_$badpath);
        go to RECORDED_MESSAGE;
      end;

    call add (identifier_tokens_name);

    call bump_ct ();
  end;
GOT_PATH:
  dummy_entry = cv_entry_ ((P_reference.name), null, code);
  if code ^= 0 then do;
      call probe_error_$record (probe_info_ptr, code, P_reference.name);
      go to RECORDED_MESSAGE;
    end;

  P_reference.path = "1"b;

  call get_parens ();

  end get_pathname;



bump_ct:
  proc;
  probe_info.ct = probe_info.ct -> token.next;
  end bump_ct;


cobol_connector:
  proc (p) returns (bit (1) aligned);
  dcl p			ptr parameter;
  dcl based_two		char (2) unal based (p -> identifier.name);
  dcl c2			char (2) aligned;
  if p -> token.type = NAME_TYPE
    then if p -> identifier.length = 2 then do;
	   c2 = based_two;
	   if c2 = "of" | c2 = "in" | c2 = "OF" | c2 = "IN"
	     then return ("1"b);
	 end;
  return ("0"b);
  end cobol_connector;

looks_like_cobol:
  proc () returns (bit (1) aligned);
  if probe_info.language_type = COBOL_lang_type
       & probe_info.ct -> token.type = NAME_TYPE
    then if cobol_connector ((probe_info.ct -> token.next))
	 then return ("1"b);
  return ("0"b);			/* cobol, but in "normal" form */
  end looks_like_cobol;
%page;
  /*        INCLUDE FILES       */

%include probe_info;
%page;
%include probe_tokens;
%page;
%include probe_references;
%page;
%include probe_source_info;
%page;
%include probe_seg_info;
%page;
%include runtime_symbol;
%page;
%include acc;
%page;
%include probe_operators;
%page;
%include probe_lang_types;
%page;
%include std_descriptor_types;
%page;
%include pascal_symbol_node;
%page;
%include encoded_precision;
%page;
%include pascal_gen_constants;
%page;
%include computational_data;
%page;
%include runtime_symbol_info_;
%page;
%include system;
%include its;

  end probe_get_value_;

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