



		    probe_increment_indices_.pl1    10/24/88  1619.7rew 10/24/88  1342.6       32805



/****^  ******************************************************
        *                                                    *
        * 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):
     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_increment_indices_:
  procedure (invert_sw, subscript, bounds, n_subscripts, finished,
       almost_finished);

  /* *	PROBE_INCREMENT_INDICES_
   *
   *	Increment a set of array indices to get to the next element in 
   *	a cross-section. The order is determined by invert_sw, which is
   *	set to "1"b for Fortran style subscripts, and "0"b otherwise.
   *
   *	Modification history:
   *	 2 Jun 83, W. Olin Sibert: return almost_finished,
   *	   change calling sequence for a single entrypoint
   *	29 Nov 78, JRD: fix stupidity - index(1) is MOST, not least sig!!!
   *	11 Nov 78, James R. Davis: Initial coding
   */

  dcl invert_sw		bit (1) aligned parameter;
				/* "1"b => Fortran style subscripts */
  dcl subscript		(*) fixed bin (24) parameter;
				/* i/o what we are incrementing */
  dcl bounds		(2, *) fixed bin (24) parameter;
				/* (input) low and high limits */
  dcl n_subscripts		fixed bin parameter;
				/* input: how many dims are meaningful */
  dcl finished		bit (1) aligned parameter;
				/* output: set "1"b when incremented over full range */
  dcl almost_finished	bit (1) aligned parameter;
				/* output: set "1"b when next call will set "finished" */

  dcl LOWER		fixed bin static options (constant) init (1);
  dcl UPPER		fixed bin static options (constant) init (2);
				/**/
  if invert_sw
    then
         call increment (1, (n_subscripts));
    else call increment ((n_subscripts), 1);
  return;



increment:
  procedure (first, last);

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

  dcl idx			fixed bin;
  dcl direction		fixed bin;

  if (last > first)
    then /* This determines the order in which the */
         direction = 1;		/* subscripts are processed */
    else direction = -1;

  idx = first;			/* start with least significant */

  subscript (idx) = subscript (idx) + 1;
  do while (subscript (idx) > bounds (UPPER, idx));
				/* did we just overflow ? */
    subscript (idx) = bounds (LOWER, idx);
				/* then reset to low */
    if (idx = last) then do;		/* have just finished last? */
        finished = "1"b;
        return;
      end;

    idx = idx + direction;		/* now bump next highest */
    subscript (idx) = subscript (idx) + 1;
				/* bump, and test before we exit */
  end;

  finished = "0"b;			/* there is useful work to be finished */

  almost_finished = "1"b;
  do idx = first to last by direction;	/* Is this the last time we'll be here? */
    if (subscript (idx) ^= bounds (UPPER, idx))
      then
	 almost_finished = "0"b;
  end;
  return;
  end increment;

  end probe_increment_indices_;






		    probe_info_requests_.pl1        10/27/88  1250.2r w 10/27/88  1224.4       54648



/****^  ***********************************************************
        *                                                         *
        * 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(86-01-21,LJAdams), approve(86-01-21,MCR7327),
     audit(86-04-17,Lippard), install(86-04-24,MR12.0-1048):
     Added ssu_ references so subsystem calls to help_ will work properly.
     Added include file "help_args" which is a structure that contains all
     needed help data includeing the new version number Vhelp_args_2.
  2) change(87-08-20,LJAdams), approve(87-09-03,MCR7766),
     audit(88-08-07,GDixon), install(88-09-13,MR12.2-1109):
     Changed Vhelp_args_2 to Vhelp_args_3.
  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_info_requests_:
  proc ();

  call probe_error_$malfunction ();	/* dummy entry */

  /* *	This procedure implements a handful of random requests, most of which were
   *	stolen more or less bodily from probe_requests_.
   *
   *	07/15/79 W. Olin Sibert
   *	Recoded to use the awful, but powerful help_, instead of help JRD Oct 1 79 */
  /* Changed to use info search paths unless nonstandard dirs listed in probe_static_info 09/28/81 S. Herbst */
  /* Modified April, 1985 by L. Adams - use new help_args_.incl.pl1                    */

  dcl P_probe_info_ptr	pointer parameter;

  dcl i			fixed bin;
  dcl desired_topic		char (32) aligned;
  dcl code		fixed bin (35);

  dcl ioa_$ioa_switch	entry options (variable);
  dcl probe_error_		entry options (variable);
  dcl probe_error_$warning	entry options (variable);
  dcl probe_error_$malfunction
			entry options (variable);

  dcl probe_request_mgr_$list_requests
			entry (ptr);
  dcl probe_request_mgr_$list_builtins
			entry (ptr);

  dcl probe_et_$too_many_args fixed bin (35) external static;

  dcl null		builtin;

  dcl cleanup		condition;


  /*  */

print_request_summary:
  entry (P_probe_info_ptr);

  probe_info_ptr = P_probe_info_ptr;
  call reject_argument ();

  call ioa_$ioa_switch (probe_info.output_switch,
       "^/Summary of probe requests:^/");

  call probe_request_mgr_$list_requests (probe_info_ptr);

  call ioa_$ioa_switch (probe_info.output_switch,
       "^/Type ""help"" for more information.");

  return;				/* end of code for $print_request_summary */

print_builtin_summary:
  entry (P_probe_info_ptr);

  probe_info_ptr = P_probe_info_ptr;
  call reject_argument ();

  call ioa_$ioa_switch (probe_info.output_switch,
       "^/Summary of probe builtins:^/");
  call probe_request_mgr_$list_builtins (probe_info_ptr);
  return;



help_request:
  entry (P_probe_info_ptr);

  probe_info_ptr = P_probe_info_ptr;

  if probe_info.ct -> token.type >= probe_info.end_token
    then
         desired_topic = "summary";
  else if probe_info.ct -> token.type = TIMES then do;
      desired_topic = "toc";
      call bump_ct ();
    end;
  else if probe_info.ct -> token.type = NAME_TYPE then do;
      desired_topic = current_identifier_name;
      call bump_ct ();
    end;
  else call probe_error_ (probe_info_ptr, 0, "Usage: help { * TOPIC }");

  call reject_argument ();

  goto help_common;



list_help_request:
  entry (P_probe_info_ptr);

  probe_info_ptr = P_probe_info_ptr;

  call reject_argument;
  desired_topic = "toc";
  goto help_common;

help_common:
  Phelp_args = null;

  on cleanup
    call help_$term ("probe", Phelp_args, (0));

  call help_$init ("probe", "info", "", Vhelp_args_3, Phelp_args, code);

  if code ^= 0
    then call probe_error_ (probe_info_ptr, code);

  if probe_static_info.info_directory_info.array_size > 1
       | probe_info_directories (1) ^= ">doc>info" then do;
				/* use info search paths unless dirs specified */
      help_args.Nsearch_dirs =
	 probe_static_info.info_directory_info.array_size;
      do i = 1 to probe_static_info.info_directory_info.array_size;
        help_args.search_dirs (i) = probe_info_directories (i);
      end;
    end;

  help_args.Npaths = 1;
  help_args.Ncas = 0;		/* yields illegal PL/1 */
  help_args.Nscns = 0;		/* 0-extent arrays */
  help_args.Nsrhs = 0;

  if desired_topic = "bugs" | desired_topic = "changes"
    then help_args.path (1).value = "probe." || desired_topic;
    else do;
      help_args.path (1).value = "probe";
      help_args.path (1).S.info_name_not_starname = "1"b;
      help_args.path (1).info_name = desired_topic;
    end;

  call help_ ("probe", Phelp_args, "info", (0), code);
  if code ^= 0
    then
         call probe_error_$warning (probe_info_ptr, 0,
	    "There is no info available for ""^a"".", desired_topic);

  call help_$term ("probe", Phelp_args, (0));

  return;				/* of code for help request */




bump_ct:
  proc;
  probe_info.ct = probe_info.ct -> token.next;
  end bump_ct;

reject_argument:
  proc;
  if probe_info.ct -> token.type < probe_info.end_token
    then call probe_error_ (probe_info_ptr, probe_et_$too_many_args);
  end reject_argument;


  /*	INCLUDE FILES	*/
%include probe_info;
%include probe_static_info;
%include probe_tokens;
%include probe_operators;

%include help_args_;
  end probe_info_requests_;




		    probe_invoke_.pl1               11/11/88  1555.4r w 11/11/88  1545.0      332064



/****^  ***********************************************************
        *                                                         *
        * 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):
     Fixed bug in passing file parameters when calling a PASCAL procedure.
  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 */

probe_invoke_:
  proc ();

  call probe_error_$malfunction ();	/* dummy entry */

  /*  This procedure is used to invoke functions and call subroutines.  The arguments supplied
   will be converted to the expected type if entry argument descriptors are available for
   the called entry.

   Initial Version:  10 August 1974 by Jeffrey M. Broughton
   Modified:  4 December 1978 by James R. Davis to not clobber generation ptr
   Modified: 12 December 1978 by JRD to call assign_value instead of assign_reference
   Modified: 10 March 1980 by JRD to call probe_assign_value_
   Note: this program could be cleaned up a fair bit, and ought to be, someday */
  /* Made to call Pascal programs 09/14/83 J.M.Athane */
  /* Added version strings to runtime_symbol_info_ structures 10/06/83 S. Herbst */
  /* Fixed to call gates 02/10/84 S. Herbst */
  /* Fixed bug in passing file parameters in Pascal JMAthane June 85 */

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

  dcl 1 P_entry_ref		aligned like reference_node parameter;
				/* description of procedure to call */
  dcl 1 P_return_ref	aligned like reference_node parameter;
				/* place to put return value */

  dcl FB24_ALL_ONES		fixed bin (24) int static
			options (constant)
			init (111111111111111111111111b);

  dcl function_flag		bit (1);	/* flags the entry used */
  dcl number_args		fixed bin;/* number of arguments supplied */
  dcl possible_number	fixed bin;/* number including return arg */
  dcl entry		pointer;	/* to procedure to be called */
  dcl stack_frame		pointer;	/* display pointer of proc (if any) */
  dcl code		fixed bin (35);
				/* global error code */

  dcl 1 arg_ref_list	aligned based,
				/* list of arguments to procedure */
       2 number		fixed bin,/* how many */
       2 node		(0 refer (arg_ref_list.number)) pointer;
				/* to reference nodes of args */

  dcl 1 encoded		aligned based,
				/* overlay for encoded scale and precision */
       2 scale		fixed bin (17) unaligned,
       2 precision		fixed bin (17) unaligned;

  dcl 1 entry_var		aligned based,
				/* overlay for entry variable */
       2 place		pointer,
       2 frame		pointer;

  dcl type_size		(23) fixed bin internal static
			options (constant)
			initial /* storage needed for converted args */
			(1, 2, 1, 2, 2, 4, 2, 4, 30, 32, 60, 64,
			2, 1, 4, 4, 0, 0, -36, -36, -4, -4, 2);

  dcl (
      error_table_$lower_ring,
      error_table_$nodescr,		/* code for no desciptors */
      probe_et_$array_arg,
      probe_et_$bad_return_val,
      probe_et_$int_proc,
      probe_et_$no_return_desc,
      probe_et_$not_function,
      probe_et_$recorded_message,
      probe_et_$struc_arg,
      probe_et_$wrong_no_args
      )			fixed bin (35) external static;

  dcl probe_assign_value_	entry (ptr,
			1 structure aligned like reference_node,
			1 structure aligned like reference_node,
			fixed bin (35));

  dcl probe_error_$record	entry options (variable);
  dcl probe_error_$malfunction
			entry options (variable);

  dcl cu_$gen_call		entry (pointer, pointer);
  dcl cu_$grow_stack_frame	entry (fixed bin (18), ptr, fixed bin (35));
  dcl decode_descriptor_	entry (pointer, fixed bin, fixed bin, bit (1),
			fixed bin, fixed bin, fixed bin);
  dcl get_entry_arg_descs_	entry (pointer, fixed bin,
			pointer dimension (*), fixed bin (35));

  dcl (addr, addrel, bit, ceil, divide, fixed, min, null, reverse, substr,
      unspec, verify)	builtin;
%page;

probe_invoke_$function:
  entry (P_probe_info_ptr, P_entry_ref, P_return_ref, P_code);

  function_flag = "1"b;		/* there will be a return argument */
  go to common;


probe_invoke_$subroutine:
  entry (P_probe_info_ptr, P_entry_ref, P_code);

  function_flag = "0"b;		/* no return arg, just call the procedure */
  go to common;

common:
  probe_info_ptr = P_probe_info_ptr;


  /*  Get the number of arguments expected, and find out what procedure to call */

  number_args = P_entry_ref.argument_list -> arg_ref_list.number;
				/* user gave <number> arguments */
  possible_number = number_args + fixed (function_flag, 1, 0);
				/* if function then there may be one more */

  if P_entry_ref.type_ptr = null
    then
      begin;			/* no PASCAL procedure description available */
      if P_entry_ref.type = 16
        then do;			/* invoking an entry variable */
	entry = P_entry_ref.address_ptr -> entry_var.place;
				/* get real entry */
	stack_frame = P_entry_ref.address_ptr -> entry_var.frame;
        end;
      else if P_entry_ref.type = 25
        then /* it is an interanl proc */
	   stack_frame = addr (stack_frame);
				/* int procs not supported, flag as such */
      else do;
        entry = P_entry_ref.address_ptr;/* external entry */
        stack_frame = null;
      end;

      if stack_frame ^= null then do;	/* check for calling an internal proc */
	call probe_error_$record (probe_info_ptr, probe_et_$int_proc,
	     P_entry_ref.name);
	goto RECORDED_MESSAGE;
        end;

%page;

      begin;

        /* When this block is entered, space for the argument list and descriptors will   be allocated */

        declare

	      desc_ptrs		(possible_number) pointer,
				/* argument descriptors from called proc */
	      1 dummy_arg_list	aligned,
				/* argument list  storage */
	       2 align_arg_list	pointer,
				/* kludge to double word align arglist */
	       2 arg_list,		/* here is the real one */
	        3 arg_count		fixed bin (17) unaligned,
				/* number of arguments */
	        3 call_code		fixed bin (17) unaligned initial (4),
				/* this is a pl1 call */
	        3 desc_count	fixed bin (17) unaligned,
				/* number of descriptors */
	        3 info		(possible_number * 2) pointer,
				/* place to pu arg and descriptor ptrs */
	      desc_origin		fixed bin,
				/* index of first desc ptr in info */
	      number_descs		fixed bin,
				/* number of descriptors from proc to be called */
	      type		fixed bin,
				/* attributes from descriptors */
	      ndims		fixed bin,
	      size		fixed bin,
	      scale		fixed bin,
	      packed		bit (1),
	      match		bit (1),
				/* proc has entry descrs, match called args to them */
	      must_build		bit (1),
				/* indicates that we must build a descriptor */

	      1 argument		aligned like reference_node
				based (arg_ref),
				/* reference node for argument */
	      arg_ref		pointer,
	      i			fixed bin;


        /* See if the called procedure has argument descriptors, if it does we will try
   to match the arguments given to the types desired, otherwise, descriptors for
   the arguments supplied will built, and the call made blindly */

        call get_entry_arg_descs_ (entry, number_descs, desc_ptrs, code);
				/* find the descriptors (if any) */
        if code ^= 0
	then if code = error_table_$nodescr | code = error_table_$lower_ring
	       then match = "0"b;	/* problem is tolerable */
	       else do;
	         call probe_error_$record (probe_info_ptr, code, "^a",
		    P_entry_ref.name);
	         goto RECORDED_MESSAGE;
	       end;

	else match = "1"b;


        if match

	then do;			/* try to match given and expected types */

	  if possible_number = number_descs
	    then do;		/* then things are fine */
	      arg_list.arg_count = possible_number * 2;
				/* complete arg list header */
	      arg_list.desc_count = possible_number * 2;
	      desc_origin = possible_number;
	    end;
	  else if function_flag & (number_args = number_descs) then do;
	      call probe_error_$record (probe_info_ptr,
		 probe_et_$not_function, P_entry_ref.name);
	      goto RECORDED_MESSAGE;
	    end;

	  else do;
	    call probe_error_$record (probe_info_ptr,
	         probe_et_$wrong_no_args, P_entry_ref.name);
	    goto RECORDED_MESSAGE;	/* some other problem */
	  end;


	  do i = 1 to number_args;	/* match each argument */
	    arg_ref = P_entry_ref.argument_list -> arg_ref_list.node (i);
	    if argument.type = structure_dtype then do;
	        call probe_error_$record (probe_info_ptr,
		   probe_et_$struc_arg, argument.name);
	        goto RECORDED_MESSAGE;
	      end;

	    call decode_descriptor_ (desc_ptrs (i), 0, type, packed, ndims,
	         size, scale);

	    if ndims > 0 then do;
	        code = probe_et_$array_arg;
	        goto SOME_ERROR;
	      end;

	    else if argument.type ^= type
				/* argument types do not match */
	      then call match_arg (arg_ref, type, size, scale, packed);
	    else if size ^= addr (argument.precision) -> encoded.precision
	      then do;
	        if size = FB24_ALL_ONES
				/* "*" extent */
		then ;		/* just have to make a descriptor */
		else call match_arg (arg_ref, type, size, scale, packed);
	      end;
	    else if scale ^= addr (argument.precision) -> encoded.scale
	      then call match_arg (arg_ref, type, size, scale, packed);
	    else if packed ^= argument.packed
	      then call match_arg (arg_ref, type, size, scale, packed);

	    must_build = (size = FB24_ALL_ONES);
	    if must_build
	      then info (desc_origin + i) = build_descriptor (arg_ref);
	      else info (desc_origin + i) = desc_ptrs (i);
	    info (i) = argument.address_ptr;
	    if type = 20 | type = 22
	      then /* for varying length strings, the pointer to     */
		 info (i) = addrel (info (i), 1);
				/* arg must pt to string itself, not length word. */

	  end;

	  if function_flag then do;	/* create entry for return argument */
	      call decode_descriptor_ (desc_ptrs (number_descs), 0, type,
		 packed, ndims, size, scale);
	      if ndims ^= 0 | size = FB24_ALL_ONES then do;
		call probe_error_$record (probe_info_ptr,
		     probe_et_$bad_return_val, P_entry_ref.name);
		goto RECORDED_MESSAGE;
	        end;

	      P_return_ref.name = P_entry_ref.name || " [return val]";
	      P_return_ref.type = type;
	      P_return_ref.descriptor = type * 2 + fixed (packed, 1, 0);
	      P_return_ref.precision = size;
	      addr (P_return_ref.precision) -> encoded.scale = scale;
	      P_return_ref.flags = "0"b;
	      P_return_ref.constant = "1"b;
	      P_return_ref.packed = packed;
	      P_return_ref.symbol_ptr = null;
	      if P_return_ref.source_info_ptr ^= null
	        then P_return_ref.source_info_ptr -> source_info.block_ptr,
		        P_return_ref.source_info_ptr
		        -> source_info.stack_ptr,
		        P_return_ref.source_info_ptr
		        -> source_info.entry_ptr = null ();
	      i = type_size (type);	/* allocate storage for result */
	      if i < 0		/* char or bit, figure out no of words */
	        then i = divide (size - i, -i, 17, 0);
	      P_return_ref.address_ptr = allocate_temp (i);

	      info (number_descs) = P_return_ref.address_ptr;
	      if type = 20 | type = 22
	        then /* kludge ptr to varying strings to point */
		   /* beyond length word to start of string */
		   info (number_descs) = addrel (info (number_descs), 1);
	      info (desc_origin + number_descs) = desc_ptrs (number_descs);
	    end;

	end;			/* of match code */

	else do;			/* nothing to compare with, work blindly */
	  if function_flag then do;	/* no idea of what the return arg is */
	      call probe_error_$record (probe_info_ptr,
		 probe_et_$no_return_desc, P_entry_ref.name);
	      goto RECORDED_MESSAGE;
	    end;

	  arg_list.arg_count = possible_number * 2;
				/* build argument list header */
	  arg_list.desc_count = possible_number * 2;
	  desc_origin = possible_number;

	  do i = 1 to number_args;	/* build descriptors for all args */
	    arg_ref = P_entry_ref.argument_list -> arg_ref_list.node (i);
	    info (i) = argument.address_ptr;
	    if argument.type = 20 | argument.type = 22
	      then
		 info (i) = addrel (info (i), 1);
	    info (desc_origin + i) = build_descriptor (arg_ref);
	  end;

	end;


        /* Ta Da !!!!!!!! */

        call cu_$gen_call (entry, addr (arg_list));
				/* make the call */
%page;
match_arg:
  procedure (ref, type, precision, scale, packed);


  declare

	ref		    pointer,
				/* to reference node of argument, altered
						   on return to node of matched temporary */
	type		    fixed bin,
				/* desired data type */
	precision		    fixed bin,
				/* arithmetic precsion or size */
	scale		    fixed bin,
	packed		    bit (1),

	1 argument	    aligned like reference_node based (ref),
				/* input argument */
	1 temp		    aligned like reference_node based (tref),
				/* converted argument temporary */
	tref		    pointer,

	based_string	    character (128) based,
	need		    fixed bin,
				/* storage for temporary */
	i		    fixed bin,
	arith_to_char	    bit (1) initial ("0"b),
				/* convert arith to char(*) */
	size		    builtin;


  tref = allocate_temp (size (temp));	/* make a place for it */

  temp.symbol_ptr, temp.source_info_ptr = null;
  temp.name = "argument temporary";

  temp.type = type;			/* fill in data and perform conversion */
  temp.descriptor = type * 2 + fixed (packed, 1, 0);
  temp.precision = precision;
  addr (temp.precision) -> encoded.scale = scale;

  if precision = FB24_ALL_ONES	/* encoded size - target must be bit, char, or area */
    then if argument.type > 12	/* source val also char bit or area */
	 then temp.precision = precision;
				/* is the same for char to char, bit to bit, etc. */
         else if type >= 21 /* target is char */
	 then do;
	   temp.precision = 128;	/* target will have room to hold any arithmetic */
	   arith_to_char = "1"b;	/* will truncate trailing blanks later */
	 end;
         else do;			/* target is bit */
	 i = addr (argument.precision) -> encoded.precision
	      - addr (argument.precision) -> encoded.scale;
	 if i < 0
	   then i = 0;		/* compute size of result */
	 if argument.type > 8
	   then i = ceil (i * 3.32);	/* decimal, result is psuedo-binary */
	 i = min (71, i);
	 temp.precision = i;
         end;

  temp.flags = "0"b;
  temp.packed = packed;

  need = type_size (type);		/* make a place to put temporary */
  if need < 0
    then need = divide (temp.precision - need - 1, -need, 17, 0);
  temp.address_ptr = allocate_temp (need);

  call probe_assign_value_ (probe_info_ptr, temp, argument, code);
				/* convert the two */
  if code ^= 0
    then goto SOME_ERROR;

  if arith_to_char then do;
      i = verify (reverse (temp.address_ptr -> based_string), " ");
      temp.precision = 129 - i;
    end;
  ref = tref;
  return;
  end match_arg;
%page;
build_descriptor:
  procedure (ref) returns (pointer);


  declare

	ref		    pointer,
				/* to argument's reference node */
	1 argument	    aligned like reference_node based (ref),

	1 descriptor	    aligned based (dp),
				/* template descriptor */
	 2 flag		    bit (1) unaligned,
				/* indicates new format */
	 2 type		    bit (6) unaligned,
				/* data type */
	 2 packed		    bit (1) unaligned,
				/* unaligned types */
	 2 ndims		    bit (4) unaligned,
				/* number of dimensions */
	 2 size		    bit (24) unaligned,
				/* arithmetic precision and scale, other size */
	dp		    pointer,
	size		    builtin;

  if argument.type = 17 then do;
      call probe_error_$record (probe_info_ptr, probe_et_$struc_arg,
	 argument.name);
      goto RECORDED_MESSAGE;
    end;
  dp = allocate_temp (size (descriptor));
				/* make a palce for it */

  descriptor.flag = "1"b;		/* and fill in information */
  descriptor.type = bit (fixed (argument.type, 6, 0));
  descriptor.packed = argument.packed;
  descriptor.ndims = (4)"0"b;

  if argument.type > 12		/* non-arithmetic, no scale */
    then descriptor.size = bit (fixed (argument.precision, 24, 0));
    else do;
      substr (descriptor.size, 1, 12) =
	 bit (fixed (addr (argument.precision) -> encoded.scale, 12, 0));
      substr (descriptor.size, 13, 12) =
	 bit (fixed (addr (argument.precision) -> encoded.precision, 12, 0))
	 ;
    end;

  return (dp);


  end build_descriptor;

%page;
allocate_temp:
  procedure (words_needed) returns (pointer);

  /* This routine allocates temporary storage in the stack frame of its caller.  Its function depends on
   its being W  a quick block.  And that the storage be needed only for the length of time that the
   procedure is active. */

  dcl words_needed		fixed bin parameter;
  dcl p			pointer;

  call cu_$grow_stack_frame ((words_needed), p, code);
  if code ^= 0
    then goto SOME_ERROR;		/* lossage */
  return (p);
  end;				/* allocate_temp internal procedure */

      end;			/* of main procedure begin block */
    end;				/* non PASCAL typed procedure */
%page;
    else
      begin;			/* call a la PASCAL : all proc and params supported ! */

      /* for argument checking, we will use the formal parameters list
   which describes how the procedure was declared in the current program. */

      dcl 1 dummy_arg_list,
	 2 align		    ptr,
	 2 arg_list,
	  3 arg_count	    fixed bin (17) unal
			    init (possible_number * 2),
	  3 call_code	    fixed bin (17) unal init (4),
	  3 desc_count	    fixed bin (17) unal init (0),
	  3 info		    (possible_number * 2) ptr;

      dcl (f_dims, a_dims)	    fixed bin (35);
      dcl pascal_int_call_op	    fixed bin (35) init (42);
      dcl pascal_ext_call_op	    fixed bin (35) init (43);
      dcl pascal_return_value	    fixed bin (35) based;
      dcl pascal_entry_parm_size  fixed bin init (5);
      dcl pvalue_ref_ptr	    ptr;
      dcl formal_ptr	    ptr;
      dcl pascal_gen_call_	    entry (ptr, ptr, ptr, fixed bin (35),
			    fixed bin (35));
      dcl operator_number	    fixed bin (35);
      dcl 1 argument	    like reference_node
			    based (arg_ref_ptr) aligned;
      dcl 1 entry_type_info	    like runtime_type_info;
      dcl 1 fconf_type_info	    like runtime_type_info;
      dcl arg_ref_ptr	    ptr;
      dcl bit_size		    fixed bin (35);
      dcl bit_string	    bit (bit_size) unal based;
      dcl temp_addr		    ptr;
      dcl get_size_in_bits_	    entry (fixed bin, fixed bin (35),
			    bit (1) aligned) returns (fixed bin);
      dcl (i, total_dims)	    fixed bin (35);
      dcl (formal_is_conformant, arg_is_conformant)
			    bit (1);
      dcl 1 formal_type_info	    like runtime_type_info;
      dcl 1 arg_type_info	    like runtime_type_info;
      dcl 1 pvalue_ref	    like reference_node
			    based (pvalue_ref_ptr) aligned;
      dcl 1 formal_array_info	    like runtime_array_info;
      dcl 1 arg_array_info	    like runtime_array_info;
      dcl 1 pascal_entry_parm	    based,
	 2 place		    ptr,
	 2 frame		    ptr,
	 2 op_nbr		    fixed bin (35);
      dcl probe_pascal_$real_type entry (fixed bin (35), ptr, fixed bin (35),
			    ptr);
      dcl probe_create_reference_ entry (ptr, ptr);
      dcl (Block_ptr, Linkage_ptr, Stack_ptr, Base_addr)
			    ptr;
      dcl based_ptr		    ptr based;

      if P_entry_ref.type = pascal_parameter_procedure_dtype then do;
	entry = P_entry_ref.address_ptr -> pascal_entry_parm.place;
	stack_frame = P_entry_ref.address_ptr -> pascal_entry_parm.frame;
	operator_number =
	     P_entry_ref.address_ptr -> pascal_entry_parm.op_nbr;
        end;
      else if P_entry_ref.type = pascal_internal_procedure_dtype then do;
	entry = P_entry_ref.address_ptr;
	stack_frame = P_entry_ref.source_info_ptr -> source_info.stack_ptr;
	operator_number = pascal_int_call_op;
        end;
      else if (P_entry_ref.type = pascal_imported_procedure_dtype) |
	 (P_entry_ref.type = pascal_exportable_procedure_dtype) then do;
	entry = P_entry_ref.address_ptr;
	stack_frame = null;
	operator_number = pascal_ext_call_op;
        end;

      formal_ptr = runtime_symbol_info_$son (P_entry_ref.type_ptr);

      do i = 1 to number_args;
        if formal_ptr = null then do;
wrong_no_arg_err:
	  call probe_error_$record (probe_info_ptr, probe_et_$wrong_no_args,
	       P_entry_ref.name);
	  go to RECORDED_MESSAGE;
	end;
        arg_ref_ptr = P_entry_ref.argument_list -> arg_ref_list.node (i);
        Block_ptr = argument.source_info_ptr -> source_info.block_ptr;
        Stack_ptr = argument.source_info_ptr -> source_info.stack_ptr;
        Linkage_ptr =
	   argument.source_info_ptr -> source_info.seg_info_ptr
	   -> seg_info.linkage_ptr;
        Base_addr = argument.base_addr;

        formal_type_info.version = RUNTIME_TYPE_INFO_VERSION_1;

        call runtime_symbol_info_$type (formal_ptr, addr (formal_type_info),
	   code);
        if code ^= 0
	then go to SOME_ERROR;

        formal_is_conformant =
	   is_conformant (formal_type_info.base_type_addr, f_dims,
	   formal_array_info);
        if argument.type_ptr = null
	then arg_is_conformant = "0"b;
	else arg_is_conformant =
		is_conformant (argument.type_ptr, a_dims, arg_array_info);
        if formal_type_info.type = pascal_variable_formal_parameter_dtype
	then do;
				/* passed by address. Types must match. Constants not allowed */
	  if (argument.symbol_ptr = null)
	       | (argument.name = "<<constant>>") then do;
invalid_arg_err:
	      call probe_error_$record (probe_info_ptr, 0,
		 "Argument ^d passed to ^a is invalid.", i,
		 P_entry_ref.name);
	      go to RECORDED_MESSAGE;
	    end;
	    else do;

	      arg_type_info.version = RUNTIME_TYPE_INFO_VERSION_1;

	      call runtime_symbol_info_$type (argument.symbol_ptr,
		 addr (arg_type_info), code);
	      if code ^= 0
	        then go to SOME_ERROR;

	      if formal_is_conformant then do;
		total_dims = 0;

		fconf_type_info.version = RUNTIME_TYPE_INFO_VERSION_1;

		call runtime_symbol_info_$type
		     (formal_type_info.base_type_addr,
		     addr (fconf_type_info), code);
		if code ^= 0
		  then go to SOME_ERROR;


		arg_type_info.version = RUNTIME_TYPE_INFO_VERSION_1;

		call runtime_symbol_info_$type (argument.type_ptr,
		     addr (arg_type_info), code);
		if code ^= 0
		  then go to SOME_ERROR;

		if ^match_arrays (fconf_type_info, arg_type_info,
		     formal_array_info, arg_array_info, total_dims)
		  then go to invalid_arg_err;
		call pass_conf_desc;
	        end;
	        else do;
		if arg_type_info.size ^= formal_type_info.size
		  then go to invalid_arg_err;
		if (arg_type_info.type ^= formal_type_info.base_type)
		     | (arg_type_info.type_addr
		     ^= formal_type_info.base_type_addr)
		  then
		       call probe_pascal_$real_type
			  ((formal_type_info.base_type),
			  formal_type_info.base_type_addr,
			  (formal_type_info.base_type),
			  formal_type_info.type_addr);
		if (formal_type_info.base_type ^= arg_type_info.type)
		     | (formal_type_info.base_type_addr
		     ^= arg_type_info.type_addr)
		  then
		       go to invalid_arg_err;
	        end;
	      info (i) = argument.address_ptr;
	      if is_file (arg_ref_ptr)
	        then info (i) = info (i) -> based_ptr;
	    end;
	end;
        else if formal_type_info.type = pascal_value_formal_parameter_dtype
	then do;
				/* passed by value. Check is done through probe_assign_ */
	  if formal_is_conformant then do;
	      if arg_is_conformant
	        then go to invalid_arg_err;
	      if argument.type = char_dtype then do;
				/* char string -> PASCAL array */
		dcl 1 char_to_array_type,
		     2 h		        like
				        pascal_symbol_node_header,
		     2 bti	        like pascal_base_type_info,
		     2 size	        fixed bin (35),
		     2 ai,
		      3 access	        like pascal_array_info
				        .access_info,
		      3 virtual_origin      fixed bin (35),
		      3 bounds	        like pascal_array_info.bounds;

		unspec (char_to_array_type) = "0"b;

		char_to_array_type.h.packed,
		     char_to_array_type.h.base_type_info,
		     char_to_array_type.h.size,
		     char_to_array_type.h.array_info = "1"b;
		char_to_array_type.type = pascal_user_defined_type_dtype;
		char_to_array_type.size = 9;
		char_to_array_type.base_type = pascal_char_dtype;
		char_to_array_type.ai.ndims = 1;
		char_to_array_type.ai.array_units = 2;
		char_to_array_type.virtual_origin = 1;
		char_to_array_type.bounds.lower = 1;
		char_to_array_type.bounds.upper = argument.precision;
		char_to_array_type.multiplier = 1;
		char_to_array_type.subscript_type = pascal_integer_dtype;

		argument.type = pascal_user_defined_type_instance_dtype;
		argument.type_ptr = addr (char_to_array_type);
		argument.precision = argument.precision * 9;

		arg_array_info.version = RUNTIME_ARRAY_INFO_VERSION_1;

		call runtime_symbol_info_$array (argument.type_ptr,
		     addr (arg_array_info), code);
		if code ^= 0
		  then go to SOME_ERROR;
	        end;
	      if argument.type_ptr = null
	        then go to invalid_arg_err;

	      arg_type_info.version = RUNTIME_TYPE_INFO_VERSION_1;

	      call runtime_symbol_info_$type (argument.type_ptr,
		 addr (arg_type_info), code);
	      if code ^= 0
	        then go to SOME_ERROR;

	      total_dims = 0;

	      fconf_type_info.version = RUNTIME_TYPE_INFO_VERSION_1;

	      call runtime_symbol_info_$type
		 (formal_type_info.base_type_addr, addr (fconf_type_info),
		 code);
	      if code ^= 0
	        then go to SOME_ERROR;

	      if ^match_arrays (fconf_type_info, arg_type_info,
		 formal_array_info,
		 arg_array_info, total_dims)
	        then go to invalid_arg_err;
	      call pass_conf_desc;
	    end;
	  call probe_create_reference_ (probe_info_ptr, pvalue_ref_ptr);
	  pvalue_ref.flags = "0"b;
	  pvalue_ref.name = "value argument for parameter "
	       || runtime_symbol_info_$name (formal_ptr) -> acc.string;
	  pvalue_ref.source_info_ptr = null;
	  pvalue_ref.type = formal_type_info.base_type;
	  pvalue_ref.type_ptr = formal_type_info.base_type_addr;
	  if formal_is_conformant
	    then
	         pvalue_ref.precision = argument.precision;
	    else pvalue_ref.precision =
		    decode (formal_type_info.size,
		    formal_type_info.size_is_encoded);
	  pvalue_ref.descriptor = pvalue_ref.type * 2;
	  if formal_type_info.packed
	    then
	         pvalue_ref.descriptor = pvalue_ref.descriptor + 1;
	  pvalue_ref.packed = formal_type_info.packed;
	  bit_size =
	       get_size_in_bits_ ((pvalue_ref.type), pvalue_ref.precision,
	       (pvalue_ref.packed));
	  pvalue_ref.symbol_ptr = null;
	  pvalue_ref.address_ptr = allocate_temp ((bit_size + 35) / 36);

	  if formal_is_conformant
	    then
	         pvalue_ref.address_ptr -> bit_string =
		    argument.address_ptr -> bit_string;
	    else do;
	      call probe_assign_value_ (probe_info_ptr, pvalue_ref,
		 argument, code);
	      if code ^= 0
	        then go to invalid_arg_err;
	    end;
	  info (i) = pvalue_ref.address_ptr;
	end;
        else if formal_type_info.type = pascal_entry_formal_parameter_dtype
	then do;
	  if argument.type = pascal_parameter_procedure_dtype then do;
				/* nothing. good form */
	    end;
	  if argument.type = pascal_exportable_procedure_dtype
	       | (argument.type = pascal_imported_procedure_dtype) then do;
	      temp_addr = allocate_temp (pascal_entry_parm_size);
	      temp_addr -> pascal_entry_parm.place = argument.address_ptr;
	      temp_addr -> pascal_entry_parm.frame = null;
	      temp_addr -> pascal_entry_parm.op_nbr = pascal_ext_call_op;
	      argument.address_ptr = temp_addr;
	    end;
	  else if argument.type = pascal_internal_procedure_dtype then do;
	      temp_addr = allocate_temp (pascal_entry_parm_size);
	      temp_addr -> pascal_entry_parm.place = argument.address_ptr;
	      temp_addr -> pascal_entry_parm.frame = null;
	      temp_addr -> pascal_entry_parm.op_nbr = pascal_int_call_op;
	      argument.address_ptr = temp_addr;
	    end;
	  info (i) = argument.address_ptr;
	end;
        formal_ptr = runtime_symbol_info_$brother (formal_ptr);
      end;
      if formal_ptr ^= null
        then go to wrong_no_arg_err;

      entry_type_info.version = RUNTIME_TYPE_INFO_VERSION_1;

      call runtime_symbol_info_$type (P_entry_ref.type_ptr,
	 addr (entry_type_info), code);
      if code ^= 0
        then go to SOME_ERROR;

      if function_flag then do;
	if entry_type_info.base_type = 0 then do;
	    call probe_error_$record (probe_info_ptr, 0,
	         "^a is not a function", P_entry_ref.name);
	    go to RECORDED_MESSAGE;
	  end;
	allocate pascal_return_value in (expression_area)
	     set (info (number_args + 1));
        end;
        else do;
	if entry_type_info.base_type ^= 0 then do;
	    call probe_error_$record (probe_info_ptr, 0,
	         "^a is a function.", P_entry_ref.name);
	    go to RECORDED_MESSAGE;
	  end;
        end;

      call pascal_gen_call_ (entry, addr (arg_list), stack_frame,
	 operator_number, code);
      if code ^= 0
        then go to SOME_ERROR;

      if function_flag then do;
	P_return_ref.address_ptr = info (number_args + 1);
	P_return_ref.type = entry_type_info.base_type;
	P_return_ref.type_ptr = entry_type_info.base_type_addr;
	if P_return_ref.type = pascal_integer_dtype
	  then P_return_ref.precision = 35;
	else if P_return_ref.type = pascal_real_dtype
	  then P_return_ref.precision = 63;
	else if P_return_ref.type = pascal_boolean_dtype
	  then P_return_ref.precision = 36;
	else P_return_ref.precision = 72 /* pointer */;
	P_return_ref.symbol_ptr = null;
	P_return_ref.name = P_entry_ref.name || " [return value]";
        end;
%page;
      /* Procedures internal to begin block for PASCAL call */

allocate_temp:
  procedure (words_needed) returns (pointer);

  /* This routine allocates temporary storage in the stack frame of its caller. */

  dcl words_needed		fixed bin parameter;
  dcl p			pointer;

  call cu_$grow_stack_frame ((words_needed), p, code);
  if code ^= 0
    then goto SOME_ERROR;		/* lossage */
  return (p);
  end allocate_temp;
%page;
decode:
  proc (value, is_encoded) returns (fixed bin (35));

  dcl value		fixed bin (35);
				/* (input) */
  dcl is_encoded		bit (1);	/* (input) */

  dcl result		fixed bin (35);
  dcl stu_$decode_runtime_value_extended
			entry (fixed bin (35), ptr, ptr, ptr, ptr, ptr,
			ptr, fixed bin (35)) returns (fixed bin (35));
  dcl ptr			builtin;

  if ^is_encoded
    then
         return (value);

  result =
       stu_$decode_runtime_value_extended (value, Block_ptr, Stack_ptr,
       Linkage_ptr, ptr (Block_ptr, 0),
       Base_addr, argument.type_ptr, code);
  if code ^= 0
    then go to SOME_ERROR;
  return (result);

  end decode;
%page;
is_conformant:
  proc (tp, nd, ai) returns (bit (1));

  dcl tp			ptr;	/* (input) ptr to TYPE symbol block */
  dcl 1 ai		like runtime_array_info;
				/* (output) array info extracted form type TYPE box */
  dcl nd			fixed bin (35);
				/* (output) number of dims of this array */

  nd = 0;
  unspec (ai) = "0"b;
  if tp = null
    then
         return ("0"b);

  nd = runtime_symbol_info_$array_dims (tp);

  ai.version = RUNTIME_ARRAY_INFO_VERSION_1;

  call runtime_symbol_info_$array (tp, addr (ai), code);
  if code ^= 0
    then go to SOME_ERROR;

  if nd = 0
    then return ("0"b);
  return (ai.lower_is_encoded (1));

  end is_conformant;
match_arrays:
  proc (ti1, ti2, ai1, ai2, dims) returns (bit (1));

  dcl 1 (ti1, ti2)		like runtime_type_info;
				/* (input) */
  dcl 1 (ai1, ai2)		like runtime_array_info;
				/* (input) */
  dcl dims		fixed bin (35);
				/* (output) */

  dcl i			fixed bin (35);
  dcl 1 (ai11, ai12)	like runtime_array_info;
  dcl 1 (ti11, ti12)	like runtime_type_info;

  if (ti1.packed ^= ti2.packed)
       | (ti1.base_type ^= ti2.base_type)
       | (ti1.base_type_addr ^= ti2.base_type_addr)
       | (ai1.ndims ^= ai2.ndims)
    then
         return ("0"b);

  if ai1.ndims = 0
    then
         return ("1"b);

  do i = 1 to ai1.ndims;
    if (ai1.subscript_type (i) ^= ai2.subscript_type (i))
         | (ai1.subscript_type_addr (i) ^= ai2.subscript_type_addr (i))
      then
	 return ("0"b);
  end;

  dims = dims + ai1.ndims;

  if ti1.base_type_addr ^= null then do;

      ti11.version = RUNTIME_TYPE_INFO_VERSION_1;
      call runtime_symbol_info_$type (ti1.base_type_addr, addr (ti11), code);
      if code ^= 0
        then go to SOME_ERROR;

      ti12.version = RUNTIME_TYPE_INFO_VERSION_1;
      call runtime_symbol_info_$type (ti2.base_type_addr, addr (ti12), code);
      if code ^= 0
        then go to SOME_ERROR;

      ai11.version = RUNTIME_ARRAY_INFO_VERSION_1;
      call runtime_symbol_info_$array (ti1.base_type_addr, addr (ai11), code);
      if code ^= 0
        then go to SOME_ERROR;

      ai12.version = RUNTIME_ARRAY_INFO_VERSION_1;
      call runtime_symbol_info_$array (ti2.base_type_addr, addr (ai12), code);
      if code ^= 0
        then go to SOME_ERROR;
      return (match_arrays (ti11, ti12, ai11, ai12, dims));
    end;
    else
         return ("1"b);

  end match_arrays;
%page;
pass_conf_desc:
  proc;

  dcl 1 ai		like runtime_array_info;
  dcl desc_len		fixed bin;
  dcl (it, count, index)	fixed bin (35);
  dcl 1 ti		like runtime_type_info;
  dcl desc		(desc_len) based (desc_addr) fixed bin (35);
  dcl desc_addr		ptr;
  dcl tp			ptr;

  desc_len = 1 + 3 * total_dims + 1;
  desc_addr = allocate_temp (desc_len);
  info (i + possible_number) = desc_addr;
  index = 2 + (total_dims - 1) * 3;
  count = 0;
  ai = arg_array_info;
  ti = arg_type_info;
  do it = 1 to ai.ndims;
    call fill_dim;
  end;

  ti.version = RUNTIME_TYPE_INFO_VERSION_1;
  ai.version = RUNTIME_ARRAY_INFO_VERSION_1;

  do while (count ^= total_dims);
    tp = ti.base_type_addr;

    call runtime_symbol_info_$type (tp, addr (ti), code);
    if code ^= 0
      then go to SOME_ERROR;

    call runtime_symbol_info_$array (tp, addr (ai), code);
    if code ^= 0
      then go to SOME_ERROR;

    do it = 1 to ai.ndims;
      call fill_dim;
    end;
  end;

fill_dim:
  proc;

  desc (index) =
       decode (ai.lower (it), ai.lower_is_encoded (it));
  desc (index + 1) =
       decode (ai.upper (it), ai.upper_is_encoded (it));
  desc (index + 2) =
       convert_units (decode (ai.multiplier (it), multiplier_is_encoded (it)),
       (ai.array_units));
  if ^fconf_type_info.packed
    then
         desc (index + 2) = desc (index + 2) / 36;
				/* mult in words */
  index = index - 3;
  count = count + 1;

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;

  end fill_dim;

  end pass_conf_desc;

is_file:
  proc (ref_p) returns (bit (1));

  dcl ref_p		ptr;
  dcl 1 ref		like reference_node based (ref_p);

  if ref.type = pascal_text_file_dtype
    then
         return ("1"b);

  if ref.type = pascal_user_defined_type_instance_dtype then do;
      dcl 1 type_info	    like runtime_type_info;
      type_info.version = RUNTIME_TYPE_INFO_VERSION_1;
      call runtime_symbol_info_$type (ref.type_ptr, addr (type_info), code);
      if code ^= 0
        then go to SOME_ERROR;
      if type_info.type = pascal_record_file_type_dtype
        then
	   return ("1"b);
    end;
  return ("0"b);

  end is_file;


    end;				/* begin block for PASCAL call */
%page;


MAIN_RETURN:			/* standard exit */
  P_code = 0;
  return;


SOME_ERROR:			/* error exit */
  P_code = code;
  return;


RECORDED_MESSAGE:
  code = probe_et_$recorded_message;
  goto SOME_ERROR;

%page;
%include probe_info;
%page;
%include probe_source_info;
%page;
%include probe_tokens;
%page;
%include probe_references;
%page;
%include std_descriptor_types;
%page;
%include acc;
%page;
%include runtime_symbol_info_;
%page;
%include probe_seg_info;
%page;
%include pascal_symbol_node;
%page;
%include system;

  end;				/* external procedure probe_invoke_ */




		    probe_lang_type_.pl1            10/24/88  1619.8rew 10/24/88  1342.8       23301



/****^  ***********************************************************
        *                                                         *
        * 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_lang_type_:
  proc (compiler_name) returns (fixed bin);

  /* given the name of a compiler, return the PROBE language code
   some of these names will not be found in object segments, but
   may be typed in by user in the PROBE "Lang" request

   James R. Davis 22 June 79
   Melanie Weaver 31 July 1981 for algol68 */
  /* Modified June 83 JMAthane to add PASCAL */
  /* Modified April 88 Hinatsu to add C */

  dcl compiler_name		char (*);

  if compiler_name = "PL/I" | compiler_name = "pl1" | compiler_name = "PL1"
    then return (PL1_lang_type);

  else if compiler_name = "FORTRAN" | compiler_name = "fortran"
       | compiler_name = "fortran2" |
       compiler_name = "FT" | compiler_name = "ft"
    then return (FORTRAN_lang_type);

  else if compiler_name = "COBOL" | compiler_name = "cobol"
    then return (COBOL_lang_type);

  else if compiler_name = "ALM" | compiler_name = "alm"
    then return (ALM_lang_type);

  else if compiler_name = "ALGOL68" | compiler_name = "Algol68"
       | compiler_name = "algol68" | compiler_name = "a68"
    then return (ALGOL68_lang_type);

  else if compiler_name = "PASCAL" | compiler_name = "pascal"
    then return (PASCAL_lang_type);

  else if compiler_name = "C" | compiler_name = "c"
    then return (C_lang_type);

  else return (OTHER_lang_type);

%include probe_lang_types;

  end probe_lang_type_;




		    probe_language_request_.pl1     10/27/88  1250.2r w 10/27/88  1224.4       22131



/****^  ***********************************************************
        *                                                         *
        * 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_language_request_:
  proc (P_probe_info_ptr);

  dcl P_probe_info_ptr	ptr parameter;
  dcl null		builtin;

  dcl probe_lang_type_	entry (char (*)) returns (fixed bin);

  dcl probe_error_		entry options (variable);
  dcl ioa_$ioa_switch	entry options (variable);

  dcl probe_et_$too_many_args fixed bin (35) external static;

  probe_info_ptr = P_probe_info_ptr;

  if probe_info.ct -> token.type >= probe_info.end_token
    then call ioa_$ioa_switch (probe_info.output_switch,
	    "Current language is ^a",
	    official_language_names (probe_info.language_type));
    else do;
      if probe_info.ct -> token.type ^= NAME_TYPE
        then call probe_error_ (probe_info_ptr, 0,
	        "A language name is required");
      if probe_info.ct -> token.next = null () |
	 probe_info.ct -> token.next -> token.type < probe_info.end_token
        then call probe_error_ (probe_info_ptr, probe_et_$too_many_args);

      probe_info.language_type = probe_lang_type_ (current_identifier_name);
      probe_info.ct = probe_info.ct -> token.next;
    end;				/* setting the lang */

  return;



%include probe_info;

  /* ;;;;;;; */

%include probe_tokens;

  /* ;;;;;;; */

%include probe_lang_types;

  end probe_language_request_;




		    probe_line_number_.pl1          10/24/88  1619.8rew 10/24/88  1339.0       37548



/****^  ***********************************************************
        *                                                         *
        * 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_line_number_:
  proc (P_probe_info_ptr, P_statement_entry) returns (char (64));

  /* *	This routine is used to format a line number (including file and statement numbers) for output.
   *	It takes as an argument a pointer to the statement map entry for the line desired.
   *
   *	Initial Version:  12 August 1974 by Jeffrey M. Broughton
   *	Converted to probe 4.0 05/27/79 W. Olin Sibert
   */

  dcl P_probe_info_ptr	pointer parameter;

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

  dcl 1 P_statement_entry	aligned like source_info;
				/* statement to be printed */

  dcl probe_info_ptr	pointer;	/* to avoid including the whole mess */

  dcl statement_map_ptr	pointer;	/* pointer to entry for this line */
  dcl name_wanted		bit (1);	/* tells whether name is  wanted */
  dcl j			fixed bin;/* tells which format to use */
  dcl i			fixed bin;
  dcl (f, l, s)		fixed bin;/* file, line, and statement numbers */

  dcl proc_name		character (32);
				/* procedure segname, we hope */
  dcl string		char (64);/* return string */

  dcl 1 map_array		(1) based aligned like statement_map;

  dcl ioa_$rsnnl		entry options (variable);

  dcl format		(0:3) char (32) varying internal static
			options (constant)
			init /* formats to use when building number */
			("line ^d",
			"line ^d,^d",
			"line ^d-^d",
			"line ^d-^d,^d");
				/*  */
  name_wanted = "0"b;
  goto COMMON;


probe_line_number_$proc:
  entry (P_probe_info_ptr, P_statement_entry) returns (character (64));
  name_wanted = "1"b;
  go to COMMON;


COMMON:
  probe_info_ptr = P_probe_info_ptr;

  if P_statement_entry.seg_info_ptr = null ()
    then
         return ("unknown line");

  statement_map_ptr =
       P_statement_entry.seg_info_ptr -> seg_info.statement_map_ptr;
  if statement_map_ptr = null ()
    then
         return ("unknown line");

  statement_map_ptr =
       addr (statement_map_ptr
       -> map_array (P_statement_entry.stmnt_map_entry_index));

  f = fixed (statement_map_ptr -> statement_map.file, 17, 0);
				/* unpack these numbers */
  l = fixed (statement_map_ptr -> statement_map.line, 17, 0);
  s = fixed (statement_map_ptr -> statement_map.statement, 17, 0);

  if s < 2
    then j = 0;			/* don't include statment number */
    else j = 1;

  if f = 0
    then /* don't include file number */
         call ioa_$rsnnl (format (j), string, i, l, s);
    else call ioa_$rsnnl (format (j + 2), string, i, f, l, s);

  if name_wanted then do;
      proc_name = P_statement_entry.seg_info_ptr -> seg_info.segname;
      if proc_name = "" then do;
	proc_name = P_statement_entry.seg_info_ptr -> seg_info.entry_name;
	if proc_name = ""
	  then proc_name = "unknown?";
        end;
      substr (string, i + 1) = " of " || proc_name;
    end;
  return (string);

  /*  */

%include statement_map;

  /* ;;;;;;; */

%include probe_source_info;

  /* ;;;;;;; */

%include probe_seg_info;

  end;				/* external procedure probe_line_number_ */




		    probe_listen_.pl1               10/27/88  1250.2r w 10/27/88  1224.4      202095



/****^  ***********************************************************
        *                                                         *
        * 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-07-02,LJAdams), approve(86-07-23,MCR7464),
     audit(86-07-23,GDixon), install(86-07-24,MR12.0-1103):
     probe_info.input_switch was not maintaining the correct value through
     different invocations of probe; e.g., after a break point had been
     executed.  Problem fixed.
  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 */

probe_listen_:
  procedure (P_probe_info_ptr, P_code);

  /* *	Listener procedure for the "probe" debugger
   *	Created out of subsystem_listen_, 0/22/79 W. Olin Sibert
   Modified JRD 16 Oct 79
   Modified 09/21/80 WOS, to fix so errors in breakpoints will call listener (bug 188)

   entries here:

   listen - basic read/eval loop
   interpret_line and check_line - take line as parameter

   These entries have to be careful of each other, because you can be called with the
   same probe_info in effect.  For example, while at probe top level (listen_) you can call
   "if", which used interpret_line, or try to set a break, which uses check_line.
   You can also be using interpret_line to execute a break list, see a "halt", which
   will call listen.  In this, rarer, case,  i think it is sufficient to save/restore
   probe_info.ct
*/
  /* Made to skip leading whitespace and not prompt after blank line 09/10/81 S. Herbst */
  /* Made prompt mode static 04/26/82 S. Herbst */
  /* Made cleanup handler reset probe_static_info.last_break_segno (recursive breaks in probe) 08/15/83 S. Herbst */

  dcl (
      P_probe_info_ptr	pointer,	/* -> probe info (Input) */
      P_request_line_ptr	pointer,
      P_request_line_lth	fixed bin (21),
      P_code		fixed binary (35)
      )			parameter;

  dcl WHITE		char (4) int static options (constant)
			init /* SP HT FF NL */ (" 	
");

  dcl execute_bit		bit (1) aligned;
				/* new value of probe_info.flags.execute */

  dcl 1 saved_info		automatic aligned,
				/* various information to be saved/restored */
       2 input_type		fixed bin,
       2 work_area_ptr	pointer unaligned,
       2 expression_area_ptr	pointer unaligned,
       2 request_name	character (32) varying,
       2 abort_probe_label	label variable,
       2 abort_line_label	label variable,
       2 token_info		like probe_info.token_info,
       2 flags		aligned like probe_info.flags,
       2 ct		ptr unal;

  dcl code		fixed binary (35);

  dcl (input_ptr, original_input_ptr)
			pointer;	/* pointer to current location in input string */
  dcl (input_lth, input_used_lth)
			fixed bin (21);
  dcl input_string		char (input_lth) based (input_ptr);

  dcl input_buffer_ptr	pointer;
  dcl input_buffer_lth	fixed bin (21);
  dcl input_buffer		char (input_buffer_lth)
			based (input_buffer_ptr);
  dcl start		fixed bin (21);

  dcl local_work_area	area (1536) automatic;
				/* area for tokens, etc. */

  dcl add_char_offset_	entry (ptr, fixed bin (21)) returns (ptr);
  dcl com_err_		entry () options (variable);
  dcl cu_$cp		entry (pointer, fixed binary (21),
			fixed binary (35));
  dcl cu_$grow_stack_frame	entry (fixed bin (18), ptr, fixed bin (35));
  dcl continue_to_signal_	entry (fixed bin (35));
  dcl ioa_$ioa_switch	entry options (variable);
  dcl ioa_$ioa_switch_nnl	entry options (variable);
  dcl iox_$control		entry (pointer, char (*), pointer,
			fixed bin (35));
  dcl iox_$get_line		entry (pointer, pointer, fixed binary (21),
			fixed binary (21), fixed binary (35));

  dcl probe_announce_entry_	entry (ptr);
  dcl probe_listen_		entry (ptr, fixed bin (35));
  dcl probe_scan_input_	entry (pointer, pointer, fixed bin (21),
			pointer,
			fixed bin, fixed bin (21), pointer,
			fixed bin (35));
  dcl probe_error_		entry options (variable);
  dcl probe_fault_handler_	entry (ptr);

  dcl (
      iox_$user_input,
      iox_$error_output
      )			pointer external static;

  dcl (
      error_table_$unimplemented_version,
      error_table_$long_record,
      error_table_$end_of_info,
      error_table_$short_record
      )			fixed bin (35) external static;

  dcl (
      probe_et_$syntax_error,
      probe_et_$complex_expr,
      probe_et_$convert_err,
      probe_et_$error_in_break,
      probe_et_$program_interrupt
      )			fixed binary (35) external static;

  dcl (cleanup, program_interrupt, area, conversion, any_other)
			condition;

  dcl (addr, empty, length, max, null, ptr, size, substr, verify)
			builtin;
				/*  */

listen:
  entry (P_probe_info_ptr, P_code);

  probe_info_ptr = P_probe_info_ptr;

  if probe_info.probe_info_version ^= probe_info_version_1 then do;
      P_code = error_table_$unimplemented_version;
      return;
    end;

  saved_info.ct = probe_info.ct;

  probe_info.abort_probe_label = LISTEN_RETURN;
  probe_info.abort_line_label = READ;

  on program_interrupt
    begin;			/* set up our various condition handlers */
    call process_interruption ();
    goto probe_info.abort_line_label;	/* do a non-local GOTO out of here */
  end;

  on cleanup
    call clean_up_listener ();

  on area
    begin;			/* catch problems with our areas */
    if probe_modes.ignore_faults
      then
	 call continue_to_signal_ ((0));
      else call probe_error_ (probe_info_ptr, probe_et_$complex_expr);
  end;

  on conversion
    begin;			/* catch conversion errors */
    if probe_modes.ignore_faults
      then
	 call continue_to_signal_ ((0));
      else call probe_error_ (probe_info_ptr, probe_et_$convert_err);
  end;

  on any_other
    begin;			/* this will handle any other problems */
    if probe_modes.ignore_faults
      then
	 call continue_to_signal_ ((0));
      else call probe_fault_handler_ (probe_info_ptr);
  end;

  probe_info.in_listener = "1"b;	/* running the listener */

  /* LISTENER LOOP */

  call initialize_console_reading ();

  probe_info.work_area_ptr = addr (local_work_area);

  probe_info.input_type = CONSOLE_INPUT;
  code = 0;			/* no errors encountered */

  do while ("1"b);			/* exit is via call to abort_probe */
READ:

    probe_info.flags.executing_request = "0"b;
				/* not executing now */
    input_lth = 0;			/* reset the input buffer */

    call read_from_console ();
    call process_input_line ();
  end;				/* of listener loop */

LISTEN_RETURN:
  call clean_up_listener ();

  P_code = code;			/* code will be set if an error or interruption occurred */

  return;


clean_up_listener:
  proc;

  probe_info.static_info_ptr -> probe_static_info.last_break_segno = "0"b;
  probe_info.ct = saved_info.ct;

  end clean_up_listener;
				/*  */

interpret_line:
  entry (P_probe_info_ptr, P_request_line_ptr, P_request_line_lth, P_code);

  /* *	These two entries are used to process individual request lines.
   *	The interpret_line entry executes the request line, and the check_line
   *	entry just checks it for syntax. Both entries save the old state of the
   *	listener, and restore it upon return or cleanup.

   * called from break_handler, or to check syntax
*/

  execute_bit = "1"b;
  goto INTERPRET_LINE_COMMON;


check_line:
  entry (P_probe_info_ptr, P_request_line_ptr, P_request_line_lth, P_code);

  execute_bit = "0"b;
  goto INTERPRET_LINE_COMMON;


INTERPRET_LINE_COMMON:
  probe_info_ptr = P_probe_info_ptr;

  if probe_info.probe_info_version ^= probe_info_version_1 then do;
      P_code = error_table_$unimplemented_version;
      return;
    end;

  if ^probe_info.in_listener & ^probe_info.in_interpret_line then do;
				/* only if lowest level */
      probe_info.abort_probe_label = INTERPRET_LINE_RETURN;
      probe_info.abort_line_label = INTERPRET_LINE_RETURN;

      on program_interrupt
        begin;			/* if no listener, punt on program_interrupt */
        code = probe_et_$program_interrupt;
				/* indicate why we returned */
        goto probe_info.abort_line_label;
      end;

      on area
        begin;			/* set up other handlers as well, if no listener */
        if probe_modes.ignore_faults
	then
	     call continue_to_signal_ ((0));
	else call probe_error_ (probe_info_ptr, probe_et_$complex_expr);
      end;

      on conversion
        begin;			/* catch conversion errors */
        if probe_modes.ignore_faults
	then
	     call continue_to_signal_ ((0));
	else call probe_error_ (probe_info_ptr, probe_et_$convert_err);
      end;

      on any_other
        begin;			/* this will handle any other problems */
        if probe_modes.ignore_faults
	then
	     call continue_to_signal_ ((0));
	else call probe_fault_handler_ (probe_info_ptr);
      end;

      probe_info.in_interpret_line = "1"b;
				/* indicate whats happening */
    end;				/* of setting up handlers when there is no listener already */

  call save_probe_info ();		/* save the relevant parts */

  on cleanup /* this will restore the things copied above */
    call clean_up_interpret_line ();

  probe_info.flags.execute = execute_bit;
  probe_info.flags.executing_request = "0"b;
  probe_info.work_area_ptr = addr (local_work_area);

  input_ptr = P_request_line_ptr;
  input_lth = P_request_line_lth;
  code = 0;			/* no errors encountered yet */

  call process_input_line ();

  call clean_up_interpret_line ();	/* All done */
  P_code = 0;
  return;				/* successful return */

INTERPRET_LINE_RETURN:

  call process_interruption ();

  call clean_up_interpret_line ();

  P_code = code;			/* code will be set if an error or interruption occurred */
  return;				/* end of code for $interpret_line entry */


clean_up_interpret_line:
  proc ();

  /* *	This is the cleanup handler for probe_listen_$interpret_line */


  probe_info.input_type = saved_info.input_type;
  probe_info.work_area_ptr = saved_info.work_area_ptr;
  probe_info.expression_area_ptr = saved_info.expression_area_ptr;
  probe_info.request_name = saved_info.request_name;
  probe_info.abort_probe_label = saved_info.abort_probe_label;
  probe_info.abort_line_label = saved_info.abort_line_label;
  probe_info.token_info = saved_info.token_info;
  probe_info.flags = saved_info.flags;
  return;
  end;

save_probe_info:
  proc ();

  /* *	This procedure saves the relevant parts of probe_info, which are restored by the code above */

  saved_info.input_type = probe_info.input_type;
  saved_info.work_area_ptr = probe_info.work_area_ptr;
  saved_info.expression_area_ptr = probe_info.expression_area_ptr;
  saved_info.request_name = probe_info.request_name;
  saved_info.abort_probe_label = probe_info.abort_probe_label;
  saved_info.abort_line_label = probe_info.abort_line_label;
  saved_info.token_info = probe_info.token_info;
  saved_info.flags = probe_info.flags;
  return;
  end;				/* internal procedure save_probe_info */

  /*  */

process_interruption:
  proc ();

  /* This procedure exists to flush command streams, and put the user in a consistent
   state after an error or quit. */

  if probe_info.input_type = CONSOLE_INPUT then do;
				/* then input is from console */
      input_lth = 0;		/* flush read ahead */
      call iox_$control (probe_info.input_switch, "resetread", (null ()), (0))
	 ;
      code = probe_et_$program_interrupt;
    end;

    else do;			/* input was from a break */

      /* the old probe only gave this message in "long" mode - in m y opinion
   it is too important to ever ignore */

      call ioa_$ioa_switch (iox_$error_output,
	 "Break aborted. Type ""continue"" to restart program.");

      /* Strategy will be to flush commands left in break command list and "stop"
   Simulate a stop, then return */

      call probe_announce_entry_ (probe_info_ptr);

      call probe_listen_ (probe_info_ptr, (0));

      code = probe_et_$error_in_break;
    end;

  end;				/* process_interruption internal procedure */

  /*  */

process_input_line:
  proc ();

  /* This internal procedure processes the current input buffer

   GLOBAL INPUT/OUTPUT: input_ptr, input_lth, input_used_lth
   i smell a kludge.

   Note that language can change while executing a request.  probe_scan_input stops at the end
   of  a statement, so we resume scan, under possibly new conditions
*/

  dcl first_token		pointer;	/* first token of current command */
  dcl next_token		pointer;	/* to next command to be parsed */
  dcl exhausted		bit (1) aligned;
				/* have we reached the end of an input string */

  probe_info.end_token = SEMI_COLON;

  exhausted = "0"b;			/* to begin with, input string is full */

  do while (^exhausted);		/* execute until we run out of string */
    work_area = empty ();		/* initialize token storage */

    call probe_scan_input_ (probe_info_ptr, input_ptr, input_lth,
         addr (work_area),
         probe_info.language_type, input_used_lth, first_token, code);

    if code ^= 0
      then /* error detected scanning input */
	 call probe_error_ (probe_info_ptr, code);

    /* interpret the tokenized input */

    do probe_info.ct = first_token repeat next_token
         while (probe_info.ct ^= null);
				/* loop through all the tokens */
      if probe_info.ct -> token.type = NAME_TYPE then do;
				/* should be a keyword */

	dcl request_entry_variable  entry variable options (variable);

	dcl old_expression_area_ptr pointer;

	/* *	This is the area used for keeping reference_nodes, among other things. It should
   *	probably be an extensible area, so it would be smaller and take up less stack frame,
   *	but I'm not sure whether that works yet.  -- wos, 07/16/79 */

	dcl local_expression_area   area (4100) automatic;

	dcl probe_request_mgr_$find_request
			        entry (ptr, char (*), entry, pointer,
			        fixed bin (35));


	old_expression_area_ptr = probe_info.expression_area_ptr;
				/* set up to save/restore */

	on cleanup
	  begin;
	  probe_info.expression_area_ptr = old_expression_area_ptr;
	end;

	local_expression_area = empty ();

	probe_info.expression_area_ptr = addr (local_expression_area);

	call probe_request_mgr_$find_request (probe_info_ptr,
	     current_identifier_name,
	     request_entry_variable, probe_request_info_ptr, code);

	if code ^= 0
	  then call probe_error_ (probe_info_ptr, code);

	probe_request_table_ptr = ptr (probe_request_info_ptr, 0);
				/* find out its primary name */
	request_namelist_ptr = ptr (probe_request_table_ptr,
	     probe_request_info.namelist_loc);

	probe_info.ct = probe_info.ct -> token.next;
	probe_info.request_name = request_namelist.names (1);
	probe_info.executing_request = "1"b;
				/* at last */

	call request_entry_variable (probe_info_ptr);

	probe_info.executing_request = "0"b;
				/* if it bothers to return */


        end;

      else if probe_info.ct -> operator.type = PERIOD then do;
				/* tell user who we are */
	probe_info.ct = probe_info.ct -> token.next;
				/* keep syntax okay */
	if probe_info.ct -> token.type = PERIOD
				/* has a .. in bad place */
	  then call ioa_$ioa_switch (iox_$error_output,
		  "The .. escape convention can be used only at the beginning of a line"
		  );
	if probe_info.ct -> token.type < probe_info.end_token
	  then
	       call probe_error_ (probe_info_ptr, probe_et_$syntax_error);
	if probe_info.execute
	  then
	       call ioa_$ioa_switch (probe_info.output_switch,
		  probe_static_info.version_string);
        end;

      else if probe_info.ct -> token.type >= probe_info.end_token
        then ;			/* do nothing, skip this one */

      else call probe_error_ (probe_info_ptr, probe_et_$syntax_error);
				/* constant doesn't belong here */
      next_token = probe_info.ct -> token.next;
    end;				/* of loop through tokens */

    input_ptr = addr (substr (input_ptr -> input_string, input_used_lth + 1));
    input_lth = max (0, input_lth - input_used_lth);
    if input_lth = 0
      then exhausted = "1"b;
      else exhausted = "0"b;
  end;				/* of loop through commands in a line */
  return;
  end;				/* process_input_line internal procedure */

  /*  */

read_from_console:
  proc ();

  /* *	This procedure reads input from the current input switch. Since it grows probe's
   *	stack frame so it can hold the input buffer, it must be quick. It does not
   *	assume that it is the only procedure extending the stack, and therefore does
   *	not assume that grow_stack_frame will allocate contiguous blocks.

   * GLOBAL import: original_input_ptr, maybe others? is this a kludge Olin?
*/

  dcl initial_input_buffer	char (256) aligned based;
				/* the first console buffer, grown with our first call */

  dcl read_ptr		pointer;
  dcl (total_input_lth, original_input_lth, this_input_lth)
			fixed bin (21);

  dcl (old_buffer_ptr, new_buffer_ptr)
			pointer;
  dcl (old_buffer_lth, new_buffer_lth)
			fixed bin (21);
  dcl old_buffer		char (old_buffer_lth) based (old_buffer_ptr);
  dcl new_buffer		char (new_buffer_lth) based (new_buffer_ptr);

  total_input_lth = input_lth;	/* it started out empty */
  original_input_lth = input_lth;	/* so we can revert from a ".." */
  read_ptr = addr (substr (input_buffer, (total_input_lth + 1), 1));
				/* start reading right after last input */

print_prompt_and_read:
  if probe_static_info.prompt_on_sw	/* print the prompt */
    then call ioa_$ioa_switch_nnl (probe_info.output_switch,
	    probe_static_info.prompt,
	    probe_info.depth > 1, probe_info.depth);

console_read_loop:
  call iox_$get_line (probe_info.input_switch, read_ptr,
       (input_buffer_lth - total_input_lth), this_input_lth, code);

  if code = 0 then do;		/* read successfully */
      input_lth = this_input_lth + total_input_lth;
    end;				/* of case for code = 0 */

  else if code = error_table_$long_record then do;
				/* must grow stack frame for the rest of this */
      old_buffer_ptr = input_buffer_ptr;
      old_buffer_lth = input_buffer_lth;
      new_buffer_lth = old_buffer_lth * 2;
				/* twice as much room */

      call cu_$grow_stack_frame (size (new_buffer), new_buffer_ptr, code);
      if code ^= 0
        then goto probe_info.abort_line_label;

      new_buffer = old_buffer;
      read_ptr = addr (substr (new_buffer, old_buffer_lth + 1, 1));
				/* where to start reading more input */
      total_input_lth = total_input_lth + this_input_lth;

      input_buffer_ptr = new_buffer_ptr;
      input_buffer_lth = new_buffer_lth;/* copy into the global values */
      goto console_read_loop;		/* and try reading some more */
    end;				/* of case for error_table_$long_record */

  else if code = error_table_$end_of_info then do;
      call com_err_ (0, probe_static_info.name,
	 "End of information reached reading switch ""^a"". Reverting to user_input.",
	 probe_info.input_switch -> iocb.name);
      probe_info.input_switch = iox_$user_input;
				/* revert to user_input */
      input_lth = this_input_lth + total_input_lth;
    end;				/* of case for error_table_$end_of_info */

  else if code = error_table_$short_record then do;
				/* pretty unlikely.... */
      if this_input_lth = 0 then do;
	call com_err_ (0, probe_static_info.name,
	     "End of information reached reading switch ""^a"". Reverting to user_input.",
	     probe_info.input_switch -> iocb.name);
	probe_info.input_switch = iox_$user_input;
				/* revert to user_input */
        end;
      input_lth = this_input_lth + total_input_lth;
    end;

  else do;			/* something pretty bonkers.... */
    call com_err_ (code, probe_static_info.name,
         "Reading switch ^a. Reverting to user_input.",
         probe_info.input_switch -> iocb.name);
    call probe_error_ (probe_info_ptr, code);
    input_lth = 0;			/* Sorry, nothing there */
  end;

  if input_lth = 1
    then go to console_read_loop;	/* no prompt after blank line */

  start = verify (input_buffer, WHITE);
  if start = 0
    then go to console_read_loop;	/* line consisting entirely of white space */
  if start > 1 then do;		/* skip leading whitespace */
      input_buffer_ptr = add_char_offset_ (input_buffer_ptr, start - 1);
      input_buffer_lth = input_buffer_lth - start + 1;
      input_lth = input_lth - start + 1;
    end;
  if input_lth > 2 then do;		/* check for ".." escape convention */
      if substr (input_buffer, 1, 2) = ".." then do;
	call cu_$cp (addr (substr (input_buffer, 3, 1)), (input_lth - 2),
	     (0));

	input_lth = original_input_lth;
				/* revert to original buffer contents, and get more input */
	read_ptr = addr (substr (input_buffer, (input_lth + 1), 1));
	total_input_lth = input_lth;
	goto print_prompt_and_read;
        end;
    end;				/* of checking for ".." escape */

  input_ptr, original_input_ptr = input_buffer_ptr;
  return;				/* end of code for read_from_console entrypoint */


initialize_console_reading:
  entry ();			/* entry to initialize stuff */

  probe_info.input_switch = probe_static_info.input_switch;

  call cu_$grow_stack_frame (size (initial_input_buffer), input_buffer_ptr,
       code);
				/* try to grab first buffer */
  if code ^= 0
    then goto probe_info.abort_line_label;

  input_buffer_lth = length (input_buffer_ptr -> initial_input_buffer);
  input_lth = 0;			/* nothing in it, right now */

  input_ptr, original_input_ptr = input_buffer_ptr;
  return;				/* end of code for initialization entry point */
  end;				/* read_from_console internal procedure */

%page;
%include probe_info;
%page;
%include probe_static_info;
%page;
%include probe_info_constants;
%page;
%include probe_modes;
%page;
%include probe_tokens;
%page;
%include probe_operators;
%page;
%include probe_request_table;
%page;
%include iocb;

  end probe_listen_;		/* external procedure */




		    probe_map_sequence_.alm         10/24/88  1619.8rew 10/24/88  1344.0       50355



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

" HISTORY COMMENTS:
"  1) change(87-06-18,RWaters), approve(87-06-18,MCR7687),
"     audit(87-06-24,Huen), install(87-07-15,MR12.1-1040):
"     Probe error #109: restore indicator registors correctly.
"  2) 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 code is placed in the break map header in order to
"	save registers, call the debugger, and restore the registers.
"	Also has template code sequences for break slots.
"
"		Initial Version:  1 July 1974  --  Jeffrey M. Broughton
"		       Modified:  13 August 1975 by JMB for new break sequence
"		       Modified:  05 May 1977 by B. Greenberg for spri/lpri in
"						break slot s.t. cobol works
"		       Comments added: JRD 12 Sept 79
"
"		       Modified:  12 March 1984 by M. Weaver to copy return ptr as bit string
"		       Modified:  01 May 1984 by S. Herbst to move sreg instruction before new sequence
"			to copy return_ptr, which changes q register.
"                          Modified:  05 May 1987 by R. Waters to correctly restore the indicator registers after continuing from a break.
"

	name	probe_map_sequence_

	equ	probe_extension_size,32

	segdef	code		This is the start of the code sequence
	segdef	return		This is the code to return from a break
	segdef	old_return
	segdef	count		This is the number of words of code here
	segdef	after_code	Slot sequences
	segdef	before_code


	equ	pointers,0	Will store pointer registers at start of extension
	equ	registers,16	And registers at offset 16 (decimal)
	equ	indicators,26	Indicators at offset 26
	equ	slot_ptr,28	Return ptr into slot left here
	equ	old_retptr_value,30	Old value of stack_frame.return_ptr
"	see probe_break_extension.incl.pl1

	equ	break_op,4	Offset in operator pointers of break handler ptr

" 

	even
code:
"
"	called with lb set to return addr in map sequence code
"
	rem			develop address of extension
	eppbp	sp|stack_frame.next_sp,*	grow frame 32 words
	epbpsb	sp|0
	eppbb	bp|probe_extension_size	bb -> new "next_sp"
	even
	inhibit	on
	spribb	sp|stack_frame.next_sp	grow frame to hold extension
	spribb	sb|stack_header.stack_end_ptr
	inhibit	off

	sti	bp|indicators
	sreg	bp|registers		save in extension
	ldaq	sp|stack_frame.return_ptr	pick up old ret_ptr, retaining any indicators
	staq	bp|old_retptr_value		save it
	sprilb	bp|slot_ptr		save before/after-code ret addr

	eppbp	return-*,ic		remember where to return to
	spribp	sp|stack_frame.return_ptr	PL/I to return to "return"
	epplp	sp|stack_frame.lp_ptr,*	restore linkage ptr
	eppap	arg_list-*,ic		set up ptr to arg list
	eppbp	sb|stack_header.trans_op_tv_ptr,*	to operator_pointers_
	callsp	bp|break_op,*		call break handler

return:
	eppbp	sp|stack_frame.next_sp,*	find extension
	eppbp	bp|-probe_extension_size		bp -> extension
	spbpsb	sp|0

	ldaq	bp|old_retptr_value		"get saved info - saved indicators may show as tag bits
	staq	sp|stack_frame.return_ptr
	ldaq	spec_inst-*,ic		"get a pair of clever instructions
	staq	bp|old_retptr_value		"put them into the extension
	ldi	bp|indicators		"restore
	lreg	bp|registers

	even
	inhibit	on			"shrink the stack
	spribp	sp|stack_frame.next_sp
	spribp	sb|stack_header.stack_end_ptr
	inhibit 	off

	tra	bp|old_retptr_value			go to break slot code

	even
arg_list:
	zero	0,4			arglist header (no args)
	zero	0,0

	even

"	these two instructions are placed on the stack and executed there!
"	they are placed on top of a pointer in the extension
"	the first of the pair is at loc old_retptr_value.  When executed, ic is the offset of
"	old_retptr_value, so this loads the prs from the base of the extension.
"	the second transfers in analogous way thru the ptr at slot_ptr 8which is a misnomer, for
"	it is really the return address)
spec_inst:
	lpri	-old_retptr_value,ic
	tra	slot_ptr-(old_retptr_value+1),ic*

count:	zero	0,count-code		number of words used


old_return:
	eppbp	sp|stack_frame.next_sp,*	find extension
	eppbp	bp|-32
	spbpsb	sp|0

	eppbb	bp|slot_ptr,*		restore saved info
	spribb	sp|stack_frame.return_ptr
	ldi	bp|indicators
	lreg	bp|registers

	inhibit	on
	spribp	sp|stack_frame.next_sp
	spribp	sb|stack_header.stack_end_ptr
	inhibit 	off

	lpri	sp|stack_frame.next_sp,*	restore pointers
	rtcd	sp|stack_frame.return_ptr

"	These are the template code sequences for the break slot code.
"
before_code:
	spri	sp|stack_frame.next_sp,*	save ALL PR'S!
	tsplb	*-*			go to map code- probe patches this
	nop	0,du		DU holds offset of slot
	nop	0,du		to be replaced by instruction
	nop 	0,du
	nop	0,du
	nop	0,du
	tra	0		to loc + inst_length


after_code:
	nop	0,du		instruction
	nop	0,du
	nop 	0,du
	nop	0,du
	spri	sp|stack_frame.next_sp,*	save ALL PR'S
	tsplb	*-*			go to map code- patched by probe
	nop	0,du		slot offset
	tra	0		to loc + inst_length
" 


	include	stack_header
	include	stack_frame
	end




		    probe_modes_mgr_.pl1            10/27/88  1250.2r w 10/27/88  1224.4      105957



/****^  ***********************************************************
        *                                                         *
        * 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_modes_mgr_:
  proc ();

  call probe_error_$malfunction ();	/* dummy entry */

  /* This is a start at the modes_manager_ written so that
   code which needs it can at least be debugged

   James R. Davis  12 July 79
   Modified 15 Sept 79 to hide set_modes and print_modes from world

   *** ENTRIES HERE ***

   mode_request		- implements probe's "mode" request
   excludep		- tells whether or not a given  name should be excluded
*/
  /* Made prompt mode static 04/26/82 S. Herbst */
  /* Added "mode meter" to meter time, vcpu and pf's at halts 09/23/82 S. Herbst */
  /* Added "mode truncate_strings" 05/21/84 S. Herbst */

  /* COMMON PARAMETERS */

  dcl P_probe_info_ptr	ptr parameter;
  dcl P_acc_ptr		ptr parameter;
				/* input: to an acc string */
  dcl P_probe_modes_ptr	pointer parameter;
				/* input: ptr to probe_modes structure to be init'd */

  /* the OFFICIAL names of the values of the len-type probe modes for i = 1 to 3 */

  dcl official_mode_names	(3) char (8) aligned internal static
			options (constant)
			init ("brief", "short", "long");
  dcl unofficial_mode_names	(3) char (2) aligned internal static
			options (constant) init ("bf", "sh", "lg");

  dcl code		fixed bin (35);
				/* global error code */

  dcl probe_error_		entry options (variable);
  dcl probe_error_$record	entry options (variable);
  dcl probe_error_$malfunction
			entry options (variable);
  dcl cpu_time_and_paging_	entry (fixed bin, fixed bin (71), fixed bin);
  dcl ioa_$ioa_switch	entry options (variable);

  dcl (
      probe_et_$syntax_error,
      probe_et_$too_many_args
      )			fixed bin (35) external static;

  dcl (clock, fixed, hbound, lbound, length, string, vclock)
			builtin;
				/*  */

probe_modes_mgr_$mode_request:
  entry (P_probe_info_ptr);

  /* *	This entry implements the "mode" request for probe. It is here because this is
   *	where all the other stuff concerned with modes is kept. */

  probe_info_ptr = P_probe_info_ptr;

  if probe_info.ct -> token.type >= probe_info.end_token
    then call print_modes ();
    else call set_mode ();
  return;


probe_modes_mgr_$excludep:
  entry (P_probe_info_ptr, P_acc_ptr) returns (bit (1) aligned);

  /* DUMMY ENTRY FOR NOW */

  return ("0"b);			/* exclude nothing */


probe_modes_mgr_$init:
  entry (P_probe_modes_ptr);

  /* *	This is a special entry, called during probe initialization to set the per-process
   *	modes structure to its default values, either consed up out of whole cloth or
   *	copied from Person_id.probe. */

  string (P_probe_modes_ptr -> probe_modes.bits) = ""b;

  P_probe_modes_ptr -> probe_modes.len_modes = 0;
  P_probe_modes_ptr -> probe_modes.len_modes.error_messages = LONG_mode_type;
  P_probe_modes_ptr -> probe_modes.len_modes.qualification = SHORT_mode_type;
  P_probe_modes_ptr -> probe_modes.len_modes.value_print = LONG_mode_type;
				/* for now */

  P_probe_modes_ptr -> probe_modes.value_separator = " = ";
				/* fun to parse, eh? */
  P_probe_modes_ptr -> probe_modes.use_exclude_names = "0"b;
  P_probe_modes_ptr -> probe_modes.octal_bitstrings = "0"b;
  P_probe_modes_ptr -> probe_modes.use_prompt = "0"b;

  P_probe_modes_ptr -> probe_modes.debug_modes_set = "0"b;
				/* announce special debugging modes */
  P_probe_modes_ptr -> probe_modes.ignore_faults = "0"b;
  P_probe_modes_ptr -> probe_modes.catch_errors = "0"b;
  P_probe_modes_ptr -> probe_modes.catch_error_once = "0"b;
  P_probe_modes_ptr -> probe_modes.debug_breaks = "0"b;
  P_probe_modes_ptr -> probe_modes.debug = "0"b;
  P_probe_modes_ptr -> probe_modes.meter = "0"b;
  P_probe_modes_ptr -> probe_modes.truncate_strings = "1"b;
  return;				/* end of code for this entry */


  /* INTERNAL PROCEDURES: */

print_modes:
  proc;

  /* print the names of all modes and their values */

  call mp ("error_messages", probe_modes.error_messages);
  call mp ("qualification", probe_modes.qualification);
  call mp ("value_print", probe_modes.value_print);

  call bp ("truncate_strings", probe_modes.truncate_strings);
  call bp ("meter", probe_modes.meter);
  call bp ("prompt", probe_modes.use_prompt);
  if probe_modes.use_prompt
    then call ioa_$ioa_switch (probe_info.output_switch,
	    "prompt string = ""^va""",
	    length (probe_static_info.prompt), probe_static_info.prompt);

  /* we don't tell them about MAGIC modes such as debug = unless they are in debug mode */

  if probe_modes.debug_modes_set then do;
      call bp ("ignore_faults", probe_modes.ignore_faults);
      call bp ("catch_errors", probe_modes.catch_errors);
      call bp ("catch_error_once", probe_modes.catch_error_once);
      call bp ("debug_breaks", probe_modes.debug_breaks);
      call bp ("debug", probe_modes.debug);
    end;				/*  *MAGIC* modes */

  call ioa_$ioa_switch (probe_info.output_switch, "value_separator = ""^va""",
       length (probe_modes.value_separator), probe_modes.value_separator);

  /* add exclude name code later */
  return;



mp:
  proc (name, value);		/* if this were LISP, we wouldnt need this program */

  /* *	This prints the value of a mode which can be "short", "brief", or "long". */

  dcl name		char (*) parameter;
  dcl value		fixed bin parameter;

  if value >= lbound (official_mode_names, 1) &
       value <= hbound (official_mode_names, 1)
    then
         call ioa_$ioa_switch (probe_info.output_switch, "^a = ^a", name,
	    official_mode_names (value));
    else call probe_error_$malfunction (probe_info_ptr, 0,
	    "Bad value ^d for mode ^a", value, name);


  end mp;


bp:
  proc (name, bitv);

  /* *	This prints the value of a mode which is either ON or OFF. */

  dcl name		char (*) parameter;
  dcl bitv		bit (1) unal parameter;
  dcl bitv_name		(0:1) char (4) aligned internal static
			options (constant) init ("off", "on");

  call ioa_$ioa_switch (probe_info.output_switch, "^a: ^a", name,
       bitv_name (fixed (bitv)));
  end bp;

  end print_modes;

set_mode:
  proc;

  dcl identifiers_name	char (probe_info.ct -> identifier.length)
			based (probe_info.ct -> identifier.name);
  dcl constant_string	char (probe_info.ct -> constant.precision)
			based (probe_info.ct -> constant.data_ptr);
  dcl mode_name		char (32);
  dcl mode_value		char (32) varying;

  if probe_info.ct -> token.type ^= NAME_TYPE
    then
         call probe_error_ (probe_info_ptr, probe_et_$syntax_error,
	    "Invalid mode name.");

  mode_name = identifiers_name;

  probe_info.ct = probe_info.ct -> token.next;
				/* look at value for this mode */

  if probe_info.ct -> token.type >= end_token
    then
         call probe_error_ (probe_info_ptr, probe_et_$syntax_error,
	    "A value for the ^a mode must be specified", mode_name);

  if probe_info.ct -> token.type = NAME_TYPE
    then
         mode_value = identifiers_name;

  else if probe_info.ct -> token.type = CONSTANT_TYPE
       & probe_info.ct -> constant.data_type = char_dtype * 2
    then
         mode_value = constant_string;

  else call probe_error_
	  (probe_info_ptr, probe_et_$syntax_error, "Invalid mode value.");

  if probe_info.ct -> token.next -> token.type < probe_info.end_token
    then
         call probe_error_ (probe_info_ptr, probe_et_$too_many_args);

  if mode_name = "error_messages" | mode_name = "em"
    then
         probe_modes.error_messages = set_len ();
  else if mode_name = "qualification" | mode_name = "qf"
    then
         probe_modes.qualification = set_len ();
  else if mode_name = "value_print" | mode_name = "vp"
    then
         probe_modes.value_print = set_len ();
  else if mode_name = "value_separator" | mode_name = "vs"
    then
         probe_modes.value_separator = mode_value;

  else if mode_name = "meter" then do;	/* set metering of time, vcpu, pf's at halts */
      probe_modes.meter = set_bit ();
      if probe_modes.meter then do;
	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;
    end;

  else if mode_name = "truncate_strings"
    then /* set whether value req prints only 1st 200 */
         probe_modes.truncate_strings = set_bit ();

  else if mode_name = "prompt"
    then /* turn prompting on and off */
         probe_static_info.prompt_on_sw = set_bit ();
  else if mode_name = "prompt_string"
    then
         probe_static_info.prompt = mode_value;

  else if mode_name = "ignore_faults"
    then /* *MAGIC* */
         probe_modes.ignore_faults = set_bit ();
  else if mode_name = "catch_errors" | mode_name = "catch_error"
    then /* *MAGIC* */
         probe_modes.catch_errors = set_bit ();
  else if mode_name = "catch_error_once" | mode_name = "ceo"
    then /* *MAGIC* */
         probe_modes.catch_error_once = set_bit ();
  else if mode_name = "debug_breaks"
    then
         probe_modes.debug_breaks = set_bit ();
  else if mode_name = "debug"
    then
         probe_modes.debug = set_bit ();

  else call probe_error_ (probe_info_ptr, 0,
	  "There is no mode named ""^a""", mode_name);

  if probe_modes.ignore_faults
       | probe_modes.catch_errors /* see if any debugging modes are set */
       | probe_modes.catch_error_once | probe_modes.debug_breaks
       | probe_modes.debug
    then
         probe_modes.debug_modes_set = "1"b;
				/* and record that fact */
    else probe_modes.debug_modes_set = "0"b;
  return;


set_len:
  proc () returns (fixed bin);

  dcl i			fixed bin;


  do i = 1 to hbound (official_mode_names, 1);
    if mode_value = official_mode_names (i)
         | mode_value = unofficial_mode_names (i)
      then
	 return (i);
  end;

  call probe_error_ (probe_info_ptr, 0,
       """^a"" is not a valid value for the ""^a"" mode",
       mode_value, mode_name);
  end set_len;


set_bit:
  proc () returns (bit (1));

  if mode_value = "true" | mode_value = "on" | mode_value = "yes" |
       mode_value = "TRUE" | mode_value = "ON" | mode_value = "YES"
    then
         return ("1"b);

  else if mode_value = "false" | mode_value = "off" | mode_value = "no" |
       mode_value = "FALSE" | mode_value = "OFF" | mode_value = "NO"
    then
         return ("0"b);

  else call probe_error_ (probe_info_ptr, 0,
	  "The ""^a"" mode can only be set ""on"" or ""off""", mode_name);
  end set_bit;
  end set_mode;


  /* INCLUDE FILES: */



%include probe_info;

  /* ;;;;;;; */

%include probe_static_info;

  /* ;;;;;;; */

%include probe_modes;

  /* ;;;;;;; */

%include probe_tokens;

  /* ;;;;;;; */

%include acc;

  /* ;;;;;;; */

%include std_descriptor_types;

  end probe_modes_mgr_;




		    probe_operate_.pl1              11/11/88  1555.4r w 11/11/88  1545.0      382464



/****^  ***********************************************************
        *                                                         *
        * 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-08,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added the procedure 'c_pointer_arithmetic' to  perform addition and
     subraction on pointers.
  2) change(88-06-13,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Modified the 'infix' entry to detect the C_LEFT_SHIFT and C_RIGHT_SHIFT
     operators and call the new procedure 'c_shift_arithmetic'; the
     procedure that performs the shift.
  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-29,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Created the procedure 'c_mod_arithmetic' to perform the modulous
     operator. Better late than never.
                                                   END HISTORY COMMENTS */


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

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

probe_operate_:
  procedure ();

  call probe_error_$malfunction ();	/* cant call this entry */

  /* This procedure is used to perform simple arithmetic operations on one */
  /* or two values represented by reference nodes. Resultant value is      */
  /* allocated in supplied area, caller must ensure it is large enough. It */
  /* has two entries, infix and prefix, to do the appropriate kind of math */

  /* * 
  *       12 Aug 74, Jeffery M. Broughton:
  *          Initial Version.
  *       ?? Jul 77,  R.J.C. Kissel:
  *          To handle new data types.  When any_to_any_ is updated to handle
  *          all data types, all references to probe_assign_ should be changed
  *          to references to assign_ and probe_assign_ and probe_convert_ 
  *          should be deleted.
  *       ?? Oct 78, James R. Davis:
  *          To add multiplication and division.
  *       ?? Nov 78, JRD:
  *          To do temp allocs in supplied area, not free seg.
  *       ?? Dec 78, JRD:
  *          To check for valid decimal data before trying to use it.
  *       ?? May 79, JRD: 
  *          To use data_type_info_ and packed decimal.
  *       ?? May 79, WOS: 
  *          To convert to probe 4.0.
  *       ?? Nov 79, ???
  *          To use assign_computational_.
  *       31 Mar 80, ??? 
  *          To fix division MPRF 5504 probe bug 184.
  *       ?? Jun 83, JMAthane:
  *          For PASCAL : check for subrange types by calls to 
  *          probe_pascal_$real_type 
  *       17 Jan 84, S. Herbst:
  *          Changed to use generic float decimal types for results of hex 
  *          float computations.
  * */
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

  dcl (
      P_probe_info_ptr	pointer,
      P_opcode		char (1) aligned,
				/* (input) what to do */
      P_code		fixed bin (35),
      1 P_first		aligned like reference_node,
				/* (input) first operand of operation */
      1 P_second		aligned like reference_node,
				/* (input) second operand of infix ops */
      1 P_result		aligned like reference_node
      )			parameter;/* output */

  dcl MAX_GENFD_WORDS	fixed bin int static options (constant)
			init (17);
				/* 16 for fixed dec(59) mantissa, 1 for exp */

  dcl 1 source		(2) aligned like computational_data;
  dcl 1 intermediate	(2) aligned like computational_data;
  dcl 1 result		aligned like computational_data;

  dcl 1 operand		(2) aligned like reference_node;
				/* copies of first and second */

  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 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 1 an_encoded_precision	aligned like encoded_precision;

  dcl 1 type_bits_copy	aligned like type_bits;

  dcl 1 gen_decimal_struc	aligned based,
				/* format of real_flt_dec_generic_dtype */
       2 exponent		fixed bin (35),
       2 mantissa		fixed decimal (59);

  dcl 1 cplx_gen_decimal_struc
			aligned based,
				/* format of cplx_flt_dec_generic_dtype */
       2 (real, imaginary)	aligned like gen_decimal_struc;

  dcl (use_genfd_sw, use_genfd_complex_sw)
			bit (1);
  dcl genfd_type		fixed bin;

  dcl dp			pointer;	/* to storage of temporary */
  dcl op			(2) pointer;
				/* to intermediate values */
  dcl (alloc_size, i, temp_precision)
			fixed bin;

  dcl fixed_bin_real	fixed bin (71) real based;
				/* operand overlays */
  dcl fixed_bin_complex	fixed bin (71) complex based;
  dcl float_bin_real	float bin (63) real based;
  dcl float_bin_complex	float bin (63) complex based;
  dcl fixed_dec_real	fixed dec (59) real based;
  dcl fixed_dec_complex	fixed dec (59) complex based;
  dcl float_dec_real	float dec (59) real based;
  dcl float_dec_complex	float dec (59) complex based;

  dcl (
      probe_et_$bad_operand,
      probe_et_$bad_decimal,
      probe_et_$recorded_message
      )			fixed bin (35) external static;
  dcl probe_pascal_$real_type entry (fixed bin (35), ptr, fixed bin (35), ptr)
			;

  dcl valid_decimal_	entry (fixed bin, ptr, fixed bin)
			returns (bit (1));
  dcl assign_$computational_	entry (ptr, ptr, fixed bin (35));

  dcl (
      generic_math_$add_decimal,
      generic_math_$divide_decimal,
      generic_math_$multiply_decimal,
      generic_math_$subtract_decimal
      )
			entry (1 aligned like gen_decimal_struc,
			1 aligned like gen_decimal_struc,
			1 aligned like gen_decimal_struc);

  dcl (
      generic_math_$add_decimal_complex,
      generic_math_$divide_decimal_complex,
      generic_math_$multiply_decimal_complex,
      generic_math_$subtract_decimal_complex
      )
			entry (1 aligned like cplx_gen_decimal_struc,
			1 aligned like cplx_gen_decimal_struc,
			1 aligned like cplx_gen_decimal_struc);

  dcl generic_math_$negate_decimal
			entry (1 aligned like gen_decimal_struc,
			1 aligned like gen_decimal_struc);
  dcl generic_math_$negate_decimal_complex
			entry (1 aligned like cplx_gen_decimal_struc,
			1 aligned like cplx_gen_decimal_struc);

  dcl (
      probe_error_$malfunction,
      probe_error_$record
      )			entry options (variable);

  dcl (abs, addr, addrel, ceil, divide, fixed, hbound, lbound, mod,
      multiply, null, max, min, pointer, sign, string, substr, unspec)
			builtin;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

  /* *	The procdedure is simple:
   *	  1) Check the inputs.
   *	  2) Compute attributes of result and temporary.
   *	  3) Convert input to temporary.
   *	  4) Do arithmetic on temp(s).
   *	  5) Assign temporary to result. */


probe_operate_$prefix:
  entry (P_probe_info_ptr, P_opcode, P_first, P_result, P_code);

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

  if probe_info.language_type = PASCAL_lang_type
    then
         call probe_pascal_$real_type (P_first.type, P_first.type_ptr,
	    P_first.type, P_first.type_ptr);

  if P_first.type < lbound (data_type_info_$info, 1)
       | P_first.type > hbound (data_type_info_$info, 1) then do;
      call probe_error_$record (probe_info_ptr, probe_et_$bad_operand,
	 P_first.name);
      goto RECORDED_MESSAGE;
    end;

  if ^data_type_info_$info (P_first.type).computational then do;
      call probe_error_$record (probe_info_ptr, probe_et_$bad_operand,
	 P_first.name);
      goto RECORDED_MESSAGE;
    end;


  if data_type_info_$info (P_first.type).arithmetic
       & /* optimize - prefix + of number */
       P_opcode = "+" then do;	/* result is the reference itself */
      P_result.address_ptr = P_first.address_ptr;
      P_result.type = P_first.type;
      P_result.descriptor = P_first.descriptor;
      P_result.precision = P_first.precision;
    end;
    else do;

      /* Must convert operand to a standard arithmetic type before continuing */

      type_bits = compute_type_bits ((P_first.type));
      type_type = fixed (string (type_bits), 3, 0);

      /* gather source attributes */

      use_genfd_sw, use_genfd_complex_sw = "0"b;
      if data_type_info_$info (P_first.type).hex
	 & data_type_info_$info (P_first.type).arithmetic then do;
	use_genfd_sw = "1"b;
	if data_type_info_$info (P_first.type).complex then do;
	    use_genfd_complex_sw = "1"b;
	    genfd_type = cplx_flt_dec_generic_dtype;
	  end;
	  else genfd_type = real_flt_dec_generic_dtype;
        end;

      call setup_structure (P_first, source (1));

      if ^type_bits.binary & ^use_genfd_sw
        then
	   if ^valid_decimal_ ((P_first.type), P_first.address_ptr,
	        (source (1).prec_or_length))
	     then do;
	       call probe_error_$record (probe_info_ptr,
		  probe_et_$bad_decimal, P_first.name);
	       goto RECORDED_MESSAGE;
	     end;

      /* make temp for intermediate, and convert to it */

      unspec (intermediate (1)) = "0"b;
      if use_genfd_sw then do;
	intermediate (1).data_type = genfd_type;
	intermediate (1).prec_or_length =
	     data_type_info_$max_decimal_precision;
	alloc_size = MAX_GENFD_WORDS;
	if use_genfd_complex_sw
	  then alloc_size = alloc_size * 2;
        end;
        else do;
	intermediate (1).data_type = common_info (type_type).type_array;
	intermediate (1).prec_or_length =
	     common_info (type_type).prec_array;
	alloc_size = common_info (type_type).size_array;
        end;
      intermediate (1).scale = source (1).scale;
      intermediate (1).picture_image_ptr = null ();

      dp = allocate_temp (alloc_size);
      intermediate (1).address = dp;

      call assign_$computational_ (addr (intermediate (1)), addr (source (1)),
	 P_code);
      if P_code ^= 0
        then
	   return;

      /* Now do the arithmetic on the intermediate value */

      if P_opcode = "+"
        then ;			/* nothing need be done */

      else if P_opcode = "-" then do;
	if use_genfd_sw
	  then
	       if use_genfd_complex_sw
	         then call generic_math_$negate_decimal_complex
		         (dp -> cplx_gen_decimal_struc,
		         dp -> cplx_gen_decimal_struc);
	         else call generic_math_$negate_decimal
		         (dp -> gen_decimal_struc,
		         dp -> gen_decimal_struc);
	else if type_bits.binary
	  then if type_bits.float
	         then if type_bits.complex
		      then dp -> float_bin_complex =
			      -dp -> float_bin_complex;
		      else dp -> float_bin_real = -dp -> float_bin_real;
	       else if type_bits.complex
	         then dp -> fixed_bin_complex = -dp -> fixed_bin_complex;
	       else dp -> fixed_bin_real = -dp -> fixed_bin_real;
	else if type_bits.float
	  then if type_bits.complex
	         then dp -> float_dec_complex = -dp -> float_dec_complex;
	         else dp -> float_dec_real = -dp -> float_dec_real;
	else if type_bits.complex
	  then dp -> fixed_dec_complex = -dp -> fixed_dec_complex;
	else dp -> fixed_dec_real = -dp -> fixed_dec_real;
        end;			/* of minus */

      else call probe_error_$malfunction (probe_info_ptr, 0,
	      "Invalid prefix operator: ""^a"".", P_opcode);

      if use_genfd_sw then do;
	P_result.type = genfd_type;
	P_result.precision = data_type_info_$max_decimal_precision;
        end;
        else P_result.type = common_info (type_type).type_array;
      P_result.descriptor = P_result.type * 2;

      /* now create some storage in the work area for the result
   This storage must survive our invocation! */

      P_result.address_ptr = allocate_temp (alloc_size);

      call setup_structure (P_result, result);
      call assign_$computational_ (addr (result), addr (intermediate (1)),
	 P_code);
    end;

  P_result.symbol_ptr = null ();
  if P_result.source_info_ptr ^= null
    then
         P_result.source_info_ptr -> source_info.block_ptr,
	    P_result.source_info_ptr -> source_info.stack_ptr,
	    P_result.source_info_ptr -> source_info.entry_ptr = null ();
  P_result.name = "<<temporary>>";
  P_result.flags = "0"b;
  P_result.constant = "1"b;

  return;				/* end of code for probe_operate_$prefix */

%page;
/*****************************************************************************/

probe_operate_$infix:
  entry (P_probe_info_ptr, P_opcode, P_first, P_second, P_result, P_code);

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

c_pointer_arithmetic:
  proc ();

  dcl i			fixed bin;
  dcl tp			ptr;
  dcl total_bits		(2) fixed bin;
  dcl data_value		(2) fixed bin;
  dcl tp_type		fixed bin;
  dcl op_addr		ptr;
  dcl total_bits_to_add	fixed bin (24);
  dcl add_word_offset	fixed bin (17);
  dcl add_bit_offset	fixed bin (5);
  dcl temp_node_ptr		ptr;
  dcl fixed_bin_short	fixed bin (17) based (op_addr);
  dcl fixed_bin_long	fixed bin (71) based (op_addr);
  dcl dec_string		char (32) based (op_addr);
  dcl stored_addr		ptr;
  dcl based_ptr		ptr based;
  dcl based_int		fixed bin (35) based;

  dcl 1 its		based aligned,
       2 pad1		bit (3) unaligned,
       2 segno		bit (15) unaligned,
       2 ringno		bit (3) unaligned,
       2 pad2		bit (9) unaligned,
       2 its_mod		bit (6) unaligned,

       2 offset		fixed bin (17) unaligned,
       2 pad3		bit (3) unaligned,
       2 bit_offset		fixed bin (5) unaligned,
       2 pad4		bit (3) unaligned,
       2 future_mod		bit (6) unaligned;

  dcl pointer_encountered	bit (1);
  dcl code		fixed bin (35);
  dcl probe_create_reference_ entry (ptr, ptr);
  dcl 01 temp_ref		aligned like reference_node;
  dcl probe_builtins_$sizeof_builtin
			entry (ptr, ptr, fixed bin (35));
  dcl 01 sub_refs		aligned like subscript_reference_ptrs;


  /* Get the size of the data type pointed to.      */
  /* Get the number of units                        */
  /* Convert the units to words and bits            */
  /* Add the appropriate fileds of the ITS pointer  */

  if (P_opcode ^= "+" & P_opcode ^= "-") then do;
      call probe_error_$record (probe_info_ptr, 0,
	 "Only addition and subtraction may be done in C pointer arithmetic."
	 );
      goto RECORDED_MESSAGE;
    end;
  total_bits (*) = 0;
  data_value (*) = 0;
  pointer_encountered = "0"b;
  P_result.symbol_ptr = null ();
  do i = 1 to 2;
    if operand (i).type = pointer_dtype then do;
        if (pointer_encountered) then do;
	  call probe_error_$record (probe_info_ptr, 0,
	       "Only one operand in a pointer arithmetic expression may be a pointer."
	       );
	  goto RECORDED_MESSAGE;
	end;
	else pointer_encountered = "1"b;
        P_result.symbol_ptr = operand (i).symbol_ptr;
        if (operand (i).symbol_ptr = null ()
	   & operand (i).c_symbol_ptr = null ()) then do;
	  call probe_error_$record (probe_info_ptr, 0,
	       "Cannot locate the data type of the data pointed to by a pointer"
	       );
	  goto RECORDED_MESSAGE;
	end;
	else do;
	  if (operand (i).symbol_ptr ^= null ())
	    then
	         tp = operand (i).symbol_ptr;
	    else
	         tp = operand (i).c_symbol_ptr;

	  stored_addr = operand (i).address_ptr -> based_ptr;

	  tp = addrel (tp, fixed (tp -> runtime_symbol.son));

	  do while (fixed (tp -> runtime_symbol.type) = c_typeref_dtype);
	    tp = addrel (tp, fixed (tp -> runtime_symbol.son));
	  end;

	  temp_ref = operand (i);
	  temp_ref.symbol_ptr = tp;

	  sub_refs.ptr (1, 1) = addr (temp_ref);
	  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 =
	       temp_ref.source_info_ptr;
	  temp_node_ptr -> reference_node.optional_info.n_subscripts = 1;
	  temp_node_ptr -> reference_node.subscript_refs_ptr =
	       addr (sub_refs);
	  call probe_builtins_$sizeof_builtin (probe_info_ptr,
	       temp_node_ptr, code);
	  temp_node_ptr -> reference_node.optional_info.n_subscripts = 0;

	  total_bits (i) =
	       temp_node_ptr -> reference_node.address_ptr -> based_int * 9;
	end;
      end;
      else do;
        op_addr = operand (i).address_ptr;
        tp_type = operand (i).type;
        if (tp_type = real_fix_bin_1_dtype)
	then
	     data_value (i) = fixed (fixed_bin_short, 17, 0);
        else if (tp_type = real_fix_bin_2_dtype)
	then
	     data_value (i) = fixed (fixed_bin_long, 17, 0);
        else if (tp_type = real_fix_dec_9bit_ls_dtype)
	then
	     data_value (i) =
		fixed (substr (dec_string, 1, operand (i).precision + 1),
		17, 0);
      end;
  end;				/* end do loop */

  P_result.type = pointer_dtype;

  if (total_bits (1) = 0)
    then
         total_bits_to_add = multiply (total_bits (2), data_value (1), 24, 0);
    else
         total_bits_to_add = multiply (total_bits (1), data_value (2), 24, 0);

  add_word_offset = divide (total_bits_to_add, 36, 17, 0);
  add_bit_offset = fixed (mod (total_bits_to_add, 36), 5, 0);

  P_result.descriptor = P_result.type * 2;

  if P_result.source_info_ptr ^= null
    then
         P_result.source_info_ptr -> source_info.block_ptr,
	    P_result.source_info_ptr -> source_info.stack_ptr,
	    P_result.source_info_ptr -> source_info.entry_ptr = null ();
  P_result.name = "<<temporary>>";
  P_result.flags = "0"b;
  P_result.constant = "1"b;

  P_result.address_ptr = allocate_temp (2);
  P_result.address_ptr -> based_ptr = stored_addr;

  if (P_opcode = "+") then do;
      add_word_offset = P_result.address_ptr -> its.offset + add_word_offset;
      add_bit_offset =
	 P_result.address_ptr -> its.bit_offset + add_bit_offset;
      if (add_bit_offset >= 36) then do;
	add_word_offset =
	     add_word_offset + divide (add_bit_offset, 36, 17, 0);
	add_bit_offset = fixed (mod (add_bit_offset, 36), 5, 0);
        end;
    end;
  else if (P_opcode = "-") then do;
      add_word_offset = P_result.address_ptr -> its.offset - add_word_offset;
      add_bit_offset =
	 P_result.address_ptr -> its.bit_offset - add_bit_offset;
      if (add_bit_offset < 0) then do;
	add_word_offset = add_word_offset - 1;
	add_bit_offset = 36 + add_bit_offset;
        end;
    end;
  P_result.address_ptr -> its.offset = add_word_offset;
  P_result.address_ptr -> its.bit_offset = add_bit_offset;

  end c_pointer_arithmetic;

%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

c_shift_arithmetic:
  proc ();

  dcl (tp_type, data_value)	fixed bin;
  dcl op_addr		ptr;
  dcl fixed_bin_short	fixed bin (17) based (op_addr);
  dcl fixed_bin_long	fixed bin (71) based (op_addr);
  dcl dec_string		char (32) based (op_addr);
  dcl bit_9		(4) unaligned bit (9) based;
  dcl bit_18		(2) unaligned bit (18) based;
  dcl bit_36		bit (36) based;
  dcl bit_72		bit (72) based;
  dcl zeros		bit (72) int static options (constant)
			init ("0"b);
  dcl mod_bits		fixed bin;

  if (probe_info.language_type ^= C_lang_type) then do;
      call probe_error_$record (probe_info_ptr, 0,
	 "The >> and << operators may not be used by the current language");
      goto RECORDED_MESSAGE;
    end;

  tp_type = operand (1).type;

  /* char */
  if (tp_type = char_dtype) then do;
      mod_bits = 9;
      P_result.address_ptr = allocate_temp (1);
      P_result.address_ptr -> bit_9 (1) =
	 operand (1).address_ptr -> bit_9 (1);
    end;

  /* int & short & long */
  else if (tp_type <= real_flt_bin_2_dtype) then do;
      if (tp_type = real_fix_bin_1_dtype | tp_type = real_flt_bin_1_dtype)
        then do;
	P_result.address_ptr = allocate_temp (1);
	if (operand (1).precision <= 18) then do;
	    mod_bits = 18;
	    P_result.address_ptr -> bit_18 (1) =
	         operand (1).address_ptr -> bit_18 (1);
	  end;
	  else do;
	    mod_bits = 36;
	    P_result.address_ptr -> bit_36 =
	         operand (1).address_ptr -> bit_36;
	  end;
        end;
        else do;
	P_result.address_ptr = allocate_temp (2);
	P_result.address_ptr -> bit_72 = operand (1).address_ptr -> bit_72;
	mod_bits = 72;
        end;
    end;

  /* Invalid data type for a shift */
  else
       call probe_error_$record (probe_info_ptr, 0,
	  "Invalid data type for the shift operator.");


  op_addr = operand (2).address_ptr;
  tp_type = operand (2).type;

  if (tp_type = real_fix_bin_1_dtype)
    then
         data_value = fixed (fixed_bin_short, 17, 0);
  else if (tp_type = real_fix_bin_2_dtype)
    then
         data_value = fixed (fixed_bin_long, 17, 0);
  else if (tp_type = real_fix_dec_9bit_ls_dtype)
    then
         data_value =
	    fixed (substr (dec_string, 1, operand (2).precision + 1), 17, 0)
	    ;

  P_result.type = operand (1).type;

  P_result.descriptor = P_result.type * 2;

  P_result.symbol_ptr = null ();
  if P_result.source_info_ptr ^= null
    then
         P_result.source_info_ptr -> source_info.block_ptr,
	    P_result.source_info_ptr -> source_info.stack_ptr,
	    P_result.source_info_ptr -> source_info.entry_ptr = null ();
  P_result.name = "<<temporary>>";
  P_result.flags = "0"b;
  P_result.constant = "1"b;

  if (data_value >= mod_bits) then do;
      substr (P_result.address_ptr -> bit_72, 1, mod_bits) =
	 substr (zeros, 1, mod_bits);
      return;
    end;
  else if (P_opcode = "<")
    then
         substr (P_result.address_ptr -> bit_72, 1, mod_bits) =
	    substr (P_result.address_ptr -> bit_72, data_value + 1,
	    mod_bits - data_value) || substr (zeros, 1, data_value);
  else if (P_opcode = ">")
    then
         substr (P_result.address_ptr -> bit_72, 1, mod_bits) =
	    substr (zeros, 1, data_value)
	    ||
	    substr (P_result.address_ptr -> bit_72, 1,
	    mod_bits - data_value);

  end c_shift_arithmetic;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

c_mod_arithmetic:
  proc ();

  dcl tp_type		fixed bin;
  dcl op_addr		ptr;
  dcl fixed_bin_short	fixed bin (35) based (op_addr);
  dcl fixed_bin_long	fixed bin (71) based (op_addr);
  dcl dec_string		char (32) based (op_addr);
  dcl (op1, op2)		fixed bin (35);
  dcl mod			builtin;

  if (probe_info.language_type ^= C_lang_type) then do;
      call probe_error_$record (probe_info_ptr, 0,
	 "The % operator may not be used by the current language.");
      goto RECORDED_MESSAGE;
    end;

  op_addr = operand (1).address_ptr;
  tp_type = operand (1).type;

  P_result.type = real_fix_bin_1_dtype;
  P_result.address_ptr = allocate_temp (1);

  if (tp_type = real_fix_bin_1_dtype)
    then
         op1 = operand (1).address_ptr -> fixed_bin_short;
  else if (tp_type = real_fix_bin_2_dtype)
    then
         op1 = fixed (operand (1).address_ptr -> fixed_bin_long, 35, 0);
  else if (tp_type = real_fix_dec_9bit_ls_dtype)
    then
         op1 = fixed (substr (dec_string, 1, operand (1).precision + 1), 35,
	    0);
				/* Invalid data type for modulous */
  else
       call probe_error_$record (probe_info_ptr, 0,
	  "Invalid data type for the modulous operator.");

  op_addr = operand (2).address_ptr;
  tp_type = operand (2).type;

  if (tp_type = real_fix_bin_1_dtype)
    then
         op2 = operand (2).address_ptr -> fixed_bin_short;
  else if (tp_type = real_fix_bin_2_dtype)
    then
         op2 = fixed (operand (2).address_ptr -> fixed_bin_long, 35, 0);
  else if (tp_type = real_fix_dec_9bit_ls_dtype)
    then
         op2 = fixed (substr (dec_string, 1, operand (2).precision + 1), 35,
	    0);
				/* Invalid data type for modulous */
  else
       call probe_error_$record (probe_info_ptr, 0,
	  "Invalid data type for the modulous operator.");

  P_result.descriptor = P_result.type * 2;

  P_result.symbol_ptr = null ();
  if P_result.source_info_ptr ^= null
    then
         P_result.source_info_ptr -> source_info.block_ptr,
	    P_result.source_info_ptr -> source_info.stack_ptr,
	    P_result.source_info_ptr -> source_info.entry_ptr = null ();
  P_result.name = "<<temporary>>";
  P_result.flags = "0"b;
  P_result.constant = "1"b;

  if (op2 = 0) then do;
      call probe_error_$record (probe_info_ptr, 0,
	 "The second argument of the modulous operator is zero.");
      goto RECORDED_MESSAGE;
    end;

  P_result.address_ptr -> fixed_bin_short = mod (op1, op2);

  end c_mod_arithmetic;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

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

  operand (1) = P_first;
  operand (2) = P_second;		/* for easier processing */

  /* check ops for validity ******************** */

  use_genfd_sw, use_genfd_complex_sw = "0"b;

  do i = 1 to 2;			/* check ops for validity */
    if probe_info.language_type = PASCAL_lang_type
      then
	 call probe_pascal_$real_type (operand (i).type,
	      operand (i).type_ptr,
	      operand (i).type, operand (i).type_ptr);

    if operand (i).type < lbound (data_type_info_$info, 1) |
         operand (i).type > hbound (data_type_info_$info, 1) then do;
        call probe_error_$record (probe_info_ptr, probe_et_$bad_operand,
	   operand (i).name);
        goto RECORDED_MESSAGE;
      end;

    /* C pointers may be incremented or decremented */

    if ^data_type_info_$info (operand (i).type).computational &
         probe_info.language_type ^= C_lang_type then do;
        call probe_error_$record (probe_info_ptr, probe_et_$bad_operand,
	   operand (i).name);
        goto RECORDED_MESSAGE;
      end;

    if data_type_info_$info (operand (i).type).hex &
         data_type_info_$info (operand (i).type).arithmetic then do;
        use_genfd_sw = "1"b;
        if data_type_info_$info (operand (i).type).complex then do;
	  use_genfd_complex_sw = "1"b;
	  genfd_type = cplx_flt_dec_generic_dtype;
	end;
        else if ^use_genfd_complex_sw
	then genfd_type = real_flt_dec_generic_dtype;
      end;
  end;

  /* Do C pointer arithmetic */

  if (operand (1).type = pointer_dtype | operand (2).type = pointer_dtype)
    then do;
      call c_pointer_arithmetic ();
      return;
    end;

  /* Do C left and right shift arithmetic */

  if (P_opcode = "<" | P_opcode = ">") then do;
      call c_shift_arithmetic ();
      return;
    end;

  /* Do C % operator */

  if (P_opcode = "%") then do;
      call c_mod_arithmetic ();
      return;
    end;

  /* to compute the attributes of the result - type_bits is cleverly set up so
   that the common attribute may be found by or'ing the separate attributes */

  type_bits = compute_type_bits ((P_first.type));
  type_bits_copy = compute_type_bits ((P_second.type));

  string (type_bits) = string (type_bits) | string (type_bits_copy);

  type_type = fixed (string (type_bits), 3, 0);
  if use_genfd_sw then do;
      P_result.type = genfd_type;
      P_result.precision = data_type_info_$max_decimal_precision;
    end;
    else P_result.type = common_info (type_type).type_array;
  P_result.descriptor = P_result.type * 2;

  P_result.symbol_ptr = null ();
  if P_result.source_info_ptr ^= null
    then
         P_result.source_info_ptr -> source_info.block_ptr,
	    P_result.source_info_ptr -> source_info.stack_ptr,
	    P_result.source_info_ptr -> source_info.entry_ptr = null ();
  P_result.name = "<<temporary>>";
  P_result.flags = "0"b;
  P_result.constant = "1"b;

  if use_genfd_sw then do;
      alloc_size = MAX_GENFD_WORDS;
      if use_genfd_complex_sw
        then alloc_size = alloc_size * 2;
    end;
    else alloc_size = common_info (type_type).size_array;
  P_result.address_ptr = allocate_temp (alloc_size);
  do i = 1 to 2;

    call setup_structure (operand (i), source (i));
    if data_type_info_$info (operand (i).type).decimal
      then if ^valid_decimal_ ((operand (i).type), operand (i).address_ptr,
	      (source (i).prec_or_length)) then do;
	     call probe_error_$record (probe_info_ptr,
		probe_et_$bad_decimal, operand (i).name);
	     goto RECORDED_MESSAGE;
	   end;

    if use_genfd_sw then do;
        intermediate (i).data_type = genfd_type;
        intermediate (i).prec_or_length =
	   data_type_info_$max_decimal_precision;
      end;
      else intermediate (i).data_type = common_info (type_type).type_array;

    if ^data_type_info_$info (source (i).data_type).arithmetic
      then if data_type_info_$info (source (i).data_type).char_string
	   then intermediate (i).prec_or_length =
		   data_type_info_$max_decimal_precision;
	   else intermediate (i).prec_or_length =
		   data_type_info_$max_fixed_binary_precision;

    if (data_type_info_$info (source (i).data_type).decimal |
         data_type_info_$info (source (i).data_type).char_string) &
         type_bits.binary & ^use_genfd_sw then do;
        intermediate (i).prec_or_length =
	   min (ceil (intermediate (i).prec_or_length * 3.332),
	   common_info (type_type).prec_array);
        intermediate (i).scale =
	   ceil (abs (intermediate (i).scale) * 3.332)
	   * sign (intermediate (i).scale);
      end;			/* decimal to bin precision hack */

    op (i), intermediate (i).address = allocate_temp (alloc_size);
  end;

  result.address = P_result.address_ptr;
  result.data_type = P_result.type;
  result.flags = "0"b;


  /* We now branch depending on the opcode. Each opcode computes the precision that the
   operands are to be converted to, does the conversion, does the operation, computes
   the precision of the result, converts the result to proper precision, and returns.
*/

  if P_opcode = "+" | P_opcode = "-" then do;

      /* Compute temporary and result precisions - both temps must have the same scale,
   because the addition is done with two dummies. the decimal points must be in
   the same column, in order to get meaningful results.   */

      /* Rules of PL/I tell what attributes of plus result are */

      if use_genfd_sw
        then result.prec_or_length = data_type_info_$max_decimal_precision;
        else result.prec_or_length = min (common_info (type_type).prec_array,
	        max (source (1).prec_or_length - source (1).scale,
	        source (2).prec_or_length - source (2).scale) +
	        max (source (1).scale, source (2).scale) + 1);
      result.scale = max (source (1).scale, source (2).scale);

      /* for intermediates use max  possible */
      if ^use_genfd_sw
        then intermediate (*).prec_or_length =
	        common_info (type_type).prec_array;
      intermediate (*).scale = max (source (1).scale, source (2).scale);

      do i = 1 to 2;
        call assign_$computational_ (addr (intermediate (i)),
	   addr (source (i)), P_code);
        if P_code ^= 0
	then
	     return;
      end;

      if P_opcode = "+" then do;
	if use_genfd_sw
	  then
	       if use_genfd_complex_sw
	         then call generic_math_$add_decimal_complex
		         (op (1) -> cplx_gen_decimal_struc,
		         op (2) -> cplx_gen_decimal_struc,
		         op (1) -> cplx_gen_decimal_struc);
	         else call generic_math_$add_decimal
		         (op (1) -> gen_decimal_struc,
		         op (2) -> gen_decimal_struc,
		         op (1) -> gen_decimal_struc);
	else if type_bits.binary
	  then if type_bits.float
	         then if type_bits.complex
		      then op (1) -> float_bin_complex =
			      op (1) -> float_bin_complex
			      + op (2) -> float_bin_complex;
		      else op (1) -> float_bin_real =
			      op (1) -> float_bin_real
			      + op (2) -> float_bin_real;
	       else if type_bits.complex
	         then op (1) -> fixed_bin_complex =
		         op (1) -> fixed_bin_complex
		         + op (2) -> fixed_bin_complex;
	       else op (1) -> fixed_bin_real =
		       op (1) -> fixed_bin_real
		       + op (2) -> fixed_bin_real;
	else if type_bits.float
	  then if type_bits.complex
	         then op (1) -> float_dec_complex =
		         op (1) -> float_dec_complex
		         + op (2) -> float_dec_complex;
	         else op (1) -> float_dec_real =
		         op (1) -> float_dec_real
		         + op (2) -> float_dec_real;
	else if type_bits.complex
	  then op (1) -> fixed_dec_complex =
		  op (1) -> fixed_dec_complex
		  + op (2) -> fixed_dec_complex;
	else op (1) -> fixed_dec_real =
		op (1) -> fixed_dec_real + op (2) -> fixed_dec_real;
        end;			/* plus */

      else if P_opcode = "-" then do;
	if use_genfd_sw
	  then
	       if use_genfd_complex_sw
	         then call generic_math_$subtract_decimal_complex
		         (op (1) -> cplx_gen_decimal_struc,
		         op (2) -> cplx_gen_decimal_struc,
		         op (1) -> cplx_gen_decimal_struc);
	         else call generic_math_$subtract_decimal
		         (op (1) -> gen_decimal_struc,
		         op (2) -> gen_decimal_struc,
		         op (1) -> gen_decimal_struc);
	else if type_bits.binary
	  then if type_bits.float
	         then if type_bits.complex
		      then op (1) -> float_bin_complex =
			      op (1) -> float_bin_complex
			      - op (2) -> float_bin_complex;
		      else op (1) -> float_bin_real =
			      op (1) -> float_bin_real
			      - op (2) -> float_bin_real;
	       else if type_bits.complex
	         then op (1) -> fixed_bin_complex =
		         op (1) -> fixed_bin_complex
		         - op (2) -> fixed_bin_complex;
	       else op (1) -> fixed_bin_real =
		       op (1) -> fixed_bin_real
		       - op (2) -> fixed_bin_real;
	else if type_bits.float
	  then if type_bits.complex
	         then op (1) -> float_dec_complex =
		         op (1) -> float_dec_complex
		         - op (2) -> float_dec_complex;
	         else op (1) -> float_dec_real =
		         op (1) -> float_dec_real
		         - op (2) -> float_dec_real;
	else if type_bits.complex
	  then op (1) -> fixed_dec_complex =
		  op (1) -> fixed_dec_complex
		  - op (2) -> fixed_dec_complex;
	else op (1) -> fixed_dec_real =
		op (1) -> fixed_dec_real - op (2) -> fixed_dec_real;
        end;			/* minus */
    end;				/* plus and minus */

  else if P_opcode = "*" then do;

      if use_genfd_sw
        then temp_precision = data_type_info_$max_decimal_precision;
        else temp_precision = common_info (type_type).prec_array;

      if type_bits.float then do;
	P_result.precision, result.prec_or_length,
	     intermediate (*).prec_or_length = temp_precision;
	result.scale, intermediate (*).scale = 0;
	do i = 1 to 2;
	  call assign_$computational_ (addr (intermediate (i)),
	       addr (source (i)), P_code);
	  if P_code ^= 0
	    then
	         return;
	end;
	if use_genfd_sw
	  then
	       if use_genfd_complex_sw
	         then call generic_math_$multiply_decimal_complex
		         (op (1) -> cplx_gen_decimal_struc,
		         op (2) -> cplx_gen_decimal_struc,
		         op (1) -> cplx_gen_decimal_struc);
	         else call generic_math_$multiply_decimal
		         (op (1) -> gen_decimal_struc,
		         op (2) -> gen_decimal_struc,
		         op (1) -> gen_decimal_struc);
	else if type_bits.binary
	  then if type_bits.complex
	         then op (1) -> float_bin_complex =
		         op (1) -> float_bin_complex
		         * op (2) -> float_bin_complex;
	         else op (1) -> float_bin_real =
		         op (1) -> float_bin_real
		         * op (2) -> float_bin_real;
	else if type_bits.complex
	  then op (1) -> float_dec_complex =
		  op (1) -> float_dec_complex
		  * op (2) -> float_dec_complex;
	else op (1) -> float_dec_real =
		op (1) -> float_dec_real * op (2) -> float_dec_real;
        end;			/* float work */

        else do;
	intermediate (*).prec_or_length = temp_precision;
	do i = 1 to 2;
	  intermediate (i).scale = source (i).scale;
	  call assign_$computational_ (addr (intermediate (i)),
	       addr (source (i)), P_code);
	  if P_code ^= 0
	    then
	         return;
	end;


	if type_bits.binary
	  then if type_bits.complex
	         then op (1) -> fixed_bin_complex =
		         op (1) -> fixed_bin_complex
		         * op (2) -> fixed_bin_complex;
	         else op (1) -> fixed_bin_real =
		         op (1) -> fixed_bin_real
		         * op (2) -> fixed_bin_real;
	else if type_bits.complex
	  then op (1) -> fixed_dec_complex =
		  op (1) -> fixed_dec_complex
		  * op (2) -> fixed_dec_complex;
	else op (1) -> fixed_dec_real =
		op (1) -> fixed_dec_real * op (2) -> fixed_dec_real;

	result.prec_or_length = min (common_info (type_type).prec_array,
	     source (1).prec_or_length + source (2).prec_or_length + 1);
	result.scale = source (1).scale + source (2).scale;
        end;			/* fixed point multiplication */

    end;				/* multiply */

  else if P_opcode = "/" then do;
      if use_genfd_sw
        then temp_precision = data_type_info_$max_decimal_precision;
        else temp_precision = common_info (type_type).prec_array;
      result.prec_or_length, intermediate (*).prec_or_length,
	 P_result.precision = temp_precision;
      intermediate (*).scale, result.scale = 0;

      do i = 1 to 2;
        call assign_$computational_ (addr (intermediate (i)),
	   addr (source (i)), P_code);
        if P_code ^= 0
	then
	     return;
      end;

      if use_genfd_sw
        then
	   if use_genfd_complex_sw
	     then call generic_math_$divide_decimal_complex
		     (op (1) -> cplx_gen_decimal_struc,
		     op (2) -> cplx_gen_decimal_struc,
		     op (1) -> cplx_gen_decimal_struc);
	     else call generic_math_$divide_decimal
		     (op (1) -> gen_decimal_struc,
		     op (2) -> gen_decimal_struc,
		     op (1) -> gen_decimal_struc);
      else if type_bits.binary
        then if type_bits.float
	     then if type_bits.complex
		  then op (1) -> float_bin_complex =
			  divide (op (1) -> float_bin_complex,
			  op (2) -> float_bin_complex, 63);
		  else op (1) -> float_bin_real =
			  divide (op (1) -> float_bin_real,
			  op (2) -> float_bin_real, 63);
	   else if type_bits.complex
	     then op (1) -> fixed_bin_complex =
		     divide (op (1) -> fixed_bin_complex,
		     op (2) -> fixed_bin_complex, 71);
	   else op (1) -> fixed_bin_real =
		   divide (op (1) -> fixed_bin_real,
		   op (2) -> fixed_bin_real, 71, 0);
      else if type_bits.float
        then if type_bits.complex
	     then op (1) -> float_dec_complex =
		     divide (op (1) -> float_dec_complex,
		     op (2) -> float_dec_complex, 59);
	     else op (1) -> float_dec_real =
		     divide (op (1) -> float_dec_real,
		     op (2) -> float_dec_real, 59);
      else if type_bits.complex
        then op (1) -> fixed_dec_complex =
	        divide (op (1) -> fixed_dec_complex,
	        op (2) -> fixed_dec_complex, 59, 0);
      else op (1) -> fixed_dec_real =
	      divide (op (1) -> fixed_dec_real, op (2) -> fixed_dec_real,
	      59, 0);

    end;				/* divide */


  call assign_$computational_ (addr (result), addr (intermediate (1)), P_code)
       ;
  an_encoded_precision.prec = result.prec_or_length;
  an_encoded_precision.scale = result.scale;
  unspec (P_result.precision) = unspec (an_encoded_precision);

  return;


RECORDED_MESSAGE:			/* error exit */
  P_code = probe_et_$recorded_message;

  return;

%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

allocate_temp:
  proc (P_size_in_words) returns (ptr);

  dcl P_size_in_words	fixed bin parameter;
  dcl based_bit		bit (P_size_in_words * 36) based;
  dcl result_ptr		ptr;

  allocate based_bit in (expression_area) set (result_ptr);
  return (result_ptr);

  end allocate_temp;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

setup_structure:
  proc (ref, comp);

  dcl 1 ref		parameter aligned like reference_node;
  dcl 1 comp		parameter aligned like computational_data;
  dcl 1 an_encoded_value	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_structure;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

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

%include probe_info;
%page;
%include probe_tokens;
%page;
%include probe_references;
%page;
%include probe_source_info;
%page;
%include std_descriptor_types;
%page;
%include data_type_info_;
%page;
%include probe_lang_types;
%page;
%include encoded_precision;
%page;
%include computational_data;
%page;
%include runtime_symbol;

  end probe_operate_;




		    probe_pascal_.pl1               11/11/88  1555.4r w 11/11/88  1545.0       79569



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

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



/****^  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_pascal_:
  proc;

  /* PROBE <-> PASCAL utilities */
  /* Written: 1983 JMAthane Grenoble University. */
  /* Fixed $indice_value to copy probe_info_ptr arg 08/01/83 S. Herbst */
  /* Added version string to runtime_type_info structure 10/06/83 S. Herbst */

  /* entries are :

   probe_pascal_$real_type entry (fixed bin (35), ptr, fied bin (35), ptr)
   probe_pascal_$indice_id entry (fixed bin (35), ptr, fixed bin(35))
   probe_pascal_$indice_value entry (ptr, ptr, fixed bin (35), fixed bin (35), ptr, fixed bin (35))
   probe_pascal_$get_external_proc_name entry (ptr, fixed bin (35), char (256)) ;
*/


  dcl (addr, addrel, rtrim, substr, unspec)
			builtin;

  dcl probe_error_$malfunction
			entry options (variable);

  call probe_error_$malfunction ();


  /* Different parameters used */


  dcl P_type		fixed bin (35);
  dcl P_type_ptr		ptr;
  dcl P_real_type		fixed bin (35);
  dcl P_real_type_ptr	ptr;
  dcl P_value		fixed bin (35);
  dcl P_probe_info_ptr	ptr;
  dcl P_seg_info_ptr	ptr;
  dcl P_reference_ptr	ptr;
  dcl P_name		char (256) varying;
  dcl P_code		fixed bin (35);



  /**/
real_type:
  entry (P_type, P_type_ptr, P_real_type, P_real_type_ptr);


  dcl 1 type_info		like runtime_type_info;

  if P_type = pascal_user_defined_type_instance_dtype then do;
      if P_type_ptr -> pascal_symbol_node_header.subrange_limits then do;

	type_info.version = RUNTIME_TYPE_INFO_VERSION_1;

	call runtime_symbol_info_$type (P_type_ptr, addr (type_info),
	     P_code);
	if P_code ^= 0
	  then go to SOME_ERROR;

	P_real_type = type_info.base_type;
	P_real_type_ptr = type_info.base_type_addr;
	return;
        end;
    end;
  P_real_type = P_type;
  P_real_type_ptr = P_type_ptr;
  return;

indice_id:
  entry (P_type, P_type_ptr, P_value) returns (char (32) varying);


  dcl (null, maxlength)	builtin;
  dcl pascal_char		char (1);
  dcl arithmetic_to_ascii_	entry (ptr, fixed bin, bit (1), fixed bin,
			fixed bin, char (132) var);
  dcl result_string		char (132) varying;
  dcl real_type		fixed bin (35);
  dcl type_ptr		ptr;
  dcl i			fixed bin (35);
  dcl p1			ptr;

  dcl probe_pascal_$real_type entry (fixed bin (35), ptr, fixed bin (35), ptr)
			;

  call probe_pascal_$real_type (P_type, P_type_ptr, real_type, type_ptr);

  if real_type = pascal_integer_dtype then do;
      call arithmetic_to_ascii_ (addr (P_value), (real_type), "0"b, 35, 0,
	 result_string);
      return (rtrim (result_string));
    end;
  else if real_type = pascal_char_dtype then do;
      unspec (pascal_char) = substr (unspec (P_value), 28, 9);
      return ("'" || pascal_char || "'");
    end;
  else if real_type = pascal_boolean_dtype then do;
      if P_value = 0
        then
	   return ("false");
        else return ("true");
    end;
  else if real_type = pascal_enumerated_type_instance_dtype then do;
      p1 = runtime_symbol_info_$son (type_ptr);
      i = 0;
      do while (p1 ^= null);
        if i = P_value
	then
	     return (runtime_symbol_info_$name (p1) -> acc.string);
        i = i + 1;
        p1 = runtime_symbol_info_$successor (p1);
      end;
    end;

  return ("???");			/* never if valid symbol table */

indice_value:
  entry (P_probe_info_ptr, P_reference_ptr, P_value, P_type, P_type_ptr,
       P_code);


  dcl assign_$computational_	entry (ptr, ptr, fixed bin (35));
  dcl probe_create_reference_ entry (ptr, ptr);
  dcl probe_error_$record	entry options (variable);
  dcl probe_et_$size	fixed bin (35) ext;
  dcl probe_get_$expression	entry (ptr, 1 aligned like reference_node,
			fixed bin (35));
  dcl probe_et_$recorded_message
			fixed bin (35) ext;
  dcl size		condition;
  dcl (
      1 tar_str,
      1 src_str
      )			aligned like computational_data;
  dcl 1 eprec		like encoded_precision;
  dcl 1 ref		like reference_node based (P_reference_ptr);

  P_code = 0;

  probe_info_ptr = P_probe_info_ptr;

  call probe_create_reference_ (probe_info_ptr, P_reference_ptr);

  call probe_get_$expression (probe_info_ptr,
       P_reference_ptr -> reference_node, P_code);
  if P_code ^= 0
    then return;

  if ^probe_info.execute
    then return;

  if ref.type = char_dtype then do;
      if ref.precision ^= 1 then do;
	call probe_error_$record (P_probe_info_ptr, 0,
	     "A character string cannot be used here.");
	P_code = probe_et_$recorded_message;
	return;
        end;
      ref.type = pascal_char_dtype;
      ref.precision = 9;
    end;

  tar_str.address = addr (P_value);
  tar_str.data_type = real_fix_bin_1_dtype;
  tar_str.flags = "0"b;
  tar_str.prec_or_length = 35;
  tar_str.scale = 0;

  unspec (eprec) = unspec (ref.precision);

  src_str.address = ref.address_ptr;
  src_str.flags = "0"b;
  src_str.prec_or_length = eprec.prec;
  src_str.scale = eprec.scale;
  src_str.packed = ref.packed;

  if ref.type < pascal_typed_pointer_type_dtype then do;
      src_str.data_type = ref.type;
      P_type = pascal_integer_dtype;
      P_type_ptr = null;
    end;
    else do;
      call probe_pascal_$real_type (ref.type, ref.type_ptr, P_type,
	 P_type_ptr);
      if P_type = pascal_boolean_dtype
	 | P_type = pascal_char_dtype
	 | P_type = pascal_enumerated_type_element_dtype
	 | P_type = pascal_enumerated_type_dtype then do;
	if src_str.prec_or_length >= 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.packed = "1"b;
        end;
      else if P_type = pascal_integer_dtype then do;
	src_str.data_type = pascal_integer_dtype;
        end;
      else do;
        call probe_error_$record (probe_info_ptr, 0,
	   "A value of type of ^a cannot be used here.", ref.name);
        P_code = probe_et_$recorded_message;
        return;
      end;
    end;

  if P_type = pascal_enumerated_type_element_dtype then do;
      P_type = pascal_enumerated_type_instance_dtype;
      P_type_ptr = runtime_symbol_info_$father_type (ref.symbol_ptr);
    end;

  on size
    begin;
    P_code = probe_et_$size;
    go to SOME_ERROR;
  end;

  call assign_$computational_ (addr (tar_str), addr (src_str), P_code);

SOME_ERROR:
  return;

get_external_proc_name:
  entry (P_seg_info_ptr, P_value, P_name);

  /* Returns in P_name the real name of the external procedure
   referenced by the link at P_value in the linkage section */

  dcl (work, def_p, seg_n_p, ent_n_p)
			ptr;

  work = P_seg_info_ptr -> linkage_ptr; /* to linkage section */
  def_p = work -> def_ptr;
  work =
       addrel (def_p,
       addrel (work -> original_linkage_ptr, P_value) -> exp_ptr);
				/* to expr word */
  work = addrel (def_p, work -> exp_word.type_ptr);
				/* to type pair */
  seg_n_p = addrel (def_p, work -> seg_ptr);
  ent_n_p = addrel (def_p, work -> ext_ptr);

  if seg_n_p = ent_n_p
    then
         if seg_n_p -> acc.num_chars > maxlength (P_name)
	 then P_name = "";
	 else P_name = seg_n_p -> acc.string;
  else if (seg_n_p -> acc.num_chars + ent_n_p -> acc.num_chars + 1)
       > maxlength (P_name)
    then P_name = "";
  else
       P_name = seg_n_p -> acc.string || "$" || ent_n_p -> acc.string;

  return;

%include probe_info;
%include probe_references;
%include linkdcl;
%include computational_data;
%include probe_tokens;
%include runtime_symbol_info_;
%include encoded_precision;
%include pascal_symbol_node;
%include std_descriptor_types;
%include acc;
%include probe_seg_info;
%include probe_source_info;

  end probe_pascal_;




		    probe_pretty_source_info_.pl1   10/27/88  1250.2r w 10/27/88  1224.5       34407



/****^  ***********************************************************
        *                                                         *
        * 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_pretty_source_info_:
  proc (P_probe_info_ptr, P_sourcep, P_return_string);

  dcl P_probe_info_ptr	ptr parameter;
  dcl P_sourcep		ptr parameter;
				/* to callers source_info */
  dcl P_return_string	char (*);

  /* given a source info, format and return a string describing it
   if map_entry_index is valid and there is a statement map for the seg, give line number
   otherwise give offset (use instruction_ptr) and warn user
   show level number if there is one

   James R. Davis 2 July 79
*/

  dcl sourcep		ptr;	/* copy of P_sourcep */
  dcl 1 caller_source	aligned like source_info based (sourcep);

  dcl level		fixed bin;/* what level we are at */
  dcl blockname		char (64);/* name of current block */
  dcl map_index		fixed bin;/* index into statement map for source_info */
  dcl no_stmnts		fixed bin;/* how many statements does proc have */
  dcl file		fixed bin;/* file number of line */
  dcl line		fixed bin;/* line number */
  dcl stmt		fixed bin;/* statement number */
  dcl map_ptr		ptr;	/* to the statement map for proc */

  dcl 1 map_entry_array	(no_stmnts) based (map_ptr) like statement_map;

  dcl probe_stack_trace_$where_source_info
			entry (ptr, ptr, fixed bin, char (*));

  dcl ioa_$rsnnl		entry options (variable);
  dcl (binary, fixed, null, rel)
			builtin;
				/*  */

  probe_info_ptr = P_probe_info_ptr;
  sourcep = P_sourcep;

  call probe_stack_trace_$where_source_info (probe_info_ptr, sourcep, level,
       blockname);

  map_index = caller_source.stmnt_map_entry_index;
  map_ptr = caller_source.seg_info_ptr -> seg_info.statement_map_ptr;
  no_stmnts = caller_source.seg_info_ptr -> seg_info.map_size;

  if map_ptr ^= null () & map_index > 0 & map_index <= no_stmnts then do;
      file = fixed (map_entry_array (map_index).file, 8);
      line = fixed (map_entry_array (map_index).line, 14);
      stmt = fixed (map_entry_array (map_index).statement, 5);

      call ioa_$rsnnl (
	 "line ^[^d-^;^s^]^d^[,^d^;^s^] in ^a ^[(level ^d)^;^s(no active frame)^]",
	 P_return_string, (0),
	 (file > 0), file,
	 line,
	 (stmt > 1), stmt,
	 blockname,
	 (level >= 0), level);
    end;
    else do;
      call ioa_$rsnnl (
	 "  ^a|^o ^[(level ^d)^;^s(no active frame)^] - ^[map missing^;offset invalid^]",
	 P_return_string, (0),
	 blockname, binary (rel (caller_source.instruction_ptr), 18),
	 (level >= 0), level,
	 map_ptr = null ());
    end;
  return;

  /*  */

%include probe_info;

  /* ;;;;;;; */

%include probe_seg_info;

  /* ;;;;;;; */

%include probe_source_info;

  /* ;;;;;;; */

%include statement_map;

  end probe_pretty_source_info_;




		    probe_print_algol68_attr_.pl1   11/11/88  1555.4r w 11/11/88  1545.0      131319



/****^  ***********************************************************
        *                                                         *
        * 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_print_algol68_attr_:
  proc (P_probe_info_ptr, P_refp, P_long_sw, P_code);

  /* 17 August 1981 Melanie Weaver  this version is just a copy of
   probe_print_pl1_attr_ with type names for new algol68 data types */
  /* probe_print_pl1_attr_ written by Jim Davis 25 May 79 */

  dcl P_probe_info_ptr	ptr parameter;
  dcl P_refp		ptr parameter;
  dcl P_long_sw		bit (1) aligned parameter;
  dcl P_code		fixed bin (35) parameter;

  dcl 1 P_reference		aligned like reference_node based (refp);
  dcl refp		ptr;
  dcl sym			ptr;	/* to symbol node */
  dcl sp			ptr;
  dcl next		ptr;
  dcl (addrel, bin, fixed, hbound, lbound, null, rtrim)
			builtin;
  dcl (
      ioa_$ioa_switch,
      ioa_$rsnnl
      )			entry options (variable);
  dcl probe_block_name_	entry (ptr, ptr, bit (1) aligned)
			returns (char (256) varying);

  probe_info_ptr = P_probe_info_ptr;
  P_code = 0;
  refp = P_refp;
  sym = P_reference.symbol_ptr;

  if sym = null () then do;
      if P_reference.type = ext_procedure_runtime_dtype
        then call ioa_$ioa_switch (probe_info.output_switch, "external entry")
	        ;
        else call ioa_$ioa_switch (probe_info.output_switch,
	        "unknown type (^d)", P_reference.type);

      /* sure wish there was a way to display attributes of external entries */

      return;
    end;				/* non-symbol case */

  call ioa_$ioa_switch (probe_info.output_switch, "^a ^a ^a ^a",
       get_pl1_attr_str (sym),
       get_pl1_class_str (sym),
       get_pl1_dims_str (sym, 0, "1"b),
       get_pl1_level_str (sym));

  if fixed (sym -> runtime_symbol.type, 6) = structure_dtype & P_long_sw
    then
      do sp = addrel (sym, sym -> runtime_symbol.son) /* for son */
	 repeat next while (sp ^= null ());
      call print_member (sp, fixed (sym -> runtime_symbol.ndims, 6));
      if sp -> runtime_symbol.brother ^= (18)"0"b
        then next = addrel (sp, sp -> runtime_symbol.brother);
        else next = null ();
    end;

  call ioa_$ioa_switch (probe_info.output_switch, "Declared in ^a",
       probe_block_name_ (probe_info_ptr, P_reference.source_info_ptr, "0"b));
  return;

print_member:
  proc (s, inheritance);

  dcl s			ptr parameter;
				/* to a symbol node */
  dcl inheritance		fixed bin parameter;
  dcl q			ptr;	/* to son and sons' siblings */
  dcl nextq		ptr;
  dcl level		fixed bin;

  level = fixed (s -> runtime_symbol.level, 6);

  call ioa_$ioa_switch (probe_info.output_switch, "  ^vx^d ^A ^a ^a",
       (level - 2) * 2, level, addrel (s, s -> runtime_symbol.name),
       get_pl1_dims_str (s, inheritance, "0"b),
       get_pl1_attr_str (s));

  if s -> runtime_symbol.son ^= (18)"0"b
    then
      do q = addrel (s, s -> runtime_symbol.son) /* for our son, and for */
	 repeat nextq /* all his brothers, until */
	 while (q ^= null ());	/* curse PL/I, becasue it lacks do-until */
      call print_member (q, fixed (s -> runtime_symbol.ndims, 6));
      if q -> runtime_symbol.brother = (18)"0"b
        then nextq = null ();		/* have reached the end */
        else nextq = addrel (q, q -> runtime_symbol.brother);
    end;				/* son,sibling loop */


  end print_member;

get_pl1_attr_str:
  proc (sym) returns (char (168) varying);

  dcl sym			ptr parameter;

  dcl attr		char (168) varying;
  dcl temp		char (64) varying;
  dcl type		fixed bin;
  dcl p			ptr;

  dcl ptr			builtin;


  type = fixed (sym -> runtime_symbol.type, 6);
  if ^legal_type (type)
    then return ("?");

  attr = "";
  temp = "";

  if data_type_info_$info (type).computational
    then if data_type_info_$info (type).arithmetic
	 then do;
	   attr = attr
	        ||
	        branch_on (data_type_info_$info (type).complex, " complex",
	        "");
	   attr = attr
	        ||
	        branch_on (data_type_info_$info (type).fixed, " fixed",
	        " float");
	   attr = attr
	        ||
	        branch_on (data_type_info_$info (type).decimal, " dec",
	        " bin");

	   if data_type_info_$info (type).arithmetic_attributes.fixed
	     then if sym -> runtime_symbol.scale = "0"b
		  then call ioa_$rsnnl (" (^d)", temp, (0),
			  sym -> runtime_symbol.size);
		  else call ioa_$rsnnl (" (^d,^d)", temp, (0),
			  sym -> runtime_symbol.size,
			  bit8_to_bin8 (sym -> runtime_symbol.scale));
	     else call ioa_$rsnnl (" (^d)", temp, (0),
		     sym -> runtime_symbol.size);
				/* float, has no scale */
	   attr = attr || rtrim (temp);

	   attr = attr
	        ||
	        branch_on (data_type_info_$info (type)
	        .arithmetic_attributes.signed, "", " unsigned");
	 end;			/* arithmetic */
	 else do;			/* string or picture */
	   if data_type_info_$info (type).char_string
	        | data_type_info_$info (type).bit_string
	     then do;
	       attr = attr
		  ||
		  branch_on (data_type_info_$info (type).varying,
		  " varying", "");
	       attr = attr
		  ||
		  branch_on (data_type_info_$info (type).char_string,
		  " char", " bit");
	       attr = attr || "(";
	       attr = attr || value (sym -> runtime_symbol.size, sym);
	       attr = attr || ")";
	     end;			/* strings */
	   else if type = picture_runtime_dtype
	     then do;
	       p = ptr (sym, sym -> runtime_symbol.size);
				/* to picture_info_block */
	       if p -> picture_image.type = picture_complexfix_type |
		  p -> picture_image.type = picture_complexflo_type
	         then attr = attr || " complex picture";
	         else attr = attr || " picture";
	       attr = attr || " """;	/* to begin picture with */
	       attr = attr || p -> picture_image.chars;
	       attr = attr || """";
	     end;			/* picture */
	   else attr = "?";		/* some random computational type */
	 end;			/* non-arithmetic computational */
    else do;			/* non-computational */
      if type = pointer_dtype
        then attr = " pointer";
      else if type = offset_dtype
        then do;
	attr = " offset";
	if sym -> runtime_symbol.size ^= 0
	  then do;
	    attr = attr || "(";
	    attr = attr
	         || symbol_name (addrel (sym, sym -> runtime_symbol.size));
	    attr = attr || ")";
	  end;			/* getting default area */
        end;			/* offset */
      else if type = label_dtype
        then attr = " label variable";
      else if type = entry_dtype
        then attr = " entry variable";
      else if type = structure_dtype
        then attr = " structure";
      else if type = area_dtype
        then do;
	attr = " area (";
	attr = attr || value (sym -> runtime_symbol.size, sym);
	attr = attr || ")";
        end;
      else if type = file_dtype
        then attr = " file";
      else if type = label_constant_runtime_dtype
        then attr = " label";
      else if type = int_entry_runtime_dtype
        then attr = " internal entry";
      else if type = ext_entry_runtime_dtype
        then attr = " external entry";
      else if type = ext_procedure_runtime_dtype
        then attr = " external procedure";
      else if type = algol68_straight_dtype
        then attr = " algol68 straight";
      else if type = algol68_format_dtype
        then attr = " algol68 format";
      else if type = algol68_array_descriptor_dtype
        then attr = " algol68 array descriptor";
      else if type = algol68_union_dtype
        then attr = " algol68 union";
      else attr = "?";
    end;				/* non-computational */

  attr = attr || branch_on (sym -> runtime_symbol.bits.packed, " unal", "");
  return (attr);

branch_on:
  proc (t_or_f, true_str, false_str) returns (char (*));
  dcl t_or_f		bit (1) unal parameter;
  dcl true_str		char (*) parameter;
  dcl false_str		char (*) parameter;

  if t_or_f
    then return (true_str);
    else return (false_str);
  end branch_on;
  end get_pl1_attr_str;

get_pl1_dims_str:
  proc (P_sym, P_inherited, P_verbose) returns (char (168) varying);

  dcl P_sym		ptr parameter;
  dcl P_inherited		fixed bin parameter;
  dcl P_verbose		bit (1) aligned parameter;

  dcl n			fixed bin;
  dcl i			fixed bin;
  dcl dims_str		char (168) varying;

  n = fixed (P_sym -> runtime_symbol.ndims, 6);
  if n <= P_inherited
    then dims_str = "";
    else do;
      if P_verbose
        then dims_str = " dimension (";
        else dims_str = " (";
      do i = P_inherited + 1 to n;
        if P_sym -> runtime_symbol.bounds (i).lower ^= 1
	then do;
	  dims_str =
	       dims_str
	       || value (P_sym -> runtime_symbol.bounds (i).lower, P_sym);
	  dims_str = dims_str || ":";
	end;
        dims_str =
	   dims_str
	   || value (P_sym -> runtime_symbol.bounds (i).upper, P_sym);
        if i < n			/* more to come */
	then dims_str = dims_str || ",";
      end;			/* dims loop */
      dims_str = dims_str || ")";
    end;

  return (dims_str);
  end get_pl1_dims_str;

get_pl1_level_str:
  proc (symb) returns (char (168) varying);
  dcl symb		ptr parameter;

  dcl l			fixed bin;/* level */
  dcl level_str		char (168) varying;

  l = fixed (symb -> runtime_symbol.level, 6);
  if l < 1
    then return ("");
  else if l = 1
    then return (" level 1");
  else do;
    call ioa_$rsnnl (" level ^d in ^a", level_str, (0), l,
         king_of_structure ());
    return (level_str);
  end;

king_of_structure:
  proc () returns (char (64));
  dcl i			fixed bin;
  dcl p			ptr;
  p = symb;
  do i = l - 1 to 1 by -1;
    p = addrel (p, p -> runtime_symbol.father);
  end;
  return (addrel (p, p -> runtime_symbol.name) -> acc.string);
  end king_of_structure;

  end get_pl1_level_str;

get_pl1_class_str:
  proc (symb) returns (char (168) varying);
  dcl symb		ptr parameter;
  dcl based_class		internal static fixed bin
			options (constant) init (3);
  dcl c			fixed bin;/* the class */
  dcl class_str		char (168) varying;

  dcl class_name		(15) char (20) internal static
			options (constant) init (
			"automatic", "automatic", "based",
			"internal static",
			"external static", "internal controlled",
			"external controlled", "parameter",
			"parameter", "?", "?", "constant", "constant",
			"?", "?");

  c = fixed (symb -> runtime_symbol.class, 4);
  class_str = class_name (c);

  if c = based_class
    then if symb -> runtime_symbol.location
	    ^= (18)"0"b /* got implicit qualifier */
	 then do;
	   class_str = class_str || " (";
	   class_str =
	        class_str
	        ||
	        symbol_name (addrel (symb, symb -> runtime_symbol.location))
	        ;
	   class_str = class_str || ")";
	 end;			/* getting implicit locator */

  return (class_str);
  end get_pl1_class_str;


  /* VARIOUS HANDY LITTLE PROCS */

symbol_name:
  proc (sp) returns (char (256) varying);

  dcl sp			ptr parameter;
				/* to the symbol node */
  dcl name		char (256) varying;
				/* its fully qualified name */
  dcl p			ptr;

  p = sp;
  name = addrel (p, p -> runtime_symbol.name) -> acc.string;
				/* our name */
  do while (fixed (p -> runtime_symbol.level, 6) > 1);
				/* invariant: we have a father */
    p = addrel (p, p -> runtime_symbol.father);
				/* point to father */
    name = addrel (p, p -> runtime_symbol.name) -> acc.string || "." || name;
				/* copy name */
  end;
  return (name);
  end symbol_name;



legal_type:
  proc (stype) returns (bit (1) aligned);
  dcl stype		fixed bin parameter;
  return (stype >= lbound (data_type_info_$info, 1) &
       stype <= hbound (data_type_info_$info, 1));
  end legal_type;


bit8_to_bin8:
  proc (b) returns (fixed bin (8));
  dcl b			bit (8) parameter;
  if bin (b, 8) <= 127
    then return (bin (b, 8));
    else return (bin (b, 8) - 256);
  end bit8_to_bin8;


value:
  procedure (ev, context) returns (character (10) varying);

  dcl ev			fixed bin (35) parameter;
				/* input: an encoded value */
  dcl context		ptr parameter;
				/* input: to symbol node of ev */

  dcl val			fixed bin (35);
  dcl 1 an_ev		aligned like encoded_value;
  dcl refp		ptr;	/* to data itself, for decoding */
  dcl block_ptr		ptr;
  dcl stack_ptr		ptr;
  dcl linkage_ptr		ptr;
  dcl based_class		bit (4) internal static options (constant)
			init ("0011"b);
  dcl code		fixed bin (35);
  dcl (char, ltrim, null, rtrim, string, unspec)
			builtin;

  dcl stu_$get_implicit_qualifier
			entry (ptr, ptr, ptr, ptr, ptr) returns (ptr);
  dcl stu_$decode_runtime_value
			entry (fixed bin (35), ptr, ptr, ptr, ptr, ptr,
			fixed bin (35)) returns (fixed bin (35));

  /* GLOBAL imports P_reference */

  string (an_ev) = unspec (ev);
  if an_ev.flag = "10"b
    then do;			/* it is encoded */
      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;
      block_ptr = P_reference.source_info_ptr -> source_info.block_ptr;
      refp = P_reference.address_ptr;
      if refp = null
        then if context -> runtime_symbol.class = based_class
				/* can try for implicit */
	     then refp =
		     stu_$get_implicit_qualifier (block_ptr, context,
		     stack_ptr, linkage_ptr, block_ptr);
      val = stu_$decode_runtime_value (ev, block_ptr, stack_ptr, linkage_ptr,
	 block_ptr, refp, code);
      if code ^= 0
        then return ("*");
    end;
    else val = ev;

  return (rtrim (ltrim (char (val))));

  end value;

%include probe_info;
%include probe_source_info;
%include probe_seg_info;
%include probe_references;
%include std_descriptor_types;
%include runtime_symbol;
%include statement_map;
%include acc;
%include data_type_info_;
%include picture_image;

  end;				/* print_algol68_attr; */




		    probe_print_arglist_.pl1        10/27/88  1250.2r w 10/27/88  1224.5      198324



/****^  ***********************************************************
        *                                                         *
        * 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(86-03-13,GWMay), approve(86-04-16,MCR7373),
     audit(86-04-29,LJAdams), install(86-05-01,MR12.0-1051):
     Changed to reference entry_desc_info_version_2 constant.
  2) change(86-09-08,DGHowe), approve(86-09-08,MCR7524),
     audit(86-09-16,Ginter), install(86-09-24,MR12.0-1158):
     use command name arglist and check for mbz and pad1 to be "0"b
  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 */

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

/* Program to print argument list in "pretty" format.  Based on earlier
   list_frame_args_ by T. VanVleck and S. Webber */
/* Initial Version: 14 June 1974 by B. Wolman */
/* Adapted for probe, 07/15/79 W. Olin Sibert */
/* Truly adapted for probe (a quick job) JRDavis 15 Sept 79 */
/* Changed to flag char strings truncated to 100 chars 09/30/81 S. Herbst */
/* Changed to detect overlength varying strings and return arguments 14 November 1981 J. Spencer Love */
/* Changed to accept all arithmetic types incl hexfp, extended, generic 02/08/84 S. Herbst */

probe_print_arglist_:
  proc (P_probe_info_ptr, P_source_info_ptr);

  dcl P_probe_info_ptr	ptr parameter;
  dcl P_source_info_ptr	ptr parameter;
				/* input: to source info describing frame */

  dcl 1 Arg_source		aligned like source_info
			based (source_info_ptr);
  dcl source_info_ptr	ptr;


  dcl argp		ptr,	/* to a particular arg */
      ap			ptr,	/* to the arglist as a whole */
      descp		ptr,	/* to a descriptor in the arglist */
      ep			ptr,	/* entry ptr for proc of interest */
      ip			ptr,	/* to info about expected arg types */
      arg_index		fixed bin,/* the index of the arg currently being printed */
      oswitch		ptr,	/* the io switch to write on */
      str_length		fixed bin (24),
      scale		fixed bin,
      type		fixed bin,/* data type of Nth arg */
      ndims		fixed bin,/* number of dimensions of N'th arg */
      packed		bit (1) aligned,
				/* was data packed? */
      quick_block		bit (1) aligned,
				/* is this a quick call? */
      expected_type		fixed bin,/* for N'th arg, what was expected data type? */
      expected_scale	fixed bin,/* scale likewise */
      expected_str_length	fixed bin (24),
      expected_ndims,
      expected_packed	bit (1) aligned,
      code		fixed bin (35),
      no_args		fixed bin,/* how many args we have */
      no_descs		fixed bin,/* how many descriptors */
      expected_no_args	fixed bin,/* how many the program wanted */
      arg_list_arg_count	fixed bin,/* for arg_list.incl.pl1 */
      arith_str		char (500) varying,
      hexfp_space		fixed bin (71),
      overlength_varying_string
			fixed bin (24),
      truncated		fixed bin (24),
      type_unknown		bit (1) aligned;

  dcl add_bit_offset_	entry (ptr, fixed bin (24))
			returns (ptr) reducible;
  dcl assign_$computational_	entry (ptr, ptr, fixed bin (35));
  dcl condition_		entry (char (*), entry);
  dcl decode_descriptor_	entry (ptr, fixed bin, fixed bin,
			bit (1) aligned, fixed bin, fixed bin (24),
			fixed bin);
  dcl display_file_value_	entry (ptr, file, fixed bin (35));
  dcl get_entry_arg_descs_$info
			entry (ptr, fixed bin, (*) ptr, ptr,
			fixed bin (35));
  dcl get_ring_		entry () returns (fixed bin (3));
  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 probe_check_ptr_$convert
			entry (ptr, bit (*))
			returns (char (256) varying);
  dcl probe_check_ptr_$convert_packed
			entry (ptr unal, bit (*))
			returns (char (256) varying);

  dcl probe_check_ptr_$check	entry (ptr, fixed bin (35));

  dcl probe_error_		entry options (variable);

  dcl 1 no_arg_info		aligned,
       2 no_args		fixed bin init (-1),
       2 function		bit (1) initial ("0"b);

  dcl 1 arg_info		aligned,	/* for get_entry_arg_descs */
       2 no_args		fixed bin,
       2 function		bit (1),
       2 descs		(128) ptr;

  dcl 1 entry_flags		aligned like entry_desc_info;

  dcl 1 (source, target)	aligned like computational_data;

  dcl word		(2) fixed bin based,
      packed_ptr		unal ptr based,
      unpacked_ptr		aligned ptr based,
      based_file		file based,
      based_length		fixed bin (24) based,
      bit_string		bit (str_length) based,
      char_string		char (str_length) based,
      based_cs		char (100) based;

  dcl (addr, addrel, binary, hbound, ltrim, max, maxlength, min, null, ptr,
      unspec, verify)	builtin;

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

  dcl star_length		fixed bin (24) static init (16777215);
				/* length in char(*) entry descriptor */


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

  dcl 1 entry_arg_info	aligned based,
       2 no_args		fixed bin,
       2 function		bit (1),
       2 descs		(n refer (entry_arg_info.no_args)) ptr;


  probe_info_ptr = P_probe_info_ptr;
  source_info_ptr = P_source_info_ptr;

  oswitch = probe_info.output_switch;

  ep = Arg_source.entry_ptr;		/* needed to decode descriptors */
  sp = Arg_source.stack_ptr;

  call find_arglist ();

  entry_flags.version = entry_desc_info_version_2;
  call get_entry_arg_descs_$info (ep, arg_info.no_args, arg_info.descs,
       addr (entry_flags), code);

  if code = 0 then do;
      arg_info.function = entry_flags.function;
      ip = addr (arg_info);
    end;
    else ip = addr (no_arg_info);

  expected_no_args = ip -> entry_arg_info.no_args;

  if expected_no_args > 0
    then if expected_no_args ^= no_args
	 then call ioa_$ioa_switch (oswitch,
		 "Warning: ^d arguments expected, ^d supplied.",
		 expected_no_args, no_args);

  if no_args = 0 then do;
      call ioa_$ioa_switch (oswitch, "No arguments.");
      return;
    end;

  if no_args > 128 then do;
      call ioa_$ioa_switch (oswitch,
	 "Only first 128 of ^d args will be considered.", no_args);
      no_args = 128;
      expected_no_args = min (expected_no_args, 128);
      if no_descs ^= 0
        then no_descs = 128;
    end;

  call condition_ ("any_other", handler);

  do arg_index = 1 to no_args;

    argp = cv_ptr (ap -> arg_list.arg_ptrs (arg_index));
    type_unknown = "0"b;

    if no_descs ^= 0 then do;
        if ap -> arg_list.call_type = Envptr_supplied_call_type
	then descp =
		cv_ptr (ap -> arg_list_with_envptr.desc_ptrs (arg_index));
	else descp = cv_ptr (ap -> arg_list.desc_ptrs (arg_index));

        call decode_descriptor_ (descp, 0, type, packed, ndims, str_length,
	   scale);

        if expected_no_args >= arg_index
	then if ip -> entry_arg_info.descs (arg_index) ^= null
	       then call compare_expected_with_actual;
      end;
    else if expected_no_args >= arg_index
      then do;
        if ip -> entry_arg_info.descs (arg_index) = null
	then call guess_type;
	else call decode_descriptor_ (ip
		-> entry_arg_info.descs (arg_index), 0, type, packed,
		ndims, str_length, scale);
      end;
    else call guess_type;


    /* now type is set, and possible others such as str_length, scale, packed, a */

    if arg_index = no_args & ip -> entry_arg_info.function
      then do;
        call ioa_$ioa_switch (oswitch, "ARG ^3d @ ^p Returns ^a.", arg_index,
	   argp, type_name (type));
        go to next_arg;
      end;

    call ioa_$ioa_switch_nnl (oswitch, "ARG ^3d @ ^p = ", arg_index, argp);

    if type < -1
      then goto unknown_type;
    if type > hbound (form, 1)
      then goto unknown_type;

    overlength_varying_string, truncated = 0;

    goto form (type);

    /* Arithmetic */

form (1):
form (2):
form (3):
form (4):
form (5):
form (6):
form (7):
form (8):
form (9):
form (10):
form (11):
form (12):
form (29):
form (30):
form (33):
form (34):
form (35):
form (36):
form (38):
form (39):
form (41):
form (42):
form (43):
form (44):
form (45):
form (46):
form (47):
form (48):
form (49):
form (50):
				/* Copied from display_data_ */

    unspec (source) = "0"b;
    source.address = argp;
    source.data_type = type;
    source.packed = packed;
    source.prec_or_length = str_length;
    source.scale = 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;
        target.picture_image_ptr = null;

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

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

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

    arith_str = ltrim (arith_str);
    call ioa_$ioa_switch (oswitch, "^a", arith_str);

    goto next_arg;

    /* Pointer */

form (13):
    if packed
      then call ioa_$ioa_switch (oswitch, "^a",
	      probe_check_ptr_$convert_packed (argp -> packed_ptr, ""b));
      else call ioa_$ioa_switch (oswitch, "^a^[ (type unknown)^]",
	      probe_check_ptr_$convert (argp -> unpacked_ptr, ""b),
	      type_unknown);

    goto next_arg;

    /* Label, Entry Variables */

form (15):
form (16):
    call ioa_$ioa_switch (oswitch, "^a ^[(external entry)^;^p^]",
         probe_check_ptr_$convert (argp -> lv.ptr, ""b),
         (argp -> lv.stack = null ()), argp -> lv.stack);

    /*** What I really want to do here is display a level number instead of a stackframeptr. */

    goto next_arg;


    /* Label, Entry Constants */

form (24):
form (25):
form (26):
form (27):

    call ioa_$ioa_switch (oswitch, "^a",
         probe_check_ptr_$convert (argp -> unpacked_ptr, ""b));

    goto next_arg;

    /* Varying bit string */

form (20):
    if addrel (argp, -1) -> based_length > str_length
         | addrel (argp, -1) -> based_length < 0
      then overlength_varying_string = addrel (argp, -1) -> based_length;
      else str_length = addrel (argp, -1) -> based_length;

    /* Bit string */

form (19):
    if str_length > 72 then do;
        truncated = str_length;
        str_length = 72;
      end;

    call ioa_$ioa_switch (oswitch,
         "^[(Length = ^d, Maxlength = ^d)  ^;^2s^]""^b""b^[ (truncated from ^d bits)^]",
         (overlength_varying_string ^= 0), overlength_varying_string,
         max (str_length, truncated),
         argp -> bit_string, (truncated > 0), truncated);

    goto next_arg;

    /* Varying char string */

form (22):
    if addrel (argp, -1) -> based_length > str_length
         | addrel (argp, -1) -> based_length < 0
      then overlength_varying_string = addrel (argp, -1) -> based_length;
      else str_length = addrel (argp, -1) -> based_length;

    /* Char string */

form (21):
    if str_length > 256 then do;
        truncated = str_length;
        str_length = 168;
      end;

    call ioa_$ioa_switch (oswitch,
         "^[(Length = ^d, Maxlength = ^d)  ^;^2s^]^a^[ (truncated from ^d chars)^;^s^]^[ (type unknown)^]",
         (overlength_varying_string ^= 0), overlength_varying_string,
         max (str_length, truncated),
         requote_string_ (argp -> char_string), (truncated > 0), truncated,
         type_unknown);

    goto next_arg;

    /* File */

form (23):
    call display_file_value_ (oswitch, argp -> based_file, (0));
    goto next_arg;

    /* Cannot determine type */

form (0):
form (-1):
    call ioa_$ioa_switch (oswitch, "^w (type unknown)", argp -> word (1));

    go to next_arg;

    /* Offset */

form (14):
    call ioa_$ioa_switch (oswitch, " ^w", argp -> word (1));

    goto next_arg;

    /* Area or Structure, or unrecognized type */

unknown_type:
form (17):
form (18):
form (28):
form (31):
form (32):
form (37):
form (40):
form (51):
form (52):
form (53):
form (54):
form (55):
form (56):
form (57):
form (58):
form (59):
    call ioa_$ioa_switch (oswitch, " (^a) ^w",
         type_name (type), argp -> word (1));

next_arg:
    if ndims > 0
      then call ioa_$ioa_switch (oswitch, "^10x(^d-dim array)", ndims);

skip_arg:
  end;				/* arg printing loop */
  return;

  /* internal procs follow */

find_arglist:
  procedure ();

  dcl bp			ptr;


  if sp = null ()
    then call probe_error_ (probe_info_ptr, 0,
	    "Can't find arg list because can't find stack frame.");

  bp = Arg_source.block_ptr;
  quick_block = "0"b;
  if bp ^= null ()
    then if bp -> runtime_block.type = ""b
	 then call probe_error_ (probe_info_ptr, 0,
		 "Begin block has no arguments.");
         else if bp -> runtime_block.quick
	 then quick_block = "1"b;

  if quick_block
    then do;			/* Make sure quick block has valid arglistptr.		*/
      ap = addrel (sp, bp -> runtime_block.entry_info);
      if ap -> its.its_mod ^= ITS_MODIFIER | ap -> its.mod ^= ""b
	 | ap -> its.pad1 ^= ""b
	 | ap -> its.pad2 ^= ""b | ap -> its.pad3 ^= ""b
	 | ap -> its.pad4 ^= ""b
	 | binary (ap -> its.ringno) ^= get_ring_ ()
	 | ap -> its.bit_offset ^= ""b
        then do;
	ap = null ();
	no_args, arg_list_arg_count, no_descs = 0;
	return;
        end;
      ap = ap -> quick_entry.argptr;
    end;
    else do;
      call probe_check_ptr_$check (stack_frame.arg_ptr, code);
      if code ^= 0
        then call probe_error_ (probe_info_ptr, code, "(argument ptr)");
      ap = stack_frame.arg_ptr;
    end;

  if ap = null ()
    then call probe_error_ (probe_info_ptr, 0, "Argument ptr is null.");

  call probe_check_ptr_$check (ap, code);
  if code ^= 0
    then call probe_error_ (probe_info_ptr, code);

  if ap -> command_name_arglist.pad1 ^= "0"b |
       ap -> command_name_arglist.mbz ^= "0"b
    then call probe_error_ (probe_info_ptr, 0,
	    "Arg list at ^p has some pad bits set.", ap);

  if ap -> arg_list.call_type ^= Quick_call_type &
       ap -> arg_list.call_type ^= Interseg_call_type &
       ap -> arg_list.call_type ^= Envptr_supplied_call_type
    then call ioa_$ioa_switch (oswitch,
	    "Warning:  Arg list at ^p has bad call type (^d).", ap,
	    ap -> arg_list.call_type);

  if quick_block & (ap -> arg_list.call_type ^= Quick_call_type)
    then call ioa_$ioa_switch (oswitch,
	    "Warning:  Arg list at ^p has nonquick type for quick call.",
	    ap);

  if ^quick_block & (ap -> arg_list.call_type = Quick_call_type)
    then call ioa_$ioa_switch (oswitch,
	    "Warning:  Arg list at ^p has quick type for nonquick call.",
	    ap);

  /* ALM does not set the envptr for C. */

  if bp ^= null () & ^quick_block
    then if ^runtime_block_is_external (bp)
	 then if ap -> arg_list.call_type = Interseg_call_type
		 & probe_info.language_type ^= C_lang_type
	        then call ioa_$ioa_switch (oswitch,
		        "Warning:  Arg list at ^p has no environmentptr.",
		        ap);
	      else if ap -> arg_list_with_envptr.envptr = null ()
		 & probe_info.language_type = C_lang_type
	        then call ioa_$ioa_switch (oswitch,
		        "Warning:  Arg list at ^p has a null environmentptr.",
		        ap);
	      else ;
         else if ap -> arg_list.call_type = Envptr_supplied_call_type
	 then if ap -> arg_list_with_envptr.envptr ^= null ()
	        then call ioa_$ioa_switch (oswitch,
		        "Warning:  Arg list at ^p has extraneous environmentptr.",
		        ap);

  no_args, arg_list_arg_count = ap -> arg_list.arg_count;
  no_descs = ap -> arg_list.desc_count;

  if no_descs > 0 & no_descs ^= no_args
    then call probe_error_ (probe_info_ptr, 0,
	    "Arg list at ^p has ^d args but only ^d descriptors.", ap,
	    no_args, no_descs);

  return;

  end find_arglist;
%page;
  /* This procedure is used to determine whether an entrypoint is internal or external.  It uses the following
   simple heuristic:  the first runtime_block in the runtime symbol table for the current component is
   assumed to be external; all others are considered internal.  I don't like this very well, but it is the
   best that can be done at present.									*/

runtime_block_is_external:
  procedure (bp) returns (bit (1) aligned);

  declare bp		    ptr,
	p		    ptr;

  p = addrel (bp, bp -> runtime_block.header);
  p = addrel (p,
       addrel (p, p -> std_symbol_header.area_pointer)
       -> pl1_symbol_block.root);
  p = addrel (p, p -> runtime_block.son);

  if bp = p
    then return ("1"b);
    else return ("0"b);

  end runtime_block_is_external;
%page;
  /* This procedure performs a (rough) comparison using calling descriptor and entry arg descriptor.
   The global variable arg_index indicates the argument being checked.
   The actual form of structures is not checked. */

compare_expected_with_actual:
  proc;


  call decode_descriptor_ (ip -> entry_arg_info.descs (arg_index), 0,
       expected_type, expected_packed,
       expected_ndims, expected_str_length, expected_scale);

  if type ^= expected_type
    then call ioa_$ioa_switch (oswitch,
	    "Warning: arg ^d type mismatch: ^a supplied, ^a expected.",
	    arg_index, type_name (type), type_name (expected_type));

  if packed ^= expected_packed
    then if (expected_type ^= 19) & (expected_type ^= 21)
	 then call ioa_$ioa_switch (oswitch,
		 "Warning: arg ^d packing mismatch: ^b supplied, ^b expected.",
		 arg_index, packed, expected_packed);

  if ndims ^= expected_ndims
    then call ioa_$ioa_switch (oswitch,
	    "Warning: arg ^d ndims mismatch: ^d supplied, ^d expected.",
	    arg_index, ndims, expected_ndims);

  if str_length ^= expected_str_length
    then if (expected_type < bit_dtype) | (expected_str_length ^= star_length)
	 then call ioa_$ioa_switch (oswitch,
		 "Warning: arg ^d length mismatch: ^d supplied, ^d expected.",
		 arg_index, str_length, expected_str_length);

  if scale ^= expected_scale
    then call ioa_$ioa_switch (oswitch,
	    "Warning: arg ^d scale mismatch: ^d supplied, ^d expected.",
	    arg_index, scale, expected_scale);

  end;
%page;
  /* This procedure attempts to guess the type of a datum by inspection.
   It guesses pointer, character string, or octal word.
   It is called when no descriptors are available. */

guess_type:
  proc;

  packed = "0"b;
  scale = 0;
  ndims = 0;
  type_unknown = "1"b;

  if argp -> its.its_mod = ITS_MODIFIER & argp -> its.pad1 = ""b
    then type = pointer_dtype;
    else do;
      str_length = verify (argp -> based_cs, LEGAL) - 1;
      if str_length < 0
        then str_length = 100;
      if str_length >= 2
        then type = char_dtype;
        else type = -1;
    end;
  end;
%page;
handler:
  proc (mcp, cname, cop, infop, continue);

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

  if cname = "alrm"
    then do;
refuse:
      continue = "1"b;
      return;
    end;

  if cname = "cput"
    then goto refuse;
  if cname = "program_interrupt"
    then goto refuse;
  if cname = "mme2"
    then goto refuse;
  if cname = "finish"
    then goto refuse;
  if cname = "storage"
    then goto refuse;
  if cname = "quit"
    then goto refuse;

  if cname = "cleanup"
    then
         return;

  call ioa_$ioa_switch (oswitch, "not accessible - ^a fault", cname);

  goto skip_arg;
  end handler;
%page;
type_name:
  proc (t) returns (char (40));

  dcl t			fixed bin parameter;
  dcl buff		char (40);

%include probe_data_type_names;

  if t >= 1 & t <= hbound (type_name, 1)
    then
         return (type_name (t));

  call ioa_$rsnnl ("type ^d", buff, 40, t);

  return (buff);

  end;
%page;
cv_ptr:
  procedure (p) returns (ptr);

  declare p		    ptr;

  declare 1 ITS		    aligned like its based (addr (p)),
	1 ITP		    aligned like itp based (addr (p)),
	OFFSET		    bit (18) unaligned based (addr (p));

  if ^quick_block
    then
         return (p);

  if ITS.its_mod = ITS_MODIFIER & ITS.mod = ""b
    then
         return (p);

  if ITS.its_mod = ""b
    then
         return (ptr (ep, OFFSET));

  if ITP.itp_mod = ITP_MODIFIER & binary (ITP.pr_no) = 6
    then
         return (
	    add_bit_offset_ (addrel (sp, ITP.offset),
	    binary (ITP.bit_offset)))
	    ;
  call probe_error_ (probe_info_ptr, 0,
       "Bad modifiers in quick arglist at ^p", ap);
  end cv_ptr;
%page;
%include probe_info;
%page;
%include probe_source_info;
%page;
%include computational_data;
%page;
%include arg_list;
%page;
%include entry_desc_info;
%page;
%include its;
%page;
%include pl1_symbol_block;
%page;
%include quick_entry;
%page;
%include runtime_symbol;
%page;
%include stack_frame;
%page;
%include std_descriptor_types;
%page;
%include std_symbol_header;
%page;
%include probe_lang_types;

  end probe_print_arglist_;




		    probe_print_c_attr_.pl1         11/11/88  1555.4r w 11/11/88  1545.0      139311



/****^  ***********************************************************
        *                                                         *
        * 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_print_c_attr_:
  proc (P_probe_info_ptr, P_refp, P_long_sw, P_code);

  dcl P_probe_info_ptr	parameter ptr;
  dcl P_refp		parameter ptr;
  dcl P_long_sw		parameter bit (1) aligned;
  dcl P_code		parameter fixed bin (35);

  dcl 1 P_reference		aligned like reference_node based (refp);
  dcl refp		ptr;
  dcl sym			ptr;
  dcl sp			ptr;
  dcl next		ptr;
  dcl (addr, addrel, fixed, null, substr)
			builtin;
  dcl (
      ioa_$ioa_switch,
      ioa_$ioa_switch_nnl,
      ioa_$rsnnl
      )			entry options (variable);
  dcl probe_block_name_	entry (ptr, ptr, bit (1) aligned)
			returns (char (256) varying);
  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 next_sym		ptr;
  dcl name_ptr		ptr;
  dcl ioa_str		char (14);
  dcl tackon_parens		char (2) varying init ("");
  dcl dummy_ptr		ptr;
  dcl temp_str_1		char (168) varying;
  dcl temp_str_2		char (168) varying;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

this_symbol_occupies_storage:
  proc (ref_ptr, sym_ptr) returns (bit (1));

  dcl ref_ptr		parameter ptr;
  dcl sym_ptr		parameter ptr;
  dcl containing_block	ptr;
  dcl steps		fixed bin;
  dcl t_ptr		ptr;
  dcl t_name		char (168) varying;
  dcl stu_$find_runtime_symbol
			entry (pointer, char (*), pointer, fixed bin)
			returns (pointer);

  if fixed (sym_ptr -> runtime_symbol.class) ^= 0
    then return ("1"b);

  name_ptr = addrel (sym, fixed (sym -> runtime_symbol.name, 1));
  t_name =
       substr (name_ptr -> acc_str.str_name, 1, name_ptr -> acc_str.str_len);
  if (t_name ^= ref_ptr -> reference_node.name) then do;
      t_ptr =
	 stu_$find_runtime_symbol (ref_ptr
	 -> reference_node.source_info_ptr -> source_info.block_ptr,
	 (ref_ptr -> reference_node.name), containing_block, steps);
      if t_ptr = null ()
        then return ("0"b);
      else if fixed (t_ptr -> runtime_symbol.class) ^= 0
        then return ("1"b);
    end;

  return ("0"b);

  end this_symbol_occupies_storage;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

  dummy_ptr = null ();
  probe_info_ptr = P_probe_info_ptr;
  P_code = 0;
  refp = P_refp;
  sym = P_reference.symbol_ptr;
  next_sym = null ();

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

  if (fixed (sym -> runtime_symbol.level) = 0 &
       fixed (sym -> runtime_symbol.class) = 0 &
       fixed (sym -> runtime_symbol.location) = 0)
    then
         call ioa_$ioa_switch_nnl (probe_info.output_switch, "typedef");

  if P_reference.type = ext_entry_runtime_dtype then do;
      sym = addrel (sym, fixed (sym -> runtime_symbol.son));
      if (fixed (sym -> runtime_symbol.type) = pointer_dtype)
        then
	   ioa_str = "^a^a()";
        else ioa_str = "^a ^a()";
      call ioa_$ioa_switch (probe_info.output_switch, ioa_str,
	 get_c_attr_str (sym, dummy_ptr),
	 substr (name_ptr -> acc_str.str_name, 1,
	 name_ptr -> acc_str.str_len));
      return;
    end;

  if fixed (sym -> runtime_symbol.type) = pointer_dtype
    then
         ioa_str = "^a^a";
    else ioa_str = "^a ^a";

  temp_str_1 = get_c_attr_str (sym, dummy_ptr);
  temp_str_2 =
       substr (name_ptr -> acc_str.str_name, 1, name_ptr -> acc_str.str_len)
       || get_c_dims_str (sym, 0, "0"b) || get_c_class_str (sym);

  if next_sym ^= null ()
    then
         sym = next_sym;

  if ((fixed (sym -> runtime_symbol.type) = structure_dtype |
       fixed (sym -> runtime_symbol.type) = c_enum_dtype |
       fixed (sym -> runtime_symbol.type) = c_union_dtype) & P_long_sw)
    then do;
      if (^this_symbol_occupies_storage (addr (P_reference), sym)) then do;
	temp_str_1 = temp_str_1 || temp_str_2;
	temp_str_2 = "";
        end;
      call ioa_$ioa_switch (probe_info.output_switch, "^a { ", temp_str_1);
      do sp = addrel (sym, sym -> runtime_symbol.son) /* for son */
	 repeat next while (sp ^= null ());
        call print_member (sp, fixed (sym -> runtime_symbol.ndims, 6), 1);
        if sp -> runtime_symbol.brother ^= (18)"0"b
	then next = addrel (sp, sp -> runtime_symbol.brother);
	else next = null ();
      end;
      call ioa_$ioa_switch (probe_info.output_switch, " } ^a", temp_str_2);
    end;
    else
         call ioa_$ioa_switch (probe_info.output_switch, ioa_str, temp_str_1,
	    temp_str_2);

  call ioa_$ioa_switch (probe_info.output_switch, "Declared in ^a",
       probe_block_name_ (probe_info_ptr, P_reference.source_info_ptr, "0"b));
  return;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

print_member:
  proc (s, inheritance, level_num);

  dcl s			ptr parameter;
				/* to a symbol node */
  dcl inheritance		fixed bin parameter;
  dcl level_num		fixed bin parameter;
  dcl q			ptr;	/* to son and sons' siblings */
  dcl nextq		ptr;
  dcl temp_ptr		ptr;
  dcl ioa_str		char (14);
  dcl print_whole_struct_or_union_ptr
			ptr;
  dcl saved_ptr		ptr;
  dcl temp_str_1		char (168) varying;
  dcl temp_str_2		char (168) varying;

  temp_ptr =
       addrel (s, fixed (s -> runtime_symbol.name, 1));
  if (substr (temp_ptr -> acc_str.str_name, 1, 1) = "!")
    then
         return;

  print_whole_struct_or_union_ptr = null ();
  saved_ptr = null ();

  if fixed (s -> runtime_symbol.type) = pointer_dtype
    then
         ioa_str = "^vx ^a^a";
    else
         ioa_str = "^vx ^a ^a";
  temp_str_1 = get_c_attr_str (s, print_whole_struct_or_union_ptr);
  temp_str_2 =
       substr (temp_ptr -> acc_str.str_name, 1, temp_ptr -> acc_str.str_len)
       || get_c_dims_str (s, inheritance, "0"b);

  if print_whole_struct_or_union_ptr ^= null () then do;
      saved_ptr = s;
      s = print_whole_struct_or_union_ptr;
    end;
  if ((fixed (s -> runtime_symbol.type) = structure_dtype |
       fixed (s -> runtime_symbol.type) = c_enum_dtype |
       fixed (s -> runtime_symbol.type) = c_union_dtype) & P_long_sw)
    then do;
      if (^this_symbol_occupies_storage (addr (P_reference), s)) then do;
	temp_str_1 = temp_str_1 || temp_str_2;
	temp_str_2 = "";
        end;
      call ioa_$ioa_switch (probe_info.output_switch, "^vx ^a {",
	 level_num * 4, temp_str_1);
      if s -> runtime_symbol.son ^= (18)"0"b
	 & fixed (s -> runtime_symbol.type) ^= pointer_dtype
	 & fixed (s -> runtime_symbol.type) ^= c_typeref_dtype
        then
	do q =
	     addrel (s, s -> runtime_symbol.son) /* for our son, and for */
	     repeat nextq /* all his brothers, until */
	     while (q ^= null ());	/* curse PL/I, becasue it lacks do-until */
	call print_member (q, fixed (s -> runtime_symbol.ndims, 6),
	     level_num + 1);
	if q -> runtime_symbol.brother = (18)"0"b
	  then nextq = null ();	/* have reached the end */
	  else nextq = addrel (q, q -> runtime_symbol.brother);
        end;			/* son,sibling loop */

      if P_long_sw
        then
	   call ioa_$ioa_switch (probe_info.output_switch, "  ^vx} ^a",
	        level_num * 4, temp_str_2);
    end;
    else
         call ioa_$ioa_switch (probe_info.output_switch, ioa_str,
	    level_num * 4, temp_str_1, temp_str_2);
  if saved_ptr ^= null ()
    then
         s = saved_ptr;

  end print_member;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

get_c_attr_str:
  proc (sym, p_w_s_o_u_ptr) returns (char (168) varying);

  dcl sym			parameter ptr;
  dcl p_w_s_o_u_ptr		parameter ptr;

  dcl son_of_sym		ptr;
  dcl attr		char (168) varying;
  dcl temp		char (64) varying;
  dcl d_type		fixed bin;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

handle_typeref_or_entry:
  proc (start_ptr, attr);

  dcl start_ptr		parameter ptr;
  dcl attr		char (*) var;
  dcl son_of_sym		ptr;
  dcl temp_ptr		ptr;

  son_of_sym =
       addrel (start_ptr, fixed (start_ptr -> runtime_symbol.son));

  if (fixed (son_of_sym -> runtime_symbol.type) = structure_dtype |
       fixed (son_of_sym -> runtime_symbol.type) = c_enum_dtype |
       fixed (son_of_sym -> runtime_symbol.type) = c_union_dtype)
    then
         next_sym = son_of_sym;
  temp_ptr =
       addrel (son_of_sym, fixed (son_of_sym -> runtime_symbol.name, 1));
  if (substr (temp_ptr -> acc_str.str_name, 1, 1) ^= "!")
    then do;
      attr = " "
	 ||
	 substr (temp_ptr -> acc_str.str_name, 1,
	 temp_ptr -> acc_str.str_len) || " " || attr;
      return;
    end;
  else if (fixed (son_of_sym -> runtime_symbol.type) = structure_dtype)
    then
         attr = " struct " || attr;
  else if (fixed (son_of_sym -> runtime_symbol.type) = c_union_dtype)
    then
         attr = " union " || attr;
  else if (fixed (son_of_sym -> runtime_symbol.type) = c_enum_dtype)
    then
         attr = " enum " || attr;

  p_w_s_o_u_ptr = son_of_sym;

  end handle_typeref_or_entry;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

get_standard_type:

  proc ();

  if d_type = char_dtype
    then
         attr = " char " || attr;
  else if d_type = real_fix_bin_1_uns_dtype
    then
         attr = " unsigned int " || attr;
  else if d_type = real_fix_bin_1_dtype
    then
         attr = " int " || attr;
  else if d_type = real_fix_bin_2_dtype
    then
         attr = " long " || attr;
  else if d_type = real_fix_bin_2_uns_dtype
    then
         attr = " unsigned long " || attr;
  else if d_type = real_flt_bin_1_dtype
    then
         attr = " float " || attr;
  else if d_type = real_flt_bin_2_dtype
    then
         attr = " double " || attr;
  else if d_type = label_dtype
    then
         attr = " label " || attr;
  else if d_type = structure_dtype
    then
         attr = " struct ";
  else if d_type = c_union_dtype
    then
         attr = " union ";
  else if d_type = c_enum_dtype
    then
         attr = " enum ";
  else if d_type = c_enum_const_dtype
    then attr = "";
  else attr = " unknown type " || attr;

  end get_standard_type;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

  d_type = fixed (sym -> runtime_symbol.type);

  attr = "";
  temp = "";

  if d_type = c_typeref_dtype | d_type = ext_entry_runtime_dtype
    then
         call handle_typeref_or_entry (sym, attr);
  else if d_type = pointer_dtype then do;
      attr = "*";
      if sym -> runtime_symbol.son ^= "0"b then do;
	son_of_sym =
	     addrel (sym, fixed (sym -> runtime_symbol.son, 17));
	do while (fixed (son_of_sym -> runtime_symbol.type) = pointer_dtype)
	     ;
	  attr = attr || "*";
	  son_of_sym =
	       addrel (son_of_sym,
	       fixed (son_of_sym -> runtime_symbol.son));
	end;
	d_type = fixed (son_of_sym -> runtime_symbol.type);
	if d_type = ext_entry_runtime_dtype
	  then
	       tackon_parens = "()";
	if d_type = c_typeref_dtype | d_type = ext_entry_runtime_dtype
	  then
	       call handle_typeref_or_entry (son_of_sym, attr);
	  else call get_standard_type ();
        end;
    end;
  else call get_standard_type ();

  return (attr);

  end get_c_attr_str;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

get_c_dims_str:
  proc (P_sym, P_inherited, P_verbose) returns (char (168) varying);

  dcl P_sym		ptr parameter;
  dcl P_inherited		fixed bin parameter;
  dcl P_verbose		bit (1) aligned parameter;

  dcl (add_on, n, i)	fixed bin;
  dcl dims_str		char (168) varying;

  n = fixed (P_sym -> runtime_symbol.ndims, 6);
  if n <= P_inherited
    then dims_str = "";
    else do;
      if P_verbose
        then dims_str = " dimension [";
        else dims_str = " [";
      do i = P_inherited + 1 to n;
        add_on = 1;
        if P_sym -> runtime_symbol.bounds (i).lower ^= 0
	then do;
	  dims_str =
	       dims_str
	       || value (P_sym -> runtime_symbol.bounds (i).lower, P_sym);
	  dims_str = dims_str || ":";
	  add_on = 0;
	end;
        dims_str =
	   dims_str
	   ||
	   value (P_sym -> runtime_symbol.bounds (i).upper + add_on, P_sym);
				/* add 1 because C starts with 0 as lower bound */
        if i < n			/* more to come */
	then dims_str = dims_str || "][";
      end;			/* dims loop */
      dims_str = dims_str || "]";
    end;

  return (dims_str);
  end get_c_dims_str;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

get_c_class_str:
  proc (symb) returns (char (*) var);

  dcl symb		ptr parameter;
  dcl c			fixed bin;/* the class */

  c = fixed (symb -> runtime_symbol.address.class);
  if c = 4
    then return (" internal static");
  else if c = 5
    then return (" external static");
  else if c = 12 | c = 13
    then return (" constant");
  return ("");

  end get_c_class_str;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

value:
  procedure (ev, context) returns (character (10) varying);

  dcl ev			fixed bin (35) parameter;
				/* input: an encoded value */
  dcl context		ptr parameter;
				/* input: to symbol node of ev */

  dcl val			fixed bin (35);
  dcl 1 an_ev		aligned like encoded_value;
  dcl refp		ptr;	/* to data itself, for decoding */
  dcl block_ptr		ptr;
  dcl stack_ptr		ptr;
  dcl linkage_ptr		ptr;
  dcl code		fixed bin (35);
  dcl (char, ltrim, rtrim, string, unspec)
			builtin;

  dcl stu_$decode_runtime_value
			entry (fixed bin (35), ptr, ptr, ptr, ptr, ptr,
			fixed bin (35)) returns (fixed bin (35));

  /* GLOBAL imports P_reference */

  string (an_ev) = unspec (ev);
  if an_ev.flag = "10"b
    then do;			/* it is encoded */
      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;
      block_ptr = P_reference.source_info_ptr -> source_info.block_ptr;
      refp = P_reference.address_ptr;
      val = stu_$decode_runtime_value (ev, block_ptr, stack_ptr, linkage_ptr,
	 block_ptr, refp, code);
      if code ^= 0
        then
	   return ("*");
    end;
    else val = ev;

  return (rtrim (ltrim (char (val))));

  end value;
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
%include probe_info;
%page;
%include probe_source_info;
%page;
%include probe_seg_info;
%page;
%include probe_references;
%page;
%include std_descriptor_types;
%page;
%include runtime_symbol;
%page;

  end probe_print_c_attr_;




		    probe_print_cobol_attr_.pl1     11/11/88  1555.4r w 11/11/88  1545.0       89370



/****^  ***********************************************************
        *                                                         *
        * 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_print_cobol_attr_:
  proc (P_probe_info_ptr, P_refp, P_long_sw, P_code);

  /* JRDavis wrote this back in the fifteenth century - it was found in the runes (sic) of a Celtic temple
   and brought here by Alan Chambers.  Translated into PL/I by Jim Davis

   Modified 4 Sept 79 JRD for bug fixes
*/

  dcl P_probe_info_ptr	ptr parameter;
  dcl P_refp		ptr parameter;
  dcl P_long_sw		bit (1) aligned parameter;
  dcl P_code		fixed bin (35) parameter;


  dcl 1 P_reference		aligned like reference_node based (refp);
  dcl refp		ptr;
  dcl sym			ptr;
  dcl sp			ptr;
  dcl ioa_$ioa_switch	entry options (variable);
  dcl (addrel, char, fixed, ltrim, null)
			builtin;

  probe_info_ptr = P_probe_info_ptr;
  P_code = 0;
  refp = P_refp;
  sym = P_reference.symbol_ptr;

  if sym = null () then do;

      if P_reference.type = ext_procedure_runtime_dtype
        then call ioa_$ioa_switch (probe_info.output_switch, "external entry")
	        ;
        else call ioa_$ioa_switch (probe_info.output_switch,
	        "??unknown type?? (^d)", P_reference.type);

      return;
    end;				/* non-symbol case */
  call ioa_$ioa_switch (probe_info.output_switch, "^a ^a ^a",
       get_cobol_level_str (sym),
       get_cobol_attr_str (sym),
       get_cobol_dim_str (sym, 0));

  if P_long_sw
    then
      do sp = addrel (sym, sym -> runtime_symbol.son) repeat sp
	 while (sp ^= null ());
      call print_son (sp, fixed (sym -> runtime_symbol.ndims, 6));
      if sp -> runtime_symbol.brother ^= "0"b
        then sp = addrel (sp, sp -> runtime_symbol.brother);
        else sp = null ();
    end;

  return;

print_son:
  proc (s, inherit_dims);
  dcl s			ptr parameter;
				/* input: to a son symbol */
  dcl inherit_dims		fixed bin parameter;
				/* Dims of Our Father, Living Still */
  dcl q			ptr;
  dcl nextq		ptr;

  call ioa_$ioa_switch (probe_info.output_switch, "^a ^A  ^a ^a",
       get_cobol_level_str (s),
       addrel (s, s -> runtime_symbol.name),
       get_cobol_attr_str (s),
       get_cobol_dim_str (s, inherit_dims));

  if s -> runtime_symbol.son ^= (18)"0"b
    then
      do q = addrel (s, s -> runtime_symbol.son)
	 repeat nextq while (q ^= null ());
				/* curse pl1 for lack of do-until */
      call print_son (q, fixed (s -> runtime_symbol.ndims, 6));
      if q -> runtime_symbol.brother = "0"b
        then nextq = null ();
        else nextq = addrel (q, q -> runtime_symbol.brother);
    end;				/* son,sibling loop */

  end print_son;





get_cobol_level_str:
  proc (sp) returns (char (20) varying);

  dcl sp			ptr parameter;
  dcl l			fixed bin;
  dcl max_depth		fixed bin internal static
			options (constant) init (5);
  dcl indepth		fixed bin;/* number of spaces before level number */
  dcl (char, copy, fixed, ltrim, min, rtrim)
			builtin;

  l = fixed (sp -> runtime_symbol.level, 6);
  indepth = min (l, max_depth) * 3;
  if l = 0
    then return ("  77");
    else return (copy (" ", indepth) || rtrim (ltrim (char (l))));
  end get_cobol_level_str;

get_cobol_attr_str:
  proc (sp) returns (char (64) varying);

  dcl sp			ptr parameter;

  dcl type		fixed bin;
  dcl prec		fixed bin (35);
  dcl scale		fixed bin;
  dcl attr		char (64) varying;

  type = fixed (sp -> runtime_symbol.type, 6);
  prec = fixed (sp -> runtime_symbol.size, 35);
  scale = bit8_to_bin8 (sp -> runtime_symbol.scale);

  if type = cobol_comp_6_dtype /* may also be comp_7 */
    then do;
      if prec <= 17
        then do;
	attr = " COMP-7";
	if sp -> runtime_symbol.aligned
	  then attr = attr || " SYNC";
        end;
        else attr = " COMP-6";
    end;				/* comp-6, 7 */
  else if type = cobol_display_ls_dtype
    then attr = " DISPLAY SIGN SEPARATE LEADING";
  else if type = cobol_display_uns_dtype
    then attr = " DISPLAY";
  else if type = cobol_display_ts_dtype
    then attr = " DISPLAY SIGN SEPARATE TRAILING";
  else if type = cobol_display_ls_overp_dtype
    then attr = " DISPLAY SIGN LEADING";
  else if type = cobol_display_ts_overp_dtype
    then attr = " DISPLAY SIGN TRAILING";
  else if type = cobol_char_string_dtype
    then do;
      attr = " PICTURE (";
      attr = attr || ltrim (char (prec));
      attr = attr || ") x.";
    end;
  else if type = cobol_comp_5_uns_dtype /* or COMP-8 unsigned, cant tell */
    then do;
      attr = " COMP-5 or COMP-8 PICTURE";
      attr = attr || guess_picture (prec, scale);
    end;
  else if type = cobol_comp_5_ts_dtype
    then do;
      attr = " COMP-5 PIC S";
      attr = attr || guess_picture (prec, scale);
    end;
  else if type = cobol_comp_8_ls_dtype
    then do;
      attr = " COMP-8 PIC S";
      attr = attr || guess_picture (prec, scale);
    end;
  else if type = label_constant_runtime_dtype
    then attr = " paragraph label";
  else if type = int_entry_runtime_dtype
       | type = ext_entry_runtime_dtype
       | type = ext_procedure_runtime_dtype
    then attr = " entrypoint";
  else attr = "?";

  return (attr);

guess_picture:
  proc (p, s) returns (char (32) varying);

  dcl p			fixed bin (35) parameter;
				/* "precision" of data */
  dcl s			fixed bin parameter;
				/* "scale" of data */

  dcl (abs, copy)		builtin;

  /* this procedure exists because there is currently no
   encoding of the picture used with arithmetic data in COBOL - fortunately
   it is possible to derive the picture from the prec and scale in the
   symbol table.  Unfortunately as of this date (May 30 79) the scale is
   not correctly in the symbol table
   */

  /* ASSERT p > 0, s is an integer */

  /* three possibilities:

   s <= 0, padding is on the right
   s >0 & s <= prec implied decimal pt
   s>  prec padding on left */

  if s <= 0
    then return (copy ("9", prec) || copy ("P", abs (scale)));
  else if s <= prec
    then return (copy ("9", prec - scale) || "V" || copy ("9", scale));
  else return (copy ("P", scale - prec) || copy ("9", prec));

  end guess_picture;

bit8_to_bin8:
  proc (bit8) returns (fixed bin (8));
  dcl bit8		bit (8) unal parameter;
  dcl bin			builtin;

  if bin (bit8, 8) <= 127
    then return (bin (bit8, 8));
    else return (bin (bit8, 8) - 256);
  end bit8_to_bin8;
  end get_cobol_attr_str;

get_cobol_dim_str:
  proc (symp, inheritance) returns (char (168) varying);
  dcl symp		ptr parameter;
  dcl inheritance		fixed bin parameter;
  dcl dim_str		char (168) varying;
  dcl n			fixed bin;/* number of dims */
  dcl i			fixed bin;

  n = fixed (symp -> runtime_symbol.ndims, 6);
  if n <= inheritance
    then dim_str = "";
    else do;
      dim_str = " OCCURS ";
      do i = inheritance + 1 to n;
        dim_str = dim_str || " ";
        dim_str =
	   dim_str || value (symp -> runtime_symbol.bounds (i).upper, symp);
        if i < n
	then dim_str = dim_str || " ,";
      end;
      dim_str = dim_str || " TIMES";
    end;
  return (dim_str);

  end get_cobol_dim_str;

value:
  procedure (ev, context) returns (character (10) varying);

  dcl ev			fixed bin (35) parameter;
				/* input: an encoded value */
  dcl context		ptr parameter;
				/* input: to symbol node of ev */

  dcl val			fixed bin (35);
  dcl 1 an_ev		aligned like encoded_value;
  dcl refp		ptr;	/* to data itself, for decoding */
  dcl block_ptr		ptr;
  dcl stack_ptr		ptr;
  dcl linkage_ptr		ptr;
  dcl based_class		bit (4) internal static options (constant)
			init ("0011"b);
  dcl code		fixed bin (35);
  dcl (char, ltrim, null, rtrim, string, unspec)
			builtin;

  dcl stu_$get_implicit_qualifier
			entry (ptr, ptr, ptr, ptr, ptr) returns (ptr);
  dcl stu_$decode_runtime_value
			entry (fixed bin (35), ptr, ptr, ptr, ptr, ptr,
			fixed bin (35)) returns (fixed bin (35));

  /* GLOBAL imports P_reference */

  string (an_ev) = unspec (ev);
  if an_ev.flag = "10"b
    then do;			/* it is encoded */
      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;
      block_ptr = P_reference.source_info_ptr -> source_info.block_ptr;
      refp = P_reference.address_ptr;
      if refp = null
        then if context -> runtime_symbol.class = based_class
				/* can try for implicit */
	     then refp =
		     stu_$get_implicit_qualifier (block_ptr, context,
		     stack_ptr, linkage_ptr, block_ptr);
      val = stu_$decode_runtime_value (ev, block_ptr, stack_ptr, linkage_ptr,
	 block_ptr, refp, code);
      if code ^= 0
        then return ("*");
    end;
    else val = ev;

  return (rtrim (ltrim (char (val))));

  end value;

%include probe_info;


%include probe_references;


%include probe_source_info;


%include probe_seg_info;


%include std_descriptor_types;
%include runtime_symbol;

  end probe_print_cobol_attr_;




		    probe_print_fortran_attr_.pl1   11/11/88  1555.4r w 11/11/88  1545.0       70317



/****^  ***********************************************************
        *                                                         *
        * 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_print_fortran_attr_:
  proc (P_probe_info_ptr, P_refp, P_long_sw, P_code);

  /* Added hexadecimal types 02/07/84 S. Herbst */

  dcl P_probe_info_ptr	ptr parameter;
  dcl P_refp		ptr parameter;
  dcl P_long_sw		bit (1) aligned parameter;
  dcl P_code		fixed bin (35) parameter;


  dcl 1 P_reference		aligned like reference_node based (refp);
  dcl refp		ptr;
  dcl Sym			ptr;	/* to the symbol node to print - used GLOBALLY */
  dcl ioa_$ioa_switch	entry options (variable);
  dcl null		builtin;

  probe_info_ptr = P_probe_info_ptr;
  P_code = 0;
  refp = P_refp;
  Sym = P_reference.symbol_ptr;

  if Sym = null () then do;

      if P_reference.type = ext_procedure_runtime_dtype
        then call ioa_$ioa_switch (probe_info.output_switch, " entrypoint");
        else call ioa_$ioa_switch (probe_info.output_switch,
	        " unknown type (^d)", P_reference.type);
      return;
    end;

  call ioa_$ioa_switch (probe_info.output_switch, "^a ^a ^a",
       get_ft_attr_str (),
       get_ft_class_str (),
       get_ft_dim_str ());

  return;

get_ft_attr_str:
  proc returns (char (168) varying);

  dcl attr_str		char (168) varying;
  dcl t			fixed bin;/* data type */
  dcl fixed		builtin;

  t = fixed (Sym -> runtime_symbol.type, 6);
  if t = ft_integer_dtype
    then attr_str = " integer";
  else if t = ft_real_dtype
    then attr_str = " real";
  else if t = ft_double_dtype
    then attr_str = " double precision real";
  else if t = ft_complex_dtype
    then attr_str = " complex";
  else if t = ft_complex_double_dtype
    then attr_str = " double precision complex ";
  else if t = ft_hex_real_dtype
    then attr_str = " real hexadecimal";
  else if t = ft_hex_double_dtype
    then attr_str = " double precision real hexadecimal";
  else if t = ft_hex_complex_dtype
    then attr_str = " complex hexadecimal";
  else if t = ft_hex_complex_double_dtype
    then attr_str = " double precision complex hexadecimal";
  else if t = ft_external_dtype
    then attr_str = " external";
  else if t = ft_logical_dtype
    then attr_str = " logical";
  else if t = ft_char_dtype then do;
      attr_str = " char*";
      attr_str = attr_str || value (Sym -> runtime_symbol.size, Sym);
      if Sym -> runtime_symbol.aligned
        then attr_str = attr_str || " (word aligned)";
        else attr_str = attr_str || " (byte aligned)";
    end;				/* char dtype */
  else if t = label_constant_runtime_dtype
    then attr_str = " label";
  else if t = int_entry_runtime_dtype |
       t = ext_entry_runtime_dtype |
       t = ext_procedure_runtime_dtype
    then attr_str = " entrypoint";
  else attr_str = " (unknown type)";


  return (attr_str);

  end get_ft_attr_str;

get_ft_class_str:
  proc () returns (char (168) varying);

  dcl class_str		char (168) varying;
  dcl c			fixed bin;/* the storage class */
  dcl (addrel, fixed, index, substr)
			builtin;
  dcl tp			ptr;
  dcl i			fixed bin;
  dcl common_class		fixed bin internal static
			options (constant) init (5);

  dcl ft_class		(15) char (10) internal static
			options (constant) init (
			"automatic", "automatic", "?", "static",
			"common",
			"?", "?", "parameter", "parameter", "?",
			"?", "", "", "?", "?");

  c = fixed (Sym -> runtime_symbol.class, 4);

  class_str = ft_class (c);

  if c = common_class & Sym -> runtime_symbol.level ^= "0"b
    then do;
      tp = addrel (Sym, Sym -> runtime_symbol.father);
      tp = addrel (tp, tp -> runtime_block.name);
				/* point to ACC common name */
      i = index (tp -> acc.string, "|");/* will be name|name */
      if substr (tp -> acc.string, 1, i - 1)
	 ^= "b_" /* default coommon name */
        then do;			/* not in default, so give name */
	class_str = class_str || "/";
	class_str = class_str || substr (tp -> acc.string, 1, i - 1);
	class_str = class_str || "/";
        end;			/* copying common name */
    end;				/* common hacking */

  return (class_str);

  end get_ft_class_str;

get_ft_dim_str:
  proc () returns (char (168) varying);

  dcl dim_str		char (168) varying;
  dcl n			fixed bin;/* number of dims */
  dcl i			fixed bin;/* ranges over all dims */
  dcl fixed		builtin;

  n = fixed (Sym -> runtime_symbol.ndims, 6);

  if n = 0
    then return ("");
    else do;
      dim_str = " dimension (";
      do i = n to 1 by -1;
        if Sym -> runtime_symbol.bounds (i).lower ^= 1
	then do;
	  dim_str =
	       dim_str
	       || value (Sym -> runtime_symbol.bounds (i).lower, Sym);
	  dim_str = dim_str || ":";
	end;
        dim_str =
	   dim_str || value (Sym -> runtime_symbol.bounds (i).upper, Sym);
        if i ^= 1
	then dim_str = dim_str || ",";
      end;
      dim_str = dim_str || ")";
    end;
  return (dim_str);

  end get_ft_dim_str;

value:
  procedure (ev, context) returns (character (10) varying);

  dcl ev			fixed bin (35) parameter;
				/* input: an encoded value */
  dcl context		ptr parameter;
				/* input: to symbol node of ev */

  dcl val			fixed bin (35);
  dcl 1 an_ev		aligned like encoded_value;
  dcl refp		ptr;	/* to data itself, for decoding */
  dcl block_ptr		ptr;
  dcl stack_ptr		ptr;
  dcl linkage_ptr		ptr;
  dcl based_class		bit (4) internal static options (constant)
			init ("0011"b);
  dcl code		fixed bin (35);
  dcl (char, ltrim, null, rtrim, string, unspec)
			builtin;

  dcl stu_$get_implicit_qualifier
			entry (ptr, ptr, ptr, ptr, ptr) returns (ptr);
  dcl stu_$decode_runtime_value
			entry (fixed bin (35), ptr, ptr, ptr, ptr, ptr,
			fixed bin (35)) returns (fixed bin (35));

  /* GLOBAL imports P_reference */

  string (an_ev) = unspec (ev);
  if an_ev.flag = "10"b
    then do;			/* it is encoded */
      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;
      block_ptr = P_reference.source_info_ptr -> source_info.block_ptr;
      refp = P_reference.address_ptr;
      if refp = null
        then if context -> runtime_symbol.class = based_class
				/* can try for implicit */
	     then refp =
		     stu_$get_implicit_qualifier (block_ptr, Sym,
		     stack_ptr, linkage_ptr, block_ptr);
      val = stu_$decode_runtime_value (ev, block_ptr, stack_ptr, linkage_ptr,
	 block_ptr, refp, code);
      if code ^= 0
        then return ("*");
    end;
    else val = ev;

  return (rtrim (ltrim (char (val))));

  end value;

%include probe_references;

%include probe_source_info;

%include probe_seg_info;

%include std_descriptor_types;
%include probe_info;

%include acc;
%include runtime_symbol;


  end probe_print_fortran_attr_;




		    probe_print_handlers_.pl1       10/27/88  1250.2r w 10/27/88  1224.5       53010



/****^  ***********************************************************
        *                                                         *
        * 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_print_handlers_ - lists enabled condition handlers in a frame.

   Cribbed 14 November 1981 by J. Spencer Love from list_onunits_, which is called by trace_stack_			*/

probe_print_handlers_:
  procedure (P_probe_info_ptr, P_source_info_ptr);

  declare P_probe_info_ptr	    ptr parameter,
	P_source_info_ptr	    ptr parameter;
				/* input: to source info describing frame */

  declare (addr, addrel, baseno, null, size, unspec)
			    builtin;

  declare cname_len		    fixed bin (21),
	file_given	    bit (1) aligned,
	file_name		    char (32),
	on_unit_ptr	    ptr,
	oswitch		    ptr,
	source_info_ptr	    ptr,
	strp		    ptr;

  declare cname		    char (cname_len)
			    based (on_unit_ptr -> on_unit.name);

  declare 1 Arg_source	    aligned like source_info
			    based (source_info_ptr);

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

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

  declare interpret_ptr_	    entry (ptr, ptr, ptr),
	ioa_$ioa_switch	    entry () options (variable);
%page;
%include probe_info;
%page;
%include probe_source_info;
%page;
%include on_unit;
%page;
%include stack_frame;
%page;
%include interpret_ptr_struc;
%page;

  probe_info_ptr = P_probe_info_ptr;
  source_info_ptr = P_source_info_ptr;

  oswitch = probe_info.output_switch;
  sp = Arg_source.stack_ptr;

  strp = addr (strbuf);

  if (^stack_frame_flags.condition) | (stack_frame.on_unit_relp1 = ""b)
    then do;
      call ioa_$ioa_switch (oswitch, "No handlers.");
      return;
    end;

  do on_unit_ptr = addrel (sp, stack_frame.on_unit_relp1)
       repeat (addrel (sp, on_unit_ptr -> on_unit.next))
       while (on_unit_ptr ^= sp);

    cname_len = on_unit_ptr -> on_unit.size;
    if cname_len < 0
      then do;
        call ioa_$ioa_switch (oswitch,
	   "Warning:  On unit at ^p has condition name length of ^d.",
	   on_unit_ptr, cname_len);
        cname_len = 0;
      end;
    else if cname_len > 32
      then do;
        call ioa_$ioa_switch (oswitch,
	   "Warning:  On unit at ^p has condition name length of ^d.
^-Maximum length for condition names is 32.", on_unit_ptr, cname_len);
        cname_len = 32;
      end;

    if cname_len > 0
      then do;
        if on_unit_ptr -> on_unit.pad ^= ""b
	then call ioa_$ioa_switch (oswitch,
		"Warning:  Pad field in on unit at ^p is ""^16b""b.",
		on_unit_ptr, on_unit_ptr -> on_unit.pad);

        call check_file_given ();

        if on_unit_ptr -> on_unit.flags.pl1_system
	then call ioa_$ioa_switch (oswitch,
		"on ^a^[ (^a)^;^s^]^[ snap^] system;", cname, file_given,
		file_name, on_unit_ptr -> on_unit.pl1_snap);

	else do;
	  call interpret_ptr_ (on_unit_ptr -> on_unit.body, null (), strp);
	  call ioa_$ioa_switch (oswitch,
	       "on ^a^[ (^a)^;^s^]^[ snap^] call ^a^a|^a ^a", cname,
	       file_given, file_name, on_unit_ptr -> on_unit.pl1_snap,
	       struc.segment,
	       struc.entryn, struc.offset, struc.comment);
	end;
      end;
  end;
  return;
%page;
  /* The following procedure tries to guess if this is a file condition.  We could just check the list of condition
   names which normally have file pointers, but it is possible that handlers could be set up which are nonstandard.
   The PL/I operator which sets up file conditions sets on_unit.file to addrel (addr (on_unit.file), 2) and puts a
   copy of the file variable after the on unit.  This must be done since the storage for the on_unit cannot be
   preallocated in the stack frame because the same on statement can set up multiple concurrent on_units if it
   specifies a file variable.  There is at present NO INDICATION in the on_unit that the file field is valid; until
   there is, this will have to do.  I plan to lobby for setting aside another flag bit to indicate that the file
   field is valid.											*/

check_file_given:
  procedure ();

  declare file_ptr		    ptr;

  file_given = "0"b;

  /* If condition_ is used, name will have been copied onto stack.  Otherwise, name will point to text section.		*/

  if baseno (on_unit_ptr -> on_unit.name) = baseno (sp)
    then
         return;

  /* Value must be exactly as created by an spri instruction in same ring.					*/

  file_ptr = addrel (on_unit_ptr, size (on_unit));

  if unspec (file_ptr) ^= unspec (on_unit_ptr -> on_unit.file)
    then
         return;

  /* For unlikely coincidence that these constraints, we will try to treat the pointer as pointing to a file value.	*/

  file_name = file_ptr -> filevar.fabp -> fab.filename;
  file_given = "1"b;
  return;

  end check_file_given;

  end probe_print_handlers_;




		    probe_print_pascal_.pl1         11/11/88  1555.4r w 11/11/88  1545.0       87318



/****^  *************************************************************************
        *                                                                       *
        * Copyright, (C) Honeywell Bull Inc., 1988                              *
        *                                                                       *
        * Copyright (c) 1980 by Centre Interuniversitaire de Calcul de Grenoble *
        * and Institut National de Recherche en Informatique et Automatique     *
        *                                                                       *
        ************************************************************************* */

/****^  HISTORY COMMENTS:
  1) change(86-09-05,JMAthane), approve(86-09-05,MCR7525),
     audit(86-09-11,Martinson), install(86-11-12,MR12.0-1212):
     This procedure now calls pascal_symbol_$display_data_. or
     pascal_symbol_$display_declaration entries instead of doing things itself.
     pascal_symbol_ entries are used by other tools to display the value of any
     PASCAL object, given a reference to its corresponding symbol table entry.
  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 */

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

/* Written: JMAthane Grenoble University 1983 */
/* Fixed "sb field_name" not to fault if parent node has no name 07/25/83 S. Herbst */
/* Fixed "v field_name not to fault if address cannot be computed 07/26/83 S. Herbst */
/* Changed for new probe_increment_indices_ calling sequence 08/02/83 Olin Sibert */
/* Fixed bug causing random results from "v enumerated_subrange_var" 08/03/83 S. Herbst */
/* Changed to print cross-sections created by probe_get_value_ 08/18/83 S. Herbst */
/* Added version string to runtime_type_info structure 10/06/83 S. Herbst */
/* Fixed bug in cross_sections JMAthane 20/03/83 */
/* Modified to pack printing when array elements are equal JMAthane 20/03/83 */
/* Modified to call pascal_symbol_ subroutines, instead of doing things here.	JMAthane June 85 */

/* Entries:
   probe_print_pascal_$attr entry (ptr, ptr, bit (1), fixed bin (35))
   probe_print_pascal_$value entry (ptr, ptr, fixed bin (35), bit(1))
*/

probe_print_pascal_:
  proc;

  dcl probe_error_$malfunction
			entry options (variable);

  call probe_error_$malfunction ();
%page;
attr:
  entry (P_probe_info_ptr, P_refp, P_long_sw, P_code);

  dcl P_probe_info_ptr	ptr;
  dcl P_refp		ptr;
  dcl P_long_sw		bit (1);
  dcl P_code		fixed bin (35);


  dcl 1 P_reference		like reference_node based (refp);
  dcl refp		ptr;
  dcl Sym			ptr;
  dcl long_switch		bit (1);
  dcl ioa_$ioa_switch	entry options (variable);
  dcl ioa_$ioa_switch_nnl	entry options (variable);
  dcl margin		fixed bin (35) init (1);

  dcl (copy, null)		builtin;

%page;

  probe_info_ptr = P_probe_info_ptr;
  refp = P_refp;
  Sym = P_reference.symbol_ptr;
  long_switch = P_long_sw;

  call ioa_$ioa_switch_nnl (probe_info.output_switch, copy (" ", margin));
  if P_reference.type = ext_procedure_runtime_dtype
    then
         if P_reference.symbol_ptr = null then do;
	   call ioa_$ioa_switch (probe_info.output_switch,
	        "external procedure");
	   return;
	 end;

  if (P_reference.type = pascal_typed_pointer_type_dtype)
       | (P_reference.type = pascal_record_file_type_dtype)
       | (P_reference.type = pascal_record_type_dtype)
       | (P_reference.type = pascal_set_dtype)
       | (P_reference.type = pascal_enumerated_type_dtype)
       | (P_reference.type = pascal_string_type_dtype)
       | (P_reference.type = pascal_user_defined_type_dtype) then do;
      call pascal_symbol_$display_declaration (Sym, probe_info.output_switch,
	 0, 3, "00101"b, error_code);
      if error_code ^= 0
        then go to SOME_ERROR;
    end;

  else if (P_reference.type = pascal_value_formal_parameter_dtype)
       | (P_reference.type = pascal_variable_formal_parameter_dtype)
       | (P_reference.type = pascal_entry_formal_parameter_dtype)
       | (P_reference.type = pascal_label_dtype)
       | (P_reference.type = pascal_parameter_procedure_dtype)
       | (P_reference.type = pascal_internal_procedure_dtype)
       | (P_reference.type = pascal_exportable_procedure_dtype)
       | (P_reference.type = pascal_imported_procedure_dtype)
       | (P_reference.type = pascal_integer_dtype)
       | (P_reference.type = pascal_real_dtype)
       | (P_reference.type = pascal_char_dtype)
       | (P_reference.type = pascal_boolean_dtype)
       | (P_reference.type = pascal_enumerated_type_instance_dtype)
       | (P_reference.type = pascal_enumerated_type_element_dtype)
       | (P_reference.type = pascal_user_defined_type_instance_dtype)
       | (P_reference.type = pascal_text_file_dtype)
    then do;
      if Sym ^= null
        then
	   call pascal_symbol_$display_declaration
	        (Sym, probe_info.output_switch, margin, 3,
	        "011"b || P_long_sw || "1"b, error_code);
        else
	   call pascal_symbol_$display_var_type
	        (P_reference.type, P_reference.type_ptr,
	        probe_info.output_switch, margin, 3, P_long_sw || "1"b,
	        error_code);
      if error_code ^= 0
        then go to SOME_ERROR;
    end;

  return;

%page;
value:
  entry (P_probe_info_ptr, P_refp, P_code, P_done);

  dcl P_done		bit (1) aligned;

  dcl symb_name		char (256) var;
  dcl name_ptr		ptr;
  dcl error_code		fixed bin (35);
  dcl Block_ptr		ptr;
  dcl Base_addr		ptr;
  dcl Linkage_ptr		ptr;
  dcl Stack_ptr		ptr;
  dcl probe_et_$no_address	fixed bin (35) ext;
  dcl probe_et_$recorded_message
			fixed bin (35) ext;
  dcl probe_error_$record	entry options (variable);
  dcl 1 ref_subscripts	aligned based (P_reference.subscript_ptr)
			like reference_subscripts;
  dcl 1 subscript_info	like reference_subscripts;

  refp = P_refp;
  Sym = P_reference.symbol_ptr;
  long_switch = "1"b;
  probe_info_ptr = P_probe_info_ptr;

  if P_reference.address_ptr = null
       & ^data_type_info_$info (P_reference.type).type
    then do;
NO_ADDRESS:
      call probe_error_$record (probe_info_ptr, probe_et_$no_address,
	 P_reference.name);
      error_code = probe_et_$recorded_message;
      go to SOME_ERROR;
    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;

  P_done = "0"b;
  error_code = 0;
  symb_name = P_reference.name;
  if symb_name = ""
    then
         if Sym ^= null then do;
	   name_ptr = runtime_symbol_info_$name (Sym);
	   if name_ptr ^= null
	     then
		symb_name = name_ptr -> acc.string;
	 end;

  if P_reference.type = pascal_typed_pointer_type_dtype
       | P_reference.type = pascal_record_file_type_dtype
       | P_reference.type = pascal_record_type_dtype
       | P_reference.type = pascal_set_dtype
       | P_reference.type = pascal_enumerated_type_dtype
       | P_reference.type = pascal_string_type_dtype
       | P_reference.type = pascal_user_defined_type_dtype then do;
      call pascal_symbol_$display_declaration (Sym, probe_info.output_switch,
	 margin, 3, "11011"b, error_code);
      if error_code ^= 0
        then go to SOME_ERROR;
      P_done = "1"b;
    end;
  else if (P_reference.type = pascal_value_formal_parameter_dtype)
       | (P_reference.type = pascal_variable_formal_parameter_dtype)
       | (P_reference.type = pascal_entry_formal_parameter_dtype)
       | (P_reference.type = pascal_label_dtype)
       | (P_reference.type = pascal_parameter_procedure_dtype)
       | (P_reference.type = pascal_internal_procedure_dtype)
       | (P_reference.type = pascal_exportable_procedure_dtype)
       | (P_reference.type = pascal_imported_procedure_dtype)
       | (P_reference.type = pascal_integer_dtype)
       | (P_reference.type = pascal_real_dtype)
       | (P_reference.type = pascal_char_dtype)
       | (P_reference.type = pascal_boolean_dtype)
       | (P_reference.type = pascal_enumerated_type_instance_dtype)
       | (P_reference.type = pascal_enumerated_type_element_dtype)
       | (P_reference.type = pascal_user_defined_type_instance_dtype)
       | (P_reference.type = pascal_text_file_dtype)
    then do;
      if P_reference.cross_section
        then subscript_info = ref_subscripts;
        else subscript_info.number = 0;
      call pascal_symbol_$display_data (P_reference.type,
	 P_reference.type_ptr, probe_info.output_switch, margin, 3, "111"b,
	 Stack_ptr, Linkage_ptr, Block_ptr, subscript_info,
	 P_reference.address_ptr, symb_name, P_reference.precision,
	 error_code);
      if error_code ^= 0
        then go to SOME_ERROR;
      P_done = "1"b;
    end;

NORMAL_RETURN:

  P_code = 0;

  return;


SOME_ERROR:

  P_code = error_code;
  P_done = "1"b;

  return;
%include probe_info;
%page;
%include probe_seg_info;
%page;
%include probe_source_info;
%page;
%include probe_references;
%page;
%include pascal_loc_class_codes;
%page;
%include std_descriptor_types;
%page;
%include acc;
%page;
%include runtime_symbol;
%page;
%include runtime_symbol_block;
%page;
%include runtime_block_type;
%page;
%include runtime_symbol_info_;
%page;
%include data_type_info_;
%page;
%include system;
%page;
%include pascal_symbol_;


  end probe_print_pascal_;




		    probe_print_pl1_attr_.pl1       11/11/88  1555.4r w 11/11/88  1545.0      126927



/****^  ***********************************************************
        *                                                         *
        * 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_print_pl1_attr_:
  proc (P_probe_info_ptr, P_refp, P_long_sw, P_code);

  /* Jim Davis 25 May 79 */

  dcl P_probe_info_ptr	ptr parameter;
  dcl P_refp		ptr parameter;
  dcl P_long_sw		bit (1) aligned parameter;
  dcl P_code		fixed bin (35) parameter;

  dcl 1 P_reference		aligned like reference_node based (refp);
  dcl refp		ptr;
  dcl sym			ptr;	/* to symbol node */
  dcl sp			ptr;
  dcl next		ptr;
  dcl (addrel, bin, fixed, hbound, lbound, null, rtrim, substr)
			builtin;
  dcl (
      ioa_$ioa_switch,
      ioa_$rsnnl
      )			entry options (variable);
  dcl probe_block_name_	entry (ptr, ptr, bit (1) aligned)
			returns (char (256) varying);

  probe_info_ptr = P_probe_info_ptr;
  P_code = 0;
  refp = P_refp;
  sym = P_reference.symbol_ptr;

  if sym = null () then do;
      if P_reference.type = ext_procedure_runtime_dtype
        then call ioa_$ioa_switch (probe_info.output_switch, "external entry")
	        ;
        else call ioa_$ioa_switch (probe_info.output_switch,
	        "unknown type (^d)", P_reference.type);

      /* sure wish there was a way to display attributes of external entries */
      return;
    end;				/* non-symbol case */

  call ioa_$ioa_switch (probe_info.output_switch, "^a ^a ^a ^a",
       get_pl1_attr_str (sym),
       get_pl1_class_str (sym),
       get_pl1_dims_str (sym, 0, "1"b),
       get_pl1_level_str (sym));

  if fixed (sym -> runtime_symbol.type, 6) = structure_dtype & P_long_sw
    then
      do sp = addrel (sym, sym -> runtime_symbol.son) /* for son */
	 repeat next while (sp ^= null ());
      call print_member (sp, fixed (sym -> runtime_symbol.ndims, 6));
      if sp -> runtime_symbol.brother ^= (18)"0"b
        then next = addrel (sp, sp -> runtime_symbol.brother);
        else next = null ();
    end;

  call ioa_$ioa_switch (probe_info.output_switch, "Declared in ^a",
       probe_block_name_ (probe_info_ptr, P_reference.source_info_ptr, "0"b));
  return;

print_member:
  proc (s, inheritance);

  dcl s			ptr parameter;
				/* to a symbol node */
  dcl inheritance		fixed bin parameter;
  dcl q			ptr;	/* to son and sons' siblings */
  dcl nextq		ptr;
  dcl level		fixed bin;

  level = fixed (s -> runtime_symbol.level, 6);

  call ioa_$ioa_switch (probe_info.output_switch, "  ^vx^d ^A ^a ^a",
       (level - 2) * 2, level, addrel (s, s -> runtime_symbol.name),
       get_pl1_dims_str (s, inheritance, "0"b),
       get_pl1_attr_str (s));

  if s -> runtime_symbol.son ^= (18)"0"b
    then
      do q = addrel (s, s -> runtime_symbol.son) /* for our son, and for */
	 repeat nextq /* all his brothers, until */
	 while (q ^= null ());	/* curse PL/I, becasue it lacks do-until */
      call print_member (q, fixed (s -> runtime_symbol.ndims, 6));
      if q -> runtime_symbol.brother = (18)"0"b
        then nextq = null ();		/* have reached the end */
        else nextq = addrel (q, q -> runtime_symbol.brother);
    end;				/* son,sibling loop */

  end print_member;

get_pl1_attr_str:
  proc (sym) returns (char (168) varying);

  dcl sym			ptr parameter;

  dcl attr		char (168) varying;
  dcl temp		char (64) varying;
  dcl type		fixed bin;
  dcl p			ptr;

  dcl ptr			builtin;

  type = fixed (sym -> runtime_symbol.type, 6);
  if ^legal_type (type)
    then
         return ("?");

  attr = "";
  temp = "";

  if data_type_info_$info (type).computational
    then if data_type_info_$info (type).arithmetic
	 then do;
	   attr = attr
	        ||
	        branch_on (data_type_info_$info (type).complex, " complex",
	        "");
	   attr = attr
	        ||
	        branch_on (data_type_info_$info (type).fixed, " fixed",
	        " float");
	   attr = attr
	        ||
	        branch_on (data_type_info_$info (type).decimal, " dec",
	        " bin");

	   if data_type_info_$info (type).arithmetic_attributes.fixed
	     then if sym -> runtime_symbol.scale = "0"b
		  then call ioa_$rsnnl (" (^d)", temp, (0),
			  sym -> runtime_symbol.size);
		  else call ioa_$rsnnl (" (^d,^d)", temp, (0),
			  sym -> runtime_symbol.size,
			  bit8_to_bin8 (sym -> runtime_symbol.scale));
	     else call ioa_$rsnnl (" (^d)", temp, (0),
		     sym -> runtime_symbol.size);
				/* float, has no scale */
	   attr = attr || rtrim (temp);

	   attr = attr
	        ||
	        branch_on (data_type_info_$info (type)
	        .arithmetic_attributes.signed, "", " unsigned");
	 end;			/* arithmetic */
	 else do;			/* string or picture */
	   if data_type_info_$info (type).char_string
	        | data_type_info_$info (type).bit_string
	     then do;
	       attr = attr
		  ||
		  branch_on (data_type_info_$info (type).varying,
		  " varying", "");
	       attr = attr
		  ||
		  branch_on (data_type_info_$info (type).char_string,
		  " char", " bit");
	       attr = attr || "(";
	       attr = attr || value (sym -> runtime_symbol.size, sym);
	       attr = attr || ")";
	     end;			/* strings */
	   else if type = picture_runtime_dtype
	     then do;
	       p = ptr (sym, sym -> runtime_symbol.size);
				/* to picture_info_block */
	       if p -> picture_image.type = picture_complexfix_type |
		  p -> picture_image.type = picture_complexflo_type
	         then attr = attr || " complex picture";
	         else attr = attr || " picture";
	       attr = attr || " """;	/* to begin picture with */
	       attr = attr || p -> picture_image.chars;
	       attr = attr || """";
	     end;			/* picture */
	   else attr = "?";		/* some random computational type */
	 end;			/* non-arithmetic computational */
    else do;			/* non-computational */
      if type = pointer_dtype
        then attr = " pointer";
      else if type = offset_dtype
        then do;
	attr = " offset";
	if sym -> runtime_symbol.size ^= 0
	  then do;
	    attr = attr || "(";
	    attr = attr
	         || symbol_name (addrel (sym, sym -> runtime_symbol.size));
	    attr = attr || ")";
	  end;			/* getting default area */
        end;			/* offset */
      else if type = label_dtype
        then attr = " label variable";
      else if type = entry_dtype
        then attr = " entry variable";
      else if type = structure_dtype
        then attr = " structure";
      else if type = area_dtype
        then do;
	attr = " area (";
	attr = attr || value (sym -> runtime_symbol.size, sym);
	attr = attr || ")";
        end;
      else if type = file_dtype
        then attr = " file";
      else if type = label_constant_runtime_dtype
        then attr = " label";
      else if type = int_entry_runtime_dtype
        then attr = " internal entry";
      else if type = ext_entry_runtime_dtype
        then attr = " external entry";
      else if type = ext_procedure_runtime_dtype
        then attr = " external procedure";
      else attr = "?";
    end;				/* non-computational */

  attr = attr || branch_on (sym -> runtime_symbol.bits.packed, " unal", "");
  return (attr);

branch_on:
  proc (t_or_f, true_str, false_str) returns (char (*));
  dcl t_or_f		bit (1) unal parameter;
  dcl true_str		char (*) parameter;
  dcl false_str		char (*) parameter;

  if t_or_f
    then return (true_str);
    else return (false_str);
  end branch_on;

  end get_pl1_attr_str;

get_pl1_dims_str:
  proc (P_sym, P_inherited, P_verbose) returns (char (168) varying);

  dcl P_sym		ptr parameter;
  dcl P_inherited		fixed bin parameter;
  dcl P_verbose		bit (1) aligned parameter;

  dcl n			fixed bin;
  dcl i			fixed bin;
  dcl dims_str		char (168) varying;

  n = fixed (P_sym -> runtime_symbol.ndims, 6);
  if n <= P_inherited
    then dims_str = "";
    else do;
      if P_verbose
        then dims_str = " dimension (";
        else dims_str = " (";
      do i = P_inherited + 1 to n;
        if P_sym -> runtime_symbol.bounds (i).lower ^= 1
	then do;
	  dims_str =
	       dims_str
	       || value (P_sym -> runtime_symbol.bounds (i).lower, P_sym);
	  dims_str = dims_str || ":";
	end;
        dims_str =
	   dims_str
	   || value (P_sym -> runtime_symbol.bounds (i).upper, P_sym);
        if i < n			/* more to come */
	then dims_str = dims_str || ",";
      end;			/* dims loop */
      dims_str = dims_str || ")";
    end;
  return (dims_str);
  end get_pl1_dims_str;

get_pl1_level_str:
  proc (symb) returns (char (168) varying);
  dcl symb		ptr parameter;

  dcl l			fixed bin;/* level */
  dcl level_str		char (168) varying;

  l = fixed (symb -> runtime_symbol.level, 6);
  if l < 1
    then
         return ("");
  else if l = 1
    then
         return (" level 1");
  else do;
    call ioa_$rsnnl (" level ^d in ^a", level_str, (0), l,
         king_of_structure ());
    return (level_str);
  end;

king_of_structure:
  proc () returns (char (64));
  dcl i			fixed bin;
  dcl p			ptr;

  p = symb;
  do i = l - 1 to 1 by -1;
    p = addrel (p, p -> runtime_symbol.father);
  end;
  return (addrel (p, p -> runtime_symbol.name) -> acc.string);
  end king_of_structure;

  end get_pl1_level_str;

get_pl1_class_str:
  proc (symb) returns (char (168) varying);
  dcl symb		ptr parameter;
  dcl based_class		internal static fixed bin
			options (constant) init (3);
  dcl c			fixed bin;/* the class */
  dcl class_str		char (168) varying;

  dcl class_name		(15) char (20) internal static
			options (constant) init (
			"automatic", "automatic", "based",
			"internal static",
			"external static", "internal controlled",
			"external controlled", "parameter",
			"parameter", "?", "?", "constant", "constant",
			"?", "?");

  c = fixed (symb -> runtime_symbol.class, 4);
  class_str = class_name (c);

  if c = based_class
    then if symb -> runtime_symbol.location
	    ^= (18)"0"b /* got implicit qualifier */
	 then do;
	   class_str = class_str || " (";
	   class_str =
	        class_str
	        ||
	        symbol_name (addrel (symb, symb -> runtime_symbol.location))
	        ;
	   class_str = class_str || ")";
	 end;			/* getting implicit locator */
  return (class_str);
  end get_pl1_class_str;


  /* VARIOUS HANDY LITTLE PROCS */

symbol_name:
  proc (sp) returns (char (256) varying);

  dcl sp			ptr parameter;
				/* to the symbol node */
  dcl name		char (256) varying;
				/* its fully qualified name */
  dcl p			ptr;

  p = sp;
  name = addrel (p, p -> runtime_symbol.name) -> acc.string;
				/* our name */
  do while (fixed (p -> runtime_symbol.level, 6) > 1);
				/* invariant: we have a father */
    p = addrel (p, p -> runtime_symbol.father);
				/* point to father */
    name = addrel (p, p -> runtime_symbol.name) -> acc.string || "." || name;
				/* copy name */
  end;
  return (name);
  end symbol_name;



legal_type:
  proc (stype) returns (bit (1) aligned);
  dcl stype		fixed bin parameter;

  return (stype >= lbound (data_type_info_$info, 1) &
       stype <= hbound (data_type_info_$info, 1));
  end legal_type;


bit8_to_bin8:
  proc (b) returns (fixed bin (8));
  dcl b			bit (8) parameter;

  if bin (b, 8) <= 127
    then return (bin (b, 8));
    else return (bin (b, 8) - 256);
  end bit8_to_bin8;


value:
  procedure (ev, context) returns (character (10) varying);

  dcl ev			fixed bin (35) parameter;
				/* input: an encoded value */
  dcl context		ptr parameter;
				/* input: to symbol node of ev */

  dcl val			fixed bin (35);
  dcl 1 an_ev		aligned like encoded_value;
  dcl refp		ptr;	/* to data itself, for decoding */
  dcl block_ptr		ptr;
  dcl stack_ptr		ptr;
  dcl linkage_ptr		ptr;
  dcl based_class		bit (4) internal static options (constant)
			init ("0011"b);
  dcl code		fixed bin (35);
  dcl (char, ltrim, null, rtrim, string, unspec)
			builtin;

  dcl stu_$get_implicit_qualifier
			entry (ptr, ptr, ptr, ptr, ptr) returns (ptr);
  dcl stu_$decode_runtime_value
			entry (fixed bin (35), ptr, ptr, ptr, ptr, ptr,
			fixed bin (35)) returns (fixed bin (35));

  /* GLOBAL imports P_reference */

  string (an_ev) = unspec (ev);
  if an_ev.flag = "10"b
    then do;			/* it is encoded */
      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;
      block_ptr = P_reference.source_info_ptr -> source_info.block_ptr;
      refp = P_reference.address_ptr;
      if refp = null
        then if context -> runtime_symbol.class = based_class
				/* can try for implicit */
	     then refp =
		     stu_$get_implicit_qualifier (block_ptr, context,
		     stack_ptr, linkage_ptr, block_ptr);
      val = stu_$decode_runtime_value (ev, block_ptr, stack_ptr, linkage_ptr,
	 block_ptr, refp, code);
      if code ^= 0
        then
	   return ("*");
    end;
    else val = ev;
  return (rtrim (ltrim (char (val))));

  end value;

%include probe_info;
%include probe_source_info;
%include probe_seg_info;
%include probe_references;
%include std_descriptor_types;
%include runtime_symbol;
%include statement_map;
%include acc;
%include data_type_info_;
%include picture_image;

  end;				/* print_pl1_attr; */




		    probe_print_stack_.pl1          10/27/88  1250.2r w 10/27/88  1224.6      104022



/****^  ***********************************************************
        *                                                         *
        * 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_print_stack_:
  proc ();

  call probe_error_$malfunction ();	/* can't call here */

  /* *	This procedure implements the stack printing feature of probe, as well
   *	as the request used to print the stack.

   Modified 3 Sept 79 JRD -  to make stack req. respect the "execute" bit. */
  /* Format shortened, "long" added 09/30/81 S. Herbst */
  /* Changed to print support frames with decimal increments 12/10/81 S. Herbst */
  /* Trailing space removed 07/26/82 S. Herbst */
  /* Fixed "stack long all" not to print garbage pathname for return_to_ring_0_ 05/27/83 S. Herbst */
  /* Changed to call probe_block_name_ with "0"b (brief form) 08/26/83 S. Herbst */

  dcl (
      P_probe_info_ptr	pointer,
      P_first_level		fixed bin,/* (input) start history at this level */
      P_number_levels	fixed bin,/* number of levels to trace */
      P_all_flag		bit (1) aligned,
				/* indicates to include system routines */
      P_long_flag		bit (1) aligned,
				/* indicates long format (paths, offsets) */
      P_code		fixed bin (35)
      )			parameter;

  dcl frame_reached		bit (1);	/* have we reached the current frame */
  dcl (i, j)		fixed bin;
  dcl block_name		char (256) varying;
  dcl continue_tracing	bit (1) aligned;
  dcl code		fixed bin (35);

  dcl 1 cond_info		aligned like condition_info automatic;

  dcl probe_et_$syntax_error	fixed bin (35) external static;

  dcl find_condition_info_	entry (pointer, pointer, fixed bin (35));
  dcl get_shortest_path_	entry (char (*)) returns (char (168));
  dcl hcs_$fs_get_path_name	entry (ptr, char (*), fixed bin, char (*),
			fixed bin (35));
  dcl ioa_$ioa_switch	entry options (variable);
  dcl ioa_$rsnnl		entry options (variable);

  dcl probe_error_$malfunction
			entry options (variable);
  dcl probe_error_		entry options (variable);
  dcl probe_block_name_	entry (ptr, ptr, bit (1) aligned)
			returns (char (256) varying);
  dcl probe_get_$integer	entry (ptr, fixed bin, fixed bin (35));
  dcl probe_trace_a_stack_	entry (ptr, ptr, bit (1) aligned);

  dcl (addr, bin, fixed, max, min, null, rel)
			builtin;
				/*  */

probe_print_stack_$print_stack_history:
  entry (P_probe_info_ptr, P_first_level, P_number_levels, P_all_flag,
       P_long_flag, P_code);

  probe_info_ptr = P_probe_info_ptr;
  P_code = 0;

  call probe_trace_a_stack_ (probe_info_ptr,
       probe_info.current_stack_frame -> stack_frame.prev_sp,
       P_all_flag);			/* get something to work with */

  j = max (stack_info.max_level - P_first_level + 1, 1);
				/* user sees numbers top down not bottom up */

  lfp = stack_info.level_chain;	/* start out with top frame */
  do while (level_frame.number ^= j);	/* search for starting level */
    lfp = level_frame.next;		/* consider the next frame */
  end;

  continue_tracing = "1"b;		/* curse pl1, which lacks do ... until */
  i = min (stack_info.max_level, j + P_number_levels - 1);
  do while (continue_tracing);

    /* if a condition exists, find out its name */

    if level_frame.condition_frame_ptr = null
      then
	 cond_info.condition_name = "";
      else call find_condition_info_ ((level_frame.condition_frame_ptr),
	      addr (cond_info), code);

    block_name =
         probe_block_name_ (probe_info_ptr, addr (level_frame.source_info),
         "0"b);


    call ioa_$ioa_switch (probe_info.output_switch,
         "^3d^[.^d^;^s^]^14t^a^a^[ (^a)^;^s^]^[^60t^]^a^[ (run unit wall)^]",
         level_frame.printed_number,
         level_frame.printed_decimal ^= 0,
         level_frame.printed_decimal,
         block_name,
         pretty_line (),
         (level_frame.source_info.seg_info_ptr -> seg_info.language_type
         ^= probe_info.language_type),
         palatable_language_names (level_frame.source_info.seg_info_ptr
         -> seg_info.language_type),
         cond_info.condition_name ^= "",
         cond_info.condition_name,
         level_frame.flags.run_unit_manager);

    if level_frame.number >= i
      then continue_tracing = "0"b;	/* stop as soon as the final interesting frame */
      else lfp = level_frame.next;	/* gets reached; otherwise go on to next frame */
  end;
  return;				/* end of code for $print_stack_history entry point */

  /*  */

pretty_line:
  proc () returns (char (300));

  /* *	This procedure returns a pleasantly formatted string describing the
   *	current frame. It is used by print_stack_history.
   *	GLOBAL imports: level_frame */

  dcl map_index		fixed bin;
  dcl 1 map_array		(no_stmnts) based (map_ptr) like statement_map;
  dcl no_stmnts		fixed bin;
  dcl map_ptr		ptr;
  dcl file		fixed bin (8) unsigned;
  dcl line		fixed bin (14) unsigned;
  dcl stmt		fixed bin (5) unsigned;
  dcl dn			char (168);
  dcl en			char (32);
  dcl (retu, long_retu)	char (300);

  no_stmnts = level_frame.source_info.seg_info_ptr -> seg_info.map_size;
  map_ptr =
       level_frame.source_info.seg_info_ptr -> seg_info.statement_map_ptr;
  map_index = level_frame.source_info.stmnt_map_entry_index;

  if map_ptr ^= null () & map_index > 1 & map_index <= no_stmnts
    then do;
      file = fixed (map_array (map_index).file, 8);
      line = fixed (map_array (map_index).line, 14);
      stmt = fixed (map_array (map_index).statement, 5);

      call ioa_$rsnnl ("^x(line^x^[^d-^;^s^]^d^[,^d^;^s^])", retu, (0),
	 (file > 0), file, line, (stmt > 1), stmt);
    end;

  else if ^P_long_flag
    then retu = "";

  else if level_frame.component_text_ptr = null
    then
         call ioa_$rsnnl ("|^o", retu, (0),
	    bin (rel (level_frame.source_info.instruction_ptr), 18));

  else call ioa_$rsnnl ("|^o", retu, (0),
	  bin (rel (level_frame.instruction_ptr), 18)
	  - bin (rel (level_frame.component_text_ptr), 18));

  if P_long_flag then do;
      call hcs_$fs_get_path_name (level_frame.source_info.instruction_ptr, dn,
	 (0), en, code);
      if code ^= 0
        then
	   return (retu);		/* no pathname - might be special hardcore module */

      dn = get_shortest_path_ (dn);

      call ioa_$rsnnl ("^a^x(^a^[>^]^a|^o)", long_retu, (0),
	 retu, dn, dn ^= ">", en,
	 bin (rel (level_frame.source_info.instruction_ptr), 18));
      return (long_retu);
    end;

    else
         return (retu);
  end pretty_line;

  /*  */

  /* *	The rest of this program implements the various requests used to display the stack */

probe_print_stack_$stack_request:
  entry (P_probe_info_ptr);

  /* *	This procedure implements the "stack" request in probe -- it process arguments
   *	and calls probe_print_stack_$print_stack_history. It parses the following syntaxes:
   *
   *	   stack [N[,M] [all]
   *
   *	If both N and M are specified then N is number of first frame and M is number to print
   *	else N is number to print and first frame printed is top one
   *	else all frames are printed.
   *
   *	JRD 2 july 79 */

  probe_info_ptr = P_probe_info_ptr;

  begin;				/* avoid name conflicts */

    dcl start		  fixed bin;
				/* first frame to trace */
    dcl num_frames;			/* number of frames to print */
    dcl (all, long)		  bit (1) aligned;
				/* print system support too? */
    dcl N			  fixed bin;
    dcl M			  fixed bin;
    dcl 1 have,
        (
         2 N,
         2 M,
         2 all,
         2 long,
         2 fault
         )		  bit (1) aligned;

    all, long = "0"b;
    have = "0"b;

    do while (probe_info.ct -> token.type < probe_info.end_token);
				/* look through token chain */
      if probe_info.ct -> token.type = CONSTANT_TYPE then do;
	if have.N
	  then goto SYNTAX_ERROR;
	have.N = "1"b;
	call probe_get_$integer (probe_info_ptr, N, code);

	if code ^= 0
	  then goto SOME_ERROR;
        end;			/* CONSTANT */

      else if probe_info.ct -> token.type = NAME_TYPE then do;
	if current_identifier_name = "all" then do;
	    if have.all
	      then goto SYNTAX_ERROR;
	      else do;
	        have.all = "1"b;
	        all = "1"b;
	        call bump_ct ();
	      end;
	  end;			/* all spec */

	else if current_identifier_name = "long"
	     | current_identifier_name = "lg" then do;
	    if have.long
	      then go to SYNTAX_ERROR;
	      else do;
	        have.long = "1"b;
	        long = "1"b;
	        call bump_ct ();
	      end;
	  end;

	else if current_identifier_name = "fault" then do;
	    goto SYNTAX_ERROR;	/* not presently implemented */
	  end;

	else call probe_error_ (probe_info_ptr, 0,
		"Unrecognized option ""^a"".", current_identifier_name);
        end;			/* of option processing */

      else if probe_info.ct -> token.type = COMMA then do;
	if have.M
	  then goto SYNTAX_ERROR;
	  else do;
	    have.M = "1"b;
	    call bump_ct ();
	    if probe_info.ct -> token.type ^= CONSTANT_TYPE
	      then
		 goto SYNTAX_ERROR;

	    call probe_get_$integer (probe_info_ptr, M, code);
	    if code ^= 0
	      then goto SOME_ERROR;
	  end;			/* getting M */
        end;

      else goto SYNTAX_ERROR;		/* other operator */
    end;				/* token loop */

    num_frames, start = 77313;	/* default, should be fewer frames then this */

    if have.M then do;
        start = N;
        num_frames = M;
      end;

    else if have.N
      then num_frames = N;

    if probe_info.execute
      then
	 call probe_print_stack_$print_stack_history (probe_info_ptr, start,
	      num_frames, all, long, (0));

  end;				/* begin block */

  return;				/* end of code for stack request */


SYNTAX_ERROR:			/* general exit for request syntax error */
  code = probe_et_$syntax_error;
  goto SOME_ERROR;


SOME_ERROR:
  call probe_error_ (probe_info_ptr, code);
				/* never returns */

  /*  */

  /* *	Assorted request support routines, extracted from probe_requests_ */

bump_ct:
  proc ();

  probe_info.ct = probe_info.ct -> token.next;
  if probe_info.ct = null ()
    then goto SYNTAX_ERROR;

  return;
  end;				/* internal procedure bump_ct */

  /*  */

  /*	INCLUDE FILES	*/

%include probe_info;

  /* ;;;;;;; */

%include probe_static_info;

  /* ;;;;;;; */

%include probe_source_info;

  /* ;;;;;;; */

%include probe_seg_info;

  /* ;;;;;;; */

%include probe_level_frame;

  /* ;;;;;;; */

%include probe_tokens;

  /* ;;;;;;; */

%include probe_operators;

  /* ;;;;;;; */

%include stack_frame;

  /*  */

%include condition_info;

  /* ;;;;;;; */

%include probe_lang_types;

  /* ;;;;;;; */

%include statement_map;

  end;				/* probe_stack_trace_ external procedure */




		    probe_request_mgr_.pl1          10/27/88  1250.2r w 10/27/88  1224.6       90126



/****^  ***********************************************************
        *                                                         *
        * 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_request_mgr_:
  proc ();

  return;				/* dummy entry */

  /* *	This procedure implements the finding of requests and builtins for the
   *	new probe. It also contains entries for printing portions of the,
   *	for the "?" request. */

  /*	Created: 04/09/79 W. Olin Sibert, stolen bodily from subsystem_request_mgr_
   Modified JRD 11 Aug 79 to not include builtins in the request list
*/

  dcl (
      P_probe_info_ptr	pointer,
      P_request_name	char (*), /* name of request to find */
      P_request_entry	entry variable options (variable),
				/* (Output) entry variable for request */
      P_request_info_ptr	pointer,	/* (Output) pointer to information about the request */
      P_code		fixed binary (35)
      )			parameter;

  dcl request_name		character (32);

  dcl request_table_array_ptr pointer;
  dcl request_table_array_size
			fixed bin;
  dcl request_table_ptrs	(request_table_array_size) pointer
			based (request_table_array_ptr);

  dcl request_idx		fixed bin;/* this and request_table_ptr are output from locate_reqest */

  dcl entry_variable	entry variable options (variable);
				/* for building up return value */

  dcl 1 entry_variable_overlay
			aligned based (addr (entry_variable)),
       2 codeptr		pointer,
       2 environmentptr	pointer;

  dcl (idx, jdx, kdx)	fixed bin;
  dcl name_size		fixed bin;
  dcl type_wanted		fixed bin;

  dcl ioa_		entry options (variable);
  dcl ioa_$nnl		entry options (variable);

  dcl probe_error_$record	entry options (variable);

  dcl (
      probe_et_$invalid_request,
      probe_et_$unknown_request,
      probe_et_$unimplemented_request,
      probe_et_$recorded_message
      )			fixed bin (35) external static;

  dcl WHITESPACE		char (2) internal static options (constant)
			init ("	");
				/* SP HT */
  dcl (
      WANT_ANYTHING		init (1),
      WANT_REQUEST		init (2),
      WANT_BUILTIN		init (3)
      )			fixed bin internal static options (constant);

  dcl (addr, length, ltrim, max, null, pointer, rtrim, verify)
			builtin;
				/*  */

  /* *	This entry searches a request table for the named request and returns
   *	the entry variable which is that request's processor. */

find_request:
  entry (P_probe_info_ptr, P_request_name, P_request_entry,
       P_request_info_ptr, P_code);


  type_wanted = WANT_REQUEST;
  goto FIND_COMMON;


find_builtin:
  entry (P_probe_info_ptr, P_request_name, P_request_entry,
       P_request_info_ptr, P_code);

  type_wanted = WANT_BUILTIN;
  goto FIND_COMMON;


FIND_COMMON:
  probe_info_ptr = P_probe_info_ptr;

  request_table_array_ptr = probe_static_info.request_table_info.array_ptr;
  request_table_array_size = probe_static_info.request_table_info.array_size;

  entry_variable_overlay.codeptr = null ();
  entry_variable_overlay.environmentptr = null ();

  P_request_entry = entry_variable;	/* null to start with */

  if length (ltrim (rtrim (P_request_name, WHITESPACE), WHITESPACE)) <= 32
    then
         request_name =
	    ltrim (rtrim (P_request_name, WHITESPACE), WHITESPACE);

    else do;
      call probe_error_$record (probe_info_ptr, probe_et_$invalid_request,
	 """^a""", P_request_name);
      goto RECORDED_MESSAGE;
    end;

  if verify (request_name, WHITESPACE) = 0 then do;
      call probe_error_$record (probe_info_ptr, probe_et_$invalid_request);
      goto RECORDED_MESSAGE;
    end;

  call locate_request ();

  if request_idx = -1 then do;	/* we lost */
      call probe_error_$record (probe_info_ptr, probe_et_$unknown_request,
	 """^a""", P_request_name);
      goto RECORDED_MESSAGE;
    end;

  /* otherwise, fall through to here if successful */
  entry_variable_overlay.codeptr = pointer (probe_request_table_ptr,
       probe_request_table.requests (request_idx).code_loc);

  P_request_entry = entry_variable;
  P_request_info_ptr = addr (probe_request_table.requests (request_idx));

  if probe_request_table.requests (request_idx).unimplemented then do;
      call probe_error_$record (probe_info_ptr,
	 probe_et_$unimplemented_request, """^a""", P_request_name);
      goto RECORDED_MESSAGE;
    end;

    else P_code = 0;

MAIN_RETURN:
  return;				/* end of code for $find_request and $find_builtin */


RECORDED_MESSAGE:
  P_code = probe_et_$recorded_message;
  goto MAIN_RETURN;

  /*  */

  /* *	This entry prints a summary of the requests defined in a given request
   *	table.  The summary includes each reques's name, abbreviation(s), and
   *	brief description as found in the table. */

probe_request_mgr_$list_requests:
  entry (P_probe_info_ptr);

  /* *	This entrypoint lists all the requests currently known by probe. */

  call list_common (WANT_REQUEST);
  return;


probe_request_mgr_$list_builtins:
  entry (P_probe_info_ptr);

  /* This entrypoint lists all the builtins currently implemented */
  call list_common (WANT_BUILTIN);
  return;


list_common:
  proc (typew);

  dcl typew		fixed bin parameter;

  probe_info_ptr = P_probe_info_ptr;

  request_table_array_ptr = probe_static_info.request_table_info.array_ptr;
  request_table_array_size = probe_static_info.request_table_info.array_size;

  /*	Make an initial loop through the tables to determine the size of longest name
   for sake of pretty printout and conservation of horizontal space (and thus time) */

  name_size = 0;

  do idx = 1 to request_table_array_size;
				/* for each request table */
    probe_request_table_ptr = request_table_ptrs (idx);

    do jdx = 1 to probe_request_table.n_requests;
				/* for each request/builtin therein */

      if interesting (probe_request_table.requests (jdx)) then do;
	request_namelist_ptr = pointer (probe_request_table_ptr,
	     probe_request_table.requests (jdx).namelist_loc);

	if request_namelist.n_names = 2
	  then
	       name_size = max (name_size,
		  length (rtrim (request_namelist.names (1)))
		  + length (rtrim (request_namelist.names (2))) + 2);

	  else name_size =
		  max (name_size,
		  length (rtrim (request_namelist.names (1))));
        end;
    end;
  end;

  /*	Print the summary */

  do idx = 1 to request_table_array_size;
    probe_request_table_ptr = request_table_ptrs (idx);

    do jdx = 1 to probe_request_table.n_requests;

      if interesting (probe_request_table.requests (jdx)) then do;
	request_namelist_ptr = pointer (probe_request_table_ptr,
	     probe_request_table.requests (jdx).namelist_loc);

	if request_namelist.n_names = 2
	  then
	       call ioa_$nnl ("^va^2x", name_size,
		  rtrim (request_namelist.names (1)) || ", "
		  || request_namelist.names (2));

	  else call ioa_$nnl ("^va^2x", name_size,
		  request_namelist.names (1));

	request_info_string_ptr = pointer (probe_request_table_ptr,
	     probe_request_table.requests (jdx).info_string.loc);
	request_info_string_lth =
	     probe_request_table.requests (jdx).info_string.lth;

	call ioa_ (request_info_string);

	if request_namelist.n_names > 2 then do;
				/* print additional abbreviations */
	    call ioa_$nnl ("^3x(");
	    do kdx = 2 to request_namelist.n_names;
	      call ioa_$nnl ("^a^[, ^;)^/^]",
		 request_namelist.names (kdx),
		 (kdx ^= request_namelist.n_names));
	    end;
	  end;
        end;
    end;
  end;
  return;

interesting:
  proc (rinfo) returns (bit (1) aligned);
  dcl 1 rinfo		aligned like probe_request_info parameter;

  return (
       (typew = WANT_REQUEST & rinfo.flags.is_request)
       | (typew = WANT_BUILTIN & rinfo.flags.is_builtin) &
       (rinfo.info_string.lth ^= 0) &
       ^rinfo.unimplemented &
       ^rinfo.secret);
  end interesting;

  end list_common;

  /*  */

locate_request:
  proc ();

  /* *	This procedure sets request_idx to the index of the desired request in the table,
   *	or to -1 if no satisfactory match is found */

  do idx = 1 to request_table_array_size;
    probe_request_table_ptr = request_table_ptrs (idx);

    do jdx = 1 to probe_request_table.n_requests;

      if (probe_request_table.is_request (jdx) & type_wanted = WANT_REQUEST)
	 | (probe_request_table.is_builtin (jdx)
	 & type_wanted = WANT_BUILTIN)
	 | (type_wanted = WANT_ANYTHING) then do;

	request_namelist_ptr =
	     pointer (probe_request_table_ptr,
	     probe_request_table.requests (jdx).namelist_loc);
	do kdx = 1 to request_namelist.n_names;
	  if request_name = request_namelist.names (kdx) then do;
	      request_idx = jdx;
	      return;		/* successful */
	    end;
	end;
        end;
    end;				/* of loop through request table */
  end;

  request_idx = -1;			/* failed to find it */
  probe_request_table_ptr = null ();
  return;				/* return, anyway */
  end;				/* locate_request internal procedure */

  /*  */

%include probe_info;

  /* ;;;;;;; */

%include probe_static_info;

  /* ;;;;;;; */

%include probe_request_table;
  end;				/* probe_request_mgr_ external procedure */




		    probe_request_table_.alm        10/24/88  1622.8rew 10/24/88  1343.5       70884



" ***********************************************************
" *                                                         *
" * 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,MCR7952),
"     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
"     Modified for C-Probe support.
"                                                      END HISTORY COMMENTS


"
"	Standard request table for new probe
"
"	Created:	04/09/79 W. Olin Sibert
"	Modified: 10 Sept 79 by JRD
"	Modified:  5 Feb 80  by JRD add declare and list_variables
"	Added input_description and output_description 10/01/81 S. Herbst
"	Added object request 11/10/81 S. Herbst
"	Added enable request (undocumented), used when debugging probe itself 08/15/83 S. Herbst
"	Modified June 83 JMAthane to add PASCAL builtins
"

	include	probe_request_macros

	begin_table	probe_request_table_

"
"
"
"	P R O B E    R E Q U E S T S
"

	request	after,(a),probe_requests_$after_request,
		(Set a breakpoint after the specified statement.)

	request	arguments,(args),probe_requests_$args_request,
		(Print argument list for procedure.)

	request	before,(b),probe_requests_$before_request,
		(Set a breakpoint before the specified statement.)

	request	call,(cl),probe_expr_requests_$call_request,
		(Call a subroutine.)

	request	continue,(c),probe_ctl_requests_$continue_request,
		(Continue after a breakpoint.)

	request	continue_to,(ct),probe_ctl_requests_$continue_to_request,
		(Resume execution from last breakpoint and stop at specified statement.)

	request   declare,(dcl),probe_vars_requests_$declare_request,
		(Create a probe variable.)

	request	display,(ds),probe_display_request_$probe_display_request_,
		(Display storage in various formats.)

	request	enable,(),probe_requests_$enable_request,
		(For debugging probe itself; resets recursive-break flag.)

	request	execute,(e),probe_requests_$execute_request,
		(Execute a Multics command line, usually within a break request.)

	request	goto,(g),probe_ctl_requests_$goto_request,
		(Continue execution at a specified statement.)

	request	go,(),probe_ctl_requests_$goto_request,
		(Synonym for goto.)

	request	halt,(h),probe_ctl_requests_$halt_request,
		(Halt and re-enter probe.)

	request	help,(),probe_info_requests_$help_request,
		(Print info files for probe requests.)

	request	handlers,(),probe_requests_$handlers_request,
		(List handlers set up for specified stack frame.)

	request	if,(),probe_expr_requests_$if_request,
		(Execute probe requests based on specified condition.)

	request	input_description,(ids),probe_requests_$input_description_request,
		(Set the input I/O switch from an attach description.)

	request	input_switch,(isw),probe_requests_$input_switch_request,
		(Set the I/O switch used for probe input.)

	request	language,(lng),probe_language_request_$probe_language_request_,
		(Display or set the current language.)

	request	let,(l),probe_expr_requests_$let_request,
		(Change the value of a variable.)

	request	list_help,(lh),probe_info_requests_$list_help_request,
		(List the available info topics for probe.)

	request	list_builtins,(lb),probe_info_requests_$print_builtin_summary,
		(Print a  summary listing of all probe builtins.)

	request	list_requests,(lr),probe_info_requests_$print_request_summary,
		(Print a summary listing of the probe requests.)

	request	list_variables,(lsv),probe_vars_requests_$list_variables_request,
		(Print type and value of one or more probe variables.)

	request	modes,(mode),probe_modes_mgr_$mode_request,
		(Set probe operation modes.)

	request	object,(obj),probe_requests_$object_request,
		(Print instructions for one or more statements.)

	request	output_description,(ods),probe_requests_$output_description_request,
		(Set the output I/O switch from an attach description.)

	request	output_switch,(osw),probe_requests_$output_switch_request,
		(Set the I/O switch used for probe output.)

	request	pause,(p),probe_ctl_requests_$pause_request,
		(Reset the current breakpoint and halt.)

	request	position,(ps),probe_requests_$position_request,
		(Move the probe pointer to a new location and display the source.)

	request	quit,(q),probe_ctl_requests_$quit_request,
		(Leave probe and return to Multics command level.)

	request	reset,(r),probe_requests_$reset_request,
		(Reset breakpoints.)

	request	source,(sc),probe_requests_$source_request,
		(Display source of program.)

	request	stack,(sk),probe_print_stack_$stack_request,
		(Display the stack.)

	request	status,(st),probe_requests_$status_request,
		(Display the status of breakpoints.)

	request	step,(s),probe_ctl_requests_$step_request,
		(Execute one statement and halt.)

	request	symbol,(sb),probe_expr_requests_$symbol_request,
		(Display information about the specified symbol.)

	request	use,(),probe_requests_$use_request,
		(Move the probe pointer to a new location.)

	request	value,(v),probe_expr_requests_$value_request,
		(Print the value of a variable or expression.)

	request	where,(wh),probe_requests_$where_request,
		(Display the current values of the probe pointers.)

	request	while,(wl),probe_expr_requests_$while_request,
		(Execute probe requests while condition is true.)


"
"
"
"	B U I L T I N     F U N C T I O N S
"

	builtin	addr,(address,$addr,$address),probe_builtins_$addr_builtin,
		(PL/1 'addr' builtin function)

	builtin	addrel,($addrel),probe_builtins_$addrel_builtin,
		(PL/1 'addrel' builtin function)

	builtin	baseptr,($baseptr),probe_builtins_$baseptr_builtin,
		(PL/1 'baseptr' builtin)

"	builtin	currentsize,($currentsize),probe_builtins_$currentsize_builtin,
"		(PL/1 'currentsize' builtin function)

	builtin	length,($length),probe_builtins_$length_builtin,
		(PL/1 'length' builtin function)

	builtin	maxlength,($maxlength),probe_builtins_$maxlength_builtin,
		(PL/1 'maxlength' builtin function)

	builtin	null,($null),probe_builtins_$null_builtin,
		(PL/1 'null' builtin function)

	builtin	octal,($octal),probe_builtins_$octal_builtin,
		(Close equivalent of PL/1 'unspec' builtin function)

	builtin	pointer,($pointer,ptr,$ptr),probe_builtins_$ptr_builtin,
		(Close relative of PL/1 'pointer' builtin)

	builtin	rel,($rel),probe_builtins_$rel_builtin,
		(PL/1 'rel' builtin)

	builtin	segno,($segno),probe_builtins_$segno_builtin,
		(PL/1 'segno' builtin)

"	builtin	size,($size),probe_bultins_$size_builtin,
"		(PL/1 'size' builtin function)

	builtin	substr,($substr),probe_builtins_$substr_builtin,
		(PL/1 'substr' builtin function)

	builtin	unspec,($unspec),probe_builtins_$unspec_builtin,
		(PL/1 'unspec' builtin)

	builtin	true,($true),probe_builtins_$pascal_true_builtin,
		(PASCAL 'true' predefined constant)

	builtin	false,($false),probe_builtins_$pascal_false_builtin,
		(PASCAL 'false' predefined constant)

	builtin	nil,($nil),probe_builtins_$pascal_nil_builtin,
		(PASCAL 'nil' predefined constant)

	builtin	ord,($ord),probe_builtins_$pascal_ord_builtin,
		(PASCAL 'ord' predefined function)

	builtin	chr,($chr),probe_builtins_$pascal_chr_builtin,
		(PASCAL 'chr' predefined function)

	builtin	eof,($eof),probe_builtins_$pascal_eof_builtin,
		(PASCAL 'eof' predefined function)

	builtin	eoln,($eoln),probe_builtins_$pascal_eoln_builtin,
		(PASCAL 'eoln' predefined function)

	builtin	sizeof,($sizeof),probe_builtins_$sizeof_builtin,
		(C 'sizeof' builtin function)

	end_table 	probe_request_table_

	end




		    probe_requests_.pl1             11/11/88  1555.4r w 11/11/88  1545.0      440334



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

/****^  HISTORY COMMENTS:
  1) change(87-06-18,RWaters), approve(87-06-18,MCR7687), audit(87-06-24,Huen),
     install(87-07-15,MR12.1-1040):
     Probe error #108: allow the object command to work w/o source code.
  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_requests_:
  proc ();

  call probe_error_$malfunction ();	/* dummy entry */

  /* THE PROBE REQUESTS WE CONTAIN ARE:

   after,
   args,
   before,
   enable,
   execute,
   handlers,
   input_description,
   input_switch,
   object,
   output_description,
   output_switch,
   position/use,
   reset,
   source,
   status,
   where


   Modified 16 Sept 79 JRDavis for version 4 break_mgr_ syntax
   Modified 09/20/80 WOS, to make args request work in breakpoint request list. (bug 198) */
  /* Make input_switch & output_switch static (per-process) 09/30/81 S. Herbst */
  /* Add input_description and output_description requetsts 10/01/81 S. Herbst */
  /* Add arguments LEVEL_N and PROC_NAME to args request 10/02/81 S. Herbst */
  /* Add "ps line +N", "ps level +N", and "b STRING" syntax 10/09/81 S. Herbst */
  /* Added object request 11/10/81 S. Herbst */
  /* Fixed for "ps N.M" and "args N.M" (support frames) 12/19/81 S. Herbst */
  /* Fixed object request to not show break instructions 09/15/82 S. Herbst */
  /* Fixed "handlers" to test for null source_info.stack_ptr 10/27/82 S. Herbst */
  /* Added "enable" request (undocumented) for use when debugging probe itself 08/15/83 S. Herbst */
  /* Changed to call probe_block_name_ with "0"b (brief form) 08/26/83 S. Herbst */
  /* Fixed "sc path" to set seg_info.(directory entry)_name 10/11/83 S. Herbst */
  /* Changed position to allow "ps lines +N" and "ps +N line(s)" same as "ps line +N" 02/09/84 S. Herbst */
  /* Fixed (input output)_description to use un-parsed attach description 03/30/84 S. Herbst */
  /* Fixed "ps" (no args) to fill in source_info.instruction_ptr if null 08/02/84 S. Herbst */
  /* Fixed "sc path" to not set seg_info.(directory_name entry_name);these refer to the object 11/07/84 S. Herbst */
  /* Added "wh object", "wh object path", "wh source path" 11/07/84 S. Herbst */
  /* Added synonym "wh obj" for "wh object" 01/03/85 Steve Herbst */
  /* Fixed "wh control" to print stack level as "wh source" does 01/31/85 Steve Herbst */
  /* Changed to allow "object" to work without a source file 05/21/87 RWaters */


  dcl P_probe_info_ptr	pointer parameter;

  dcl (
      PRIVATE		init ("1"b),
      NOT_PRIVATE		init ("0"b)
      )			bit (1) aligned int static options (constant);
  dcl (
      STREAM_INPUT		init (1),
      STREAM_OUTPUT		init (2)
      )			fixed bin int static options (constant);

  dcl NL			char (1) int static options (constant) init ("
");

  dcl code		fixed bin (35);

  dcl 1 new_source_info	aligned like source_info;
  dcl source_ptr		ptr;
  dcl level_string		char (32) varying;
  dcl (frame_number, frame_decimal, level)
			fixed bin;

  dcl 1 map_array		(map_size) aligned based (stmt_map_ptr)
			like statement_map;
  dcl map_size		fixed bin (21);
  dcl stmt_map_ptr		ptr;

  dcl constant_string	char (probe_info.ct -> constant.precision)
			based (probe_info.ct -> constant.data_ptr);
  dcl pathname		char (256) varying;
  dcl attach_description	char (256) varying;

  dcl (
      probe_et_$e_syntax_err,
      probe_et_$bad_ctl_arg,
      probe_et_$bad_line,
      probe_et_$no_statement_map,
      probe_et_$noarg,
      probe_et_$none_active,
      probe_et_$syntax_error,
      probe_et_$too_many_args,
      probe_et_$unimplemented_request
      )			fixed bin (35) external static;

  dcl probe_break_mgr_$print_instructions
			entry (ptr, ptr, ptr, fixed bin);
  dcl probe_error_$malfunction
			entry options (variable);
  dcl probe_error_$warning	entry options (variable);
  dcl error_table_$noentry	fixed bin (35) ext static;
  dcl probe_get_$decimal	entry (ptr, fixed bin, fixed bin,
			fixed bin (35));
  dcl probe_get_$integer	entry (ptr, fixed bin, fixed bin (35));
  dcl probe_get_$line	entry (ptr, ptr, fixed bin, bit (36) aligned,
			fixed bin, fixed bin (35));
  dcl probe_get_$pathname	entry (ptr, char (*) varying, fixed bin (35));
  dcl probe_get_$object	entry (ptr, ptr, fixed bin (35));
  dcl probe_get_$request_list entry (ptr, ptr, fixed bin (21), fixed bin (35))
			;
  dcl probe_block_name_	entry (ptr, ptr, bit (1) aligned)
			returns (char (256) varying);
  dcl probe_error_		entry options (variable);
  dcl probe_line_number_	entry (ptr, 1 aligned like source_info)
			returns (char (64));
  dcl probe_pretty_source_info_
			entry (ptr, ptr, char (*));
  dcl probe_source_segment_$get_file_ptr
			entry (ptr, ptr, fixed bin) returns (ptr);
  dcl probe_source_segment_$list_statement
			entry (ptr, ptr, fixed bin, fixed bin (35));
  dcl probe_stack_trace_$where_source_info
			entry (ptr, ptr, fixed bin, char (*));
  dcl probe_trace_a_stack_	entry (ptr, ptr, bit (1) aligned);

  dcl cv_dec_		entry (char (*)) returns (fixed bin);
  dcl hcs_$fs_get_path_name	entry (ptr, char (*), fixed bin, char (*),
			fixed bin (35));
  dcl ioa_$ioa_switch	entry options (variable);
  dcl ioa_$rsnnl		entry options (variable);
  dcl iox_$attach_name	entry (char (*), ptr, char (*), ptr,
			fixed bin (35));
  dcl iox_$close		entry (ptr, fixed bin (35));
  dcl iox_$destroy_iocb	entry (ptr, fixed bin (35));
  dcl iox_$detach_iocb	entry (ptr, fixed bin (35));
  dcl iox_$open		entry (ptr, fixed bin, bit (1) aligned,
			fixed bin (35));
  dcl pathname_		entry (char (*), char (*)) returns (char (168));
  dcl unique_chars_		entry (bit (*)) returns (char (15));

  dcl (addr, binary, fixed, length, min, null, pointer, rel, rtrim, substr)
			builtin;
SYNTAX_ERROR:			/* general-purpose error exit */
  code = probe_et_$syntax_error;

  call probe_error_ (probe_info_ptr, code, probe_info.request_name);
  goto MAIN_RETURN;


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

%page;
  dcl probe_get_$io_switch	entry (ptr, ptr, fixed bin (35));
  dcl (
      iox_$user_input,
      iox_$user_output,
      iox_$error_output,
      iox_$user_io
      )			ptr external;

  dcl iocb_ptr		pointer;

input_switch_request:
  entry (P_probe_info_ptr);

  /* *	This request sets the IOCB pointer from which probe does input */


  probe_info_ptr = P_probe_info_ptr;

  if ^probe_info.execute
    then goto MAIN_RETURN;

  if probe_info.ct -> token.type < probe_info.end_token then do;
				/* an argument was supplied */
      call probe_get_$io_switch (probe_info_ptr, iocb_ptr, code);
      if code ^= 0
        then goto SOME_ERROR;
      call reject_argument ();	/* too many arguments */
      if iocb_ptr ^= null ()
        then
	   call set_iocb (probe_static_info.input_switch,
	        probe_static_info.private_input_sw,
	        iocb_ptr, NOT_PRIVATE);
    end;

    else call set_iocb (probe_static_info.input_switch,
	    probe_static_info.private_input_sw,
	    iox_$user_input, NOT_PRIVATE);
				/* default value */

  probe_info.input_switch = probe_static_info.input_switch;

  goto MAIN_RETURN;




output_switch_request:
  entry (P_probe_info_ptr);

  /* *	This request sets the IOCB pointer to which probe does output */


  probe_info_ptr = P_probe_info_ptr;

  if ^probe_info.execute
    then goto MAIN_RETURN;

  if probe_info.ct -> token.type < probe_info.end_token then do;
				/* an argument was supplied */
      call probe_get_$io_switch (probe_info_ptr, iocb_ptr, code);
      if code ^= 0
        then goto SOME_ERROR;
      call reject_argument ();	/* too many arguments */
      if iocb_ptr ^= null ()
        then
	   call set_iocb (probe_static_info.output_switch,
	        probe_static_info.private_output_sw,
	        iocb_ptr, NOT_PRIVATE);
    end;
    else call set_iocb (probe_static_info.output_switch,
	    probe_static_info.private_output_sw,
	    iox_$user_output, NOT_PRIVATE);
				/* default value */

  probe_info.output_switch = probe_static_info.output_switch;

  goto MAIN_RETURN;
%page;
input_description_request:
  entry (P_probe_info_ptr);

  /* This request creates a new IOCB from an attach description and sets the switch for reading input */

  probe_info_ptr = P_probe_info_ptr;

  if ^probe_info.execute
    then goto MAIN_RETURN;

  if probe_info.ct -> token.type >= probe_info.end_token
    then
         call probe_error_ (probe_info_ptr, 0,
	    "Usage: input_description attach_description");

  call rest_of_request (attach_description);

  call iox_$attach_name ("probe_input." || unique_chars_ ("0"b), iocb_ptr,
       (attach_description), null, code);
  if code ^= 0
    then call probe_error_ (probe_info_ptr, code, "^a", attach_description);
  call iox_$open (iocb_ptr, STREAM_INPUT, "0"b, code);
  if code ^= 0 then do;
      call iox_$detach_iocb (iocb_ptr, (0));
      call probe_error_ (probe_info_ptr, code,
	 "Unable to open switch for reading.");
    end;

  call set_iocb (probe_static_info.input_switch,
       probe_static_info.private_input_sw,
       iocb_ptr, PRIVATE);

  probe_info.input_switch = probe_static_info.input_switch;

  go to MAIN_RETURN;

output_description_request:
  entry (P_probe_info_ptr);

  /* Creates an IOCB from an attach description and sets the switch for printing output */

  probe_info_ptr = P_probe_info_ptr;

  if ^probe_info.execute
    then goto MAIN_RETURN;

  if probe_info.ct -> token.type >= probe_info.end_token
    then
         call probe_error_ (probe_info_ptr, (0),
	    "Usage: output_description attach_description");

  call rest_of_request (attach_description);

  call iox_$attach_name ("probe_output." || unique_chars_ ("0"b), iocb_ptr,
       (attach_description), null, code);
  if code ^= 0
    then call probe_error_ (probe_info_ptr, code, "^a", attach_description);
  call iox_$open (iocb_ptr, STREAM_OUTPUT, "0"b, code);
  if code ^= 0 then do;
      call iox_$detach_iocb (iocb_ptr, (0));
      call probe_error_ (probe_info_ptr, code,
	 "Unable to open switch for writing.");
    end;

  call set_iocb (probe_static_info.output_switch,
       probe_static_info.private_output_sw,
       iocb_ptr, PRIVATE);

  probe_info.output_switch = probe_static_info.output_switch;

  go to MAIN_RETURN;
%page;
args_request:
  entry (P_probe_info_ptr);

  dcl block_name		char (256) varying;
  dcl probe_print_arglist_	entry (ptr, ptr);

  probe_info_ptr = P_probe_info_ptr;

  if probe_info.execute then do;
      if probe_info.ct -> token.type >= probe_info.end_token
        then source_ptr = probe_info.ptr_to_current_source;

        else do;
	call probe_trace_a_stack_
	     (probe_info_ptr,
	     probe_info.current_stack_frame -> stack_frame.prev_sp, "1"b);

	lfp = stack_info.level_chain;
	if probe_info.ct -> token.type = CONSTANT_TYPE then do;
				/* args for frame number N */
	    if probe_info.ct -> constant.scale ^= 0
	      then
		 call probe_get_$decimal (probe_info_ptr, frame_number,
		      frame_decimal, code);
	      else do;
	        call probe_get_$integer (probe_info_ptr, frame_number, code)
		   ;
	        frame_decimal = 0;
	      end;
	    if code ^= 0
	      then call probe_error_ (probe_info_ptr, code);
	    if frame_number > stack_info.max_level | frame_number = 0
	      then
NO_FRAME:
	        call probe_error_ (probe_info_ptr, 0,
		   "No frame number ^d^[.^d^]",
		   frame_number, frame_decimal ^= 0, frame_decimal);

	    do while (level_frame.printed_number ^= frame_number |
	         level_frame.printed_decimal ^= frame_decimal);
	      lfp = level_frame.next;
	      if lfp = null
	        then go to NO_FRAME;
	    end;
	    source_ptr = addr (level_frame.source_info);
	  end;
	else if probe_info.ct -> token.type = NAME_TYPE then do;
	    source_ptr = null;
	    do while (source_ptr = null);

	      block_name =
		 probe_block_name_ (probe_info_ptr,
		 addr (level_frame.source_info), "0"b);

	      if block_name = current_identifier_name
	        then
		   source_ptr = addr (level_frame.source_info);
	      else if level_frame.next = null
	        then call probe_error_
		        (probe_info_ptr, 0, "No frame for ^a",
		        current_identifier_name);
	      else lfp = level_frame.next;
	    end;
	  end;

	else go to SYNTAX_ERROR;
        end;

      call probe_print_arglist_ (probe_info_ptr, source_ptr);
    end;
  goto MAIN_RETURN;
%page;
handlers_request:
  entry (P_probe_info_ptr);

  dcl probe_print_handlers_	entry (ptr, ptr);
  dcl token_type		bit (18);
  dcl token_name		char (168);

  probe_info_ptr = P_probe_info_ptr;

  if probe_info.execute then do;

      token_type = probe_info.ct -> token.type;
      if token_type = NAME_TYPE
        then token_name = current_identifier_name;

      if probe_info.ct -> token.type >= probe_info.end_token then do;
	source_ptr = probe_info.ptr_to_current_source;
	if source_ptr -> source_info.stack_ptr = null then do;
	    token_type = NAME_TYPE;
	    token_name =
	         source_ptr -> source_info.seg_info_ptr
	         -> seg_info.entry_name;
	    go to FIND_FRAME;
	  end;
        end;

        else do;
FIND_FRAME:
	call probe_trace_a_stack_
	     (probe_info_ptr,
	     probe_info.current_stack_frame -> stack_frame.prev_sp, "0"b);

	lfp = stack_info.level_chain;
	if token_type = CONSTANT_TYPE then do;
				/* args for frame number N */
	    call probe_get_$integer (probe_info_ptr, frame_number, code);
	    if code ^= 0
	      then call probe_error_ (probe_info_ptr, code);
	    if frame_number > stack_info.max_level | frame_number = 0
	      then
		 call probe_error_ (probe_info_ptr, 0,
		      "No frame number ^d", frame_number);

	    do while (level_frame.printed_number ^= frame_number
	         | level_frame.printed_decimal ^= 0);
	      lfp = level_frame.next;
	    end;
	    source_ptr = addr (level_frame.source_info);
	  end;
	else if token_type = NAME_TYPE then do;
	    source_ptr = null;
	    do while (source_ptr = null);

	      block_name =
		 probe_block_name_ (probe_info_ptr,
		 addr (level_frame.source_info), "0"b);

	      if block_name = token_name
	        then
		   source_ptr = addr (level_frame.source_info);
	      else if level_frame.next = null
	        then call probe_error_
		        (probe_info_ptr, 0, "No frame for ^a",
		        current_identifier_name);
	      else lfp = level_frame.next;
	    end;
	  end;

	else go to SYNTAX_ERROR;
        end;

      call probe_print_handlers_ (probe_info_ptr, source_ptr);
    end;
  goto MAIN_RETURN;
%page;
execute_request:
  entry (P_probe_info_ptr);

  /* *	This is used to execute Multics commands from within probe, primarily
   *	within probe breakpoints. Its syntax is considerably more restrictive
   *	than necessary, and this will be fixed someday soon */

  dcl command_line_lth	fixed bin (21);
  dcl cu_$cp		entry (pointer, fixed bin (21), fixed bin (35));

  dcl command_line_ptr	pointer;


  probe_info_ptr = P_probe_info_ptr;

  call require_argument ();

  if probe_info.ct -> token.type ^= CONSTANT_TYPE
    then
         call probe_error_ (probe_info_ptr, probe_et_$e_syntax_err);

  if probe_info.ct -> constant.data_type ^= char_dtype * 2
    then
         call probe_error_ (probe_info_ptr, probe_et_$e_syntax_err);

  command_line_ptr = probe_info.ct -> constant.data_ptr;
  command_line_lth = probe_info.ct -> constant.scale_and_precision;

  call bump_ct ();			/* get the next token */
  call reject_argument ();		/* only one string at a time */

  if probe_info.execute
    then /* give it to Multics */
         call cu_$cp (command_line_ptr, command_line_lth, (0));

  goto MAIN_RETURN;			/* end of code for execute request */

%page;

source_request:
  entry (P_probe_info_ptr);

  /* *	The source request prints source lines from the program, and can
   *	also be used to specify a pathname to look for the source. */

  dcl number_to_print	fixed bin;
  dcl source_dname		char (168);
  dcl source_ename		char (32);
  dcl source_seg_ptr	pointer;
  dcl expand_pathname_	entry (char (*), char (*), char (*),
			fixed bin (35));
  dcl hcs_$initiate		entry (char (*), char (*), char (*),
			fixed bin (1), fixed bin (2), pointer,
			fixed bin (35));


  probe_info_ptr = P_probe_info_ptr;

  if probe_info.ct -> token.type ^= NAME_TYPE then do;
      if probe_info.ct -> token.type >= probe_info.end_token
        then /* nothing specified, print one line */
	   number_to_print = 1;

      else if probe_info.ct -> token.type = CONSTANT_TYPE then do;
				/* print N lines */
	call probe_get_$integer (probe_info_ptr, number_to_print, code);
	if code ^= 0
	  then goto SOME_ERROR;
	call reject_argument ();	/* can have at most one number */
	if number_to_print < 0
	  then /* and can only print a positive number */
	       call probe_error_ (probe_info_ptr, 0,
		  "Number of source lines to print must be positive.");
        end;

      else goto SYNTAX_ERROR;		/* wrong kind of token here */

      if probe_info.execute then do;	/* do it, if we're supposed to */
	call probe_source_segment_$list_statement
	     (probe_info_ptr, addr (current_source), number_to_print, code);
	if code ^= 0
	  then goto SOME_ERROR;
        end;
    end;

    else do;			/* otherwise, hope it's "source path" */
      if current_identifier_name ^= "path"
        then goto SYNTAX_ERROR;
      call bump_ct ();
      call require_argument ();

      call probe_get_$pathname (probe_info_ptr, pathname, code);
      if code ^= 0
        then goto SOME_ERROR;

      call reject_argument ();	/* can't have anything following the pathname */

      call expand_pathname_ ((pathname), source_dname, source_ename, code);
      if code ^= 0
        then call probe_error_ (probe_info_ptr, code, "^a", pathname);

      call hcs_$initiate (source_dname, source_ename, "", 0, 0,
	 source_seg_ptr, code);
      if source_seg_ptr = null ()
        then
	   call probe_error_ (probe_info_ptr, code, "^a>^a", source_dname,
	        source_ename);

      if probe_info.execute
        then /* set the pointer in seg_info so we'll remember later */
	   current_source.seg_info_ptr -> seg_info.file_pointers (1) =
	        source_seg_ptr;

    end;				/* of code for "source path" */
  goto MAIN_RETURN;			/* end of code for source request */

%page;
object_request:
  entry (P_probe_info_ptr);


  /* Say "object {N}" to print N or 1 stmt's worth of object code. */

  dcl seg_info_ptr		ptr;
  dcl start_offset		fixed bin (21);
  dcl (i, len)		fixed bin;

  probe_info_ptr = P_probe_info_ptr;

  if probe_info.ct -> token.type >= probe_info.end_token
    then number_to_print = 1;
    else do;
      call probe_get_$integer (probe_info_ptr, number_to_print, code);
      if code ^= 0
        then go to SOME_ERROR;
    end;

  seg_info_ptr = current_source.seg_info_ptr;
  if seg_info_ptr = null then do;
      code = probe_et_$bad_line;
      go to SOME_ERROR;
    end;
  stmt_map_ptr = seg_info_ptr -> seg_info.statement_map_ptr;
  if stmt_map_ptr = null then do;
      code = probe_et_$no_statement_map;
      go to SOME_ERROR;
    end;

  map_size = seg_info_ptr -> seg_info.map_size;

  new_source_info = current_source;

  do i = current_source.stmnt_map_entry_index to min (map_size,
       current_source.stmnt_map_entry_index + number_to_print - 1);

    call print_object (i);
  end;
  goto MAIN_RETURN;


print_object:
  proc (P_i);

  /* Prints source line followed by the instructions for it */

  dcl P_i			fixed bin;

  new_source_info.stmnt_map_entry_index = P_i;

  call probe_source_segment_$list_statement (probe_info_ptr,
       addr (new_source_info), 1, code);

  /* Any problems? */
  if code ^= 0 then do;
				/* If we couldn't find the source print a warning, but print the object anyway */
      if code = error_table_$noentry then do;
	call probe_error_$warning (probe_info_ptr, code);
	code = 0;
        end;
        else go to SOME_ERROR;
    end;

  start_offset = fixed (map_array (P_i).location);
  if P_i >= map_size
    then len = 1;
    else len = fixed (map_array (P_i + 1).location) - start_offset;

  call probe_break_mgr_$print_instructions (probe_info_ptr,
       addr (new_source_info),
       pointer (current_source.instruction_ptr, map_array (P_i).location),
       len);

  end print_object;
%page;
position_request:
  entry (P_probe_info_ptr);


  /* Both "position" and "use"

   we accept:

   +N
   -N
   level N
   STRING
   < STRING
   LINE
   PROCEDURE

*/
  dcl print_it		bit (1) aligned;
				/* are we "ps" or "use" */
  dcl (use_level, use_decimal)
			fixed bin;
  dcl line_invocation	fixed bin;
  dcl number_to_position	fixed bin;
  dcl position_lines	bit (1) aligned;
  dcl position_backwards	bit (1) aligned;
  dcl rel_level_sw		bit (1) aligned;
  dcl hp			ptr;
  dcl (loc, next_token_type)	bit (18);

  dcl probe_source_segment_$position_source
			entry (ptr, ptr, fixed bin, fixed bin (35));
  dcl probe_source_segment_$position_source_lines
			entry (ptr, ptr, fixed bin, fixed bin (35));
  dcl probe_source_segment_$find_source
			entry (ptr, ptr, char (*), fixed bin (35));
  dcl probe_stack_trace_$current_level
			entry (ptr) returns (fixed bin);
  dcl probe_stack_trace_$get_level
			entry (ptr, ptr, fixed bin, fixed bin);

  print_it = "1"b;
  goto ps_use_com;


use_request:
  entry (P_probe_info_ptr);


  print_it = "0"b;
  goto ps_use_com;

ps_use_com:
  probe_info_ptr = P_probe_info_ptr;

  code = 0;			/* assume we will win */
  position_lines, position_backwards = "0"b;

  if probe_info.ct -> operator.type >= probe_info.end_token then do;
				/* if no args, return to where we began */
      new_source_info = initial_source;
      if new_source_info.instruction_ptr = null
	 & new_source_info.seg_info_ptr ^= null then do;
	stmt_map_ptr =
	     new_source_info.seg_info_ptr -> seg_info.statement_map_ptr;
	if stmt_map_ptr ^= null then do;
	    loc = map_array (new_source_info.stmnt_map_entry_index)
	         .location;
	    hp = new_source_info.seg_info_ptr -> seg_info.symbol_header_ptr;
	    new_source_info.instruction_ptr = pointer (hp, loc);
	  end;
        end;
      go to GOT_LOCATION;
    end;

  next_token_type = probe_info.ct -> token.next -> token.type;

  if probe_info.ct -> operator.type = MINUS
       | probe_info.ct -> operator.type = PLUS then do;
POSITION_REL:
      if probe_info.ct -> operator.type = MINUS
        then
	   position_backwards = "1"b;

      call bump_ct ();
      if probe_info.ct -> token.type ^= CONSTANT_TYPE
        then
	   goto SYNTAX_ERROR;

      call probe_get_$integer (probe_info_ptr, number_to_position, code);
      if code ^= 0
        then goto SOME_ERROR;

      if probe_info.ct -> token.type = NAME_TYPE
        then
	   if current_identifier_name = "line"
	        | current_identifier_name = "lines" then do;
	       position_lines = "1"b;
	       call bump_ct ();
	     end;

      call reject_argument ();

      if position_backwards
        then number_to_position = -number_to_position;
				/* negate it */

      if probe_info.execute then do;
	new_source_info = current_source;
				/* all the same, except for statement # */
	if position_lines
	  then call probe_source_segment_$position_source_lines
		  (probe_info_ptr, addr (new_source_info),
		  number_to_position, code);

	  else call probe_source_segment_$position_source
		  (probe_info_ptr, addr (new_source_info),
		  number_to_position, code);
        end;
    end;


  else if probe_info.ct -> token.type = CONSTANT_TYPE /* a string */
       & probe_info.ct -> constant.data_type = (char_dtype * 2) then do;
      call reject_next_argument ();	/* make sure theres nothing more */

      if probe_info.execute then do;
	new_source_info = current_source;
	call probe_source_segment_$find_source
	     (probe_info_ptr, addr (new_source_info), constant_string, code)
	     ;
        end;

      call bump_ct ();		/* keep syntax happy */
    end;

  else if probe_info.ct -> token.type = LESS_THAN &
       probe_info.ct -> token.next -> constant.data_type = (char_dtype * 2)
    then do;
				/* < STRING search */
      probe_info.ct = probe_info.ct -> token.next;

      call reject_next_argument;

      call probe_error_ (probe_info_ptr, probe_et_$unimplemented_request,
	 "backwards searching for STRING");

      if probe_info.execute
        then do;
	new_source_info = current_source;
				/* start from here */

	/* add code ere someday */

        end;

      call bump_ct ();

    end;				/* < STRING */

  else if probe_info.ct -> token.type = NAME_TYPE &
       (next_token_type = CONSTANT_TYPE | next_token_type = MINUS
       | next_token_type = PLUS) then do;
      if current_identifier_name = "line" | current_identifier_name = "lines"
        then do;
	position_lines = "1"b;

	call bump_ct ();
	if probe_info.ct -> operator.type = MINUS
	     | probe_info.ct -> operator.type = PLUS
	  then
	       go to POSITION_REL;
	  else go to POSITION_LINE;
        end;

      else if current_identifier_name = "level"
	 | current_identifier_name = "lvl" |
	 current_identifier_name = "lv" then do;

	if next_token_type = MINUS | next_token_type = PLUS then do;
	    rel_level_sw = "1"b;
	    position_backwards = (next_token_type = MINUS);

	    call bump_ct ();
	    if probe_info.ct -> token.next -> token.type ^= CONSTANT_TYPE
	      then go to SYNTAX_ERROR;
	  end;
	  else rel_level_sw = "0"b;

	call bump_ct ();
	call reject_next_argument;

	if probe_info.ct -> constant.scale ^= 0 & ^rel_level_sw
	  then
	       call probe_get_$decimal (probe_info_ptr, use_level,
		  use_decimal, code);
	  else do;
	    call probe_get_$integer (probe_info_ptr, use_level, code);
	    use_decimal = 0;
	  end;
	if code ^= 0
	  then goto SOME_ERROR;

	if probe_info.execute then do;

	    if rel_level_sw then do;
	        if position_backwards
		then use_level = -use_level;

	        use_level =
		   probe_stack_trace_$current_level (probe_info_ptr)
		   + use_level;
	      end;

	    call probe_stack_trace_$get_level (probe_info_ptr,
	         addr (new_source_info),
	         use_level, use_decimal);
	  end;
        end;

      else go to SYNTAX_ERROR;
    end;				/* level N */

  else /* LINE or PROCEDURE */
POSITION_LINE:
    call get_location ();
GOT_LOCATION:
  call reject_argument ();

  /* Now the Syntax is known good */

  /* *	If executing, new_source_info is set, so assign it to current_source.
   *	code is 0 unless search failed, so print if appropriate */

  if probe_info.execute then do;	/* print the new one, if desired */
      if code = 0 then do;		/* it worked. code was left set by all paths above */

	probe_info.language_type =
	     new_source_info.seg_info_ptr -> seg_info.language_type;
	current_source = new_source_info;

	/* in old probe this was also controlled by "mode brief" */

	if print_it
	  then call probe_source_segment_$list_statement (probe_info_ptr,
		  addr (current_source), 1, code);
	if code ^= 0
	  then goto SOME_ERROR;
        end;

        else call probe_error_ (probe_info_ptr, code);
				/* lose, otherwise */
    end;
  goto MAIN_RETURN;			/* end of code for position request */


get_location:
  proc;				/* also used by reset/status */

  if resembles_path ()
    then do;
      call probe_get_$object (probe_info_ptr, addr (new_source_info), code);
      data_type_found = ext_procedure_runtime_dtype;
    end;
    else do;
      call probe_get_$line (probe_info_ptr, addr (new_source_info),
	 line_invocation, "1110"b, data_type_found, code);
    end;
  if code ^= 0
    then goto SOME_ERROR;
  return;


resembles_path:
  proc () returns (bit (1) aligned);

  if probe_info.ct -> token.type = LESS_THAN |
       probe_info.ct -> token.type = GREATER_THAN
    then return ("1"b);
  if probe_info.ct -> token.type = NAME_TYPE &
       probe_info.ct -> token.next -> token.type = GREATER_THAN
    then return ("1"b);
  return ("0"b);
  end resembles_path;
  end get_location;
%page;

where_request:
  entry (P_probe_info_ptr);

  /* *	This prints out information about the current values of the pointers */


  dcl 1 want_locs		aligned,
       2 source		bit (1) unal,
       2 control		bit (1) unal,
       2 path		bit (1) unal;
  dcl location_string	char (256);
  dcl dn			char (168);
  dcl (en, proc_name)	char (32);
  dcl dn_len		fixed bin;
  dcl sip			ptr;

  probe_info_ptr = P_probe_info_ptr;

  want_locs = "0"b;

  if probe_info.ct -> token.type >= probe_info.end_token
    then /* if none specified, print them all */
         want_locs.source, want_locs.control = "1"b;

    else
      do while (probe_info.ct -> token.type < probe_info.end_token);
				/* otherwise, look for good keywords */
      if probe_info.ct -> token.type ^= NAME_TYPE
        then goto WHERE_USAGE;

      if current_identifier_name = "source" | current_identifier_name = "sc" |
	 current_identifier_name = "block" | current_identifier_name = "bk"
				/* allow old forms for a while */
        then want_locs.source = "1"b;
      else if current_identifier_name = "control"
	 | current_identifier_name = "ctl" |
	 current_identifier_name = "object"
	 | current_identifier_name = "obj" |
	 current_identifier_name = "oj"
        then want_locs.control = "1"b;
      else if current_identifier_name = "path"
        then want_locs.path = "1"b;
      else goto WHERE_USAGE;

      call bump_ct ();		/* look at the next token */
    end;

  if ^want_locs.source & ^want_locs.control
    then want_locs.source, want_locs.control = "1"b;
				/* default */

  if ^probe_info.execute
    then goto MAIN_RETURN;

  if want_locs.source then do;
      if want_locs.path then do;
	source_ptr = probe_source_segment_$get_file_ptr
	     (probe_info_ptr, probe_info.ptr_to_current_source, 1);
	call hcs_$fs_get_path_name (source_ptr, dn, dn_len, en, code);
	if code ^= 0 then do;
	    call probe_error_ (probe_info_ptr, code,
	         "Evaluating source pointer.");
	    goto MAIN_RETURN;
	  end;
	location_string = pathname_ (substr (dn, 1, dn_len), en);
        end;
        else call probe_pretty_source_info_ (probe_info_ptr,
	        probe_info.ptr_to_current_source, location_string);
      call ioa_$ioa_switch (probe_info.output_switch, "^a", location_string);
    end;

  if want_locs.control then do;

      call probe_stack_trace_$where_source_info (probe_info_ptr,
	 probe_info.ptr_to_initial_source, level, "");
      call ioa_$rsnnl ("^[(level ^d)^;^s(no active frame)^]",
	 level_string, length (level_string), level >= 0, level);

      if want_locs.path then do;	/* "where object path" */
	sip = current_source.seg_info_ptr;
	location_string =
	     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 */
	       location_string =
		  rtrim (sip -> seg_info.segname) || " in "
		  || location_string;
	call ioa_$ioa_switch (probe_info.output_switch, "^a ^a",
	     location_string, level_string);
        end;
      else if initial_source.seg_info_ptr -> seg_info.statement_map_ptr
	 ^= null
        then
	   call ioa_$ioa_switch (probe_info.output_switch,
	        "Control at ^a of ^a ^a",
	        probe_line_number_ (probe_info_ptr, initial_source),
	        probe_block_name_ (probe_info_ptr,
	        probe_info.ptr_to_initial_source, "0"b), level_string);
      else call ioa_$ioa_switch (probe_info.output_switch,
	      "Control at ^a|^o. ^a",
	      probe_block_name_ (probe_info_ptr,
	      probe_info.ptr_to_initial_source, "0"b),
	      binary (rel (initial_source.instruction_ptr), 18, 0),
	      level_string);
    end;

  goto MAIN_RETURN;

WHERE_USAGE:
  call probe_error_ (probe_info_ptr, 0,
       "Only the keywords ""source"", ""control"" or ""object"", and ""path"" are allowed."
       );
  goto MAIN_RETURN;			/* end of code for where request */

%page;

reset_request:
  entry (P_probe_info_ptr);

  reset_req = "1"b;
  goto S_R_COM;


status_request:
  entry (P_probe_info_ptr);

  reset_req = "0"b;
  goto S_R_COM;
  dcl reset_req		bit (1) aligned;
				/* as distinct from source req */
  dcl long_sw		bit (1) aligned;
  dcl case		fixed bin;
  dcl data_type_found	fixed bin;/* LINE: what kind did you find ? */
  dcl mod_type		fixed bin;
  dcl ctl			char (64) varying;


  dcl probe_listen_$check_line
			entry (ptr, ptr, fixed bin (21), fixed bin (35))
			;
  dcl probe_break_mgr_$reset_break_at_line
			entry (ptr, ptr, fixed bin, bit (1) aligned,
			fixed bin (35));
  dcl probe_break_mgr_$reset_breaks_in_seg
			entry (ptr, ptr, bit (1) aligned,
			fixed bin (35));
  dcl probe_break_mgr_$reset_breaks_in_world
			entry (ptr, bit (1) aligned, fixed bin (35));

  dcl probe_break_mgr_$list_breaks_at_line
			entry (ptr, ptr, fixed bin, bit (1) aligned,
			fixed bin (35));
  dcl probe_break_mgr_$list_breaks_in_seg
			entry (ptr, ptr, bit (1) aligned,
			fixed bin (35));
  dcl probe_break_mgr_$list_breaks_in_world
			entry (ptr, bit (1) aligned, fixed bin (35));
  dcl probe_break_mgr_$list_broken_segs
			entry (ptr, fixed bin (35));

  dcl (
      DEFAULT_CASE		init (1), /* nothing */
      WORLD_CASE		init (2), /* -all */
      LINE_CASE		init (3), /* LINE */
      SEG_CASE		init (4), /* OBJECT */
      STAR_CASE		init (5), /* * */
      STRING_CASE		init (6)	/* STRING */
      )			fixed bin internal static options (constant);


  dcl probe_get_$control_arg	entry (ptr, char (64) varying, fixed bin (35));


S_R_COM:

  probe_info_ptr = P_probe_info_ptr;

  /* Now to parse */

  call probe_get_$control_arg (probe_info_ptr, ctl, code);
  if code ^= 0
    then goto SOME_ERROR;

  if ctl = "brief" | ctl = "bf" then do;
      case = DEFAULT_CASE;
      long_sw = "0"b;
    end;
  else if ctl = "long" | ctl = "lg" then do;
      case = DEFAULT_CASE;
      long_sw = "1"b;
    end;
  else do;			/* ctl may be null or supplied - we shall see */
    if ctl = "all" | ctl = "a"
      then case = WORLD_CASE;
    else if ctl ^= ""		/* some other ctl arg, yechh ! */
      then call probe_error_ (probe_info_ptr, probe_et_$bad_ctl_arg,
	      "-" || ctl);
    else if probe_info.ct -> token.type >= probe_info.end_token
      then case = DEFAULT_CASE;
    else if probe_info.ct -> token.type = TIMES
         | probe_info.ct -> token.type = C_INDIRECTION then do;
        call bump_ct ();		/* past * */
        case = STAR_CASE;
      end;
    else if probe_info.ct -> token.type = CONSTANT_TYPE &
         probe_info.ct -> constant.data_type = (char_dtype * 2) then do;
        case = STRING_CASE;
        mod_type = BREAK_AT;
        search_string = constant_string;

        call bump_ct ();
      end;

    else do;			/* it must be LINE or OBJECT */

      /* if a LINE MOD is there, it must be a line */

      mod_type = -1;		/* no such type */
      if probe_info.ct -> token.type = NAME_TYPE
        then if current_identifier_name = "after" |
	        current_identifier_name = "af" |
	        current_identifier_name = "a"
	     then do;
	       call bump_ct ();
	       mod_type = BREAK_AFTER;
	     end;
	   else if current_identifier_name = "before" |
	        current_identifier_name = "be" |
	        current_identifier_name = "b"
	     then do;
	       call bump_ct ();
	       mod_type = BREAK_BEFORE;
	     end;
	   else if current_identifier_name = "at"
	     then do;
	       call bump_ct ();
	       mod_type = BREAK_AT;
	     end;

      call get_location ();		/* much LINE and OBJECT */
      if data_type_found = ext_procedure_runtime_dtype |
	 data_type_found = ext_entry_runtime_dtype
        then do;
	case = SEG_CASE;
	if mod_type >= 0
	  then
	       call probe_error_ (probe_info_ptr, 0,
		  """^a"" not allowed before external procedure.",
		  PLACE (mod_type));
        end;
        else do;
	case = LINE_CASE;
	if mod_type < 0
	  then mod_type = BREAK_AT;
        end;
    end;				/* parsing LINE or PROC */


    call probe_get_$control_arg (probe_info_ptr, ctl, code);
  end;
  if code ^= 0
    then goto SOME_ERROR;

  call reject_argument ();

  /* all parsing done - but must examine ctl */

  if reset_req
    then long_sw = "1"b;		/* default */
  else if case = LINE_CASE
    then long_sw = "1"b;
  else long_sw = "0"b;

  if ctl = "long" | ctl = "lg"
    then long_sw = "1"b;
  else if ctl = "brief" | ctl = "bf"
    then long_sw = "0"b;
  else if ctl ^= ""
    then call probe_error_ (probe_info_ptr, probe_et_$bad_ctl_arg, "-" || ctl)
	    ;

  /* SYNTAX IS NOW KNOWN TO BE GOOD */

  if probe_info.execute
    then if reset_req
	 then do;
	   if case = DEFAULT_CASE
	     then if probe_info.break_slot_ptr = null ()
		  then call probe_error_ (probe_info_ptr,
			  probe_et_$none_active);
		  else do;
		    new_source_info = initial_source;
		    call probe_break_mgr_$reset_break_at_line (
		         probe_info_ptr, addr (initial_source),
		         probe_info.break_slot_ptr -> break_slot.type,
		         long_sw, code);
		  end;
	   else if case = WORLD_CASE | case = STAR_CASE
	     then call probe_break_mgr_$reset_breaks_in_world
		     (probe_info_ptr, long_sw, code);
	   else if case = STRING_CASE then do;
				/* r STRING: reset all matches */
	       new_source_info = current_source;

	       call probe_source_segment_$find_source
		  (probe_info_ptr, addr (new_source_info),
		  (search_string), code);
	       if code ^= 0
	         then goto MAIN_RETURN;
	       first_match = new_source_info.stmnt_map_entry_index;
	       do while ("1"b);
	         call probe_break_mgr_$reset_break_at_line
		    (probe_info_ptr, addr (new_source_info), mod_type,
		    long_sw, code);

	         call probe_source_segment_$find_source
		    (probe_info_ptr, addr (new_source_info),
		    (search_string), code);
	         if code ^= 0
		    | new_source_info.stmnt_map_entry_index = first_match
		 then goto MAIN_RETURN;
	       end;
	     end;
	   else if case = LINE_CASE
	     then call probe_break_mgr_$reset_break_at_line
		     (probe_info_ptr, addr (new_source_info), mod_type,
		     long_sw, code);
	   else if case = SEG_CASE
	     then call probe_break_mgr_$reset_breaks_in_seg (probe_info_ptr,
		     addr (new_source_info), long_sw, code);
	 end;			/* reset cases */
	 else do;
	   if case = DEFAULT_CASE
	     then do;
	       call probe_break_mgr_$list_breaks_in_seg (probe_info_ptr,
		  addr (current_source),
		  long_sw, code);
	       new_source_info = current_source;
	     end;
	   else if case = WORLD_CASE
	     then call probe_break_mgr_$list_breaks_in_world (
		     probe_info_ptr, long_sw, code);
	   else if case = LINE_CASE
	     then call probe_break_mgr_$list_breaks_at_line (probe_info_ptr,
		     addr (new_source_info), mod_type,
		     long_sw, code);
	   else if case = SEG_CASE
	     then call probe_break_mgr_$list_breaks_in_seg (probe_info_ptr,
		     addr (new_source_info),
		     long_sw, code);
	   else if case = STAR_CASE
	     then call probe_break_mgr_$list_broken_segs (probe_info_ptr,
		     code);
	 end;			/* status  cases */

  dcl (
      probe_et_$breakless,
      probe_et_$no_breaks
      )			fixed bin (35) external static;

  if code = probe_et_$breakless
    then call probe_error_ (probe_info_ptr, probe_et_$breakless,
	    PLACE (mod_type),
	    probe_line_number_ (probe_info_ptr, new_source_info));
  else if code = probe_et_$no_breaks then do;
      pathname =
	 rtrim (new_source_info.seg_info_ptr -> seg_info.directory_name);
      pathname = pathname || ">";
				/* it turns out that .entry_name is really the segname */
      pathname =
	 pathname
	 || rtrim (new_source_info.seg_info_ptr -> seg_info.entry_name);
      pathname = pathname || "$";
      pathname =
	 pathname
	 || rtrim (new_source_info.seg_info_ptr -> seg_info.segname);
				/* and .segname is really the entry point name */
      call probe_error_ (probe_info_ptr, probe_et_$no_breaks, pathname);
    end;

  if code ^= 0
    then goto SOME_ERROR;
  goto MAIN_RETURN;

%page;
after_request:
  entry (P_probe_info_ptr);

  /* *	This request sets a breakpoint after the specified line */

  dcl break_location	fixed bin;
  dcl requests_ptr		pointer;
  dcl requests_lth		fixed bin (21);
  dcl search_sw		bit (1) aligned;
  dcl search_string		char (256) varying;
  dcl first_match		fixed bin;
  dcl done		bit (1) aligned;
  dcl DEFAULT_BREAK_REQUEST	char (4) aligned internal static
			options (constant) init ("halt");
  dcl probe_break_mgr_$set_break
			entry (ptr, ptr, fixed bin, pointer,
			fixed bin (21), fixed bin (35));

  break_location = BREAK_AFTER;
  goto AFTER_BEFORE_COMMON;

before_request:
  entry (P_probe_info_ptr);

  /* *     This request sets a breakpoint before the specified line */

  break_location = BREAK_BEFORE;
  goto AFTER_BEFORE_COMMON;


AFTER_BEFORE_COMMON:
  probe_info_ptr = P_probe_info_ptr;


  /* We can accept the following:
   b	default loc and default break list
   b N	explicit loc default break
   b : R	default loc, explicit break list
   b N:R	explicit both

*/

  search_sw = "0"b;

  if probe_info.ct -> token.type >= probe_info.end_token |
       probe_info.ct -> token.type = COLON
    then new_source_info = current_source;

  else if probe_info.ct -> token.type = CONSTANT_TYPE &
       probe_info.ct -> constant.data_type = (char_dtype * 2) then do;
      search_sw = "1"b;
      search_string = constant_string;

      call bump_ct ();
    end;

  else do;
    call probe_get_$line (probe_info_ptr, addr (new_source_info), (0),
         "0000"b, (0), code);
    if code ^= 0
      then goto SOME_ERROR;
  end;

  /* now have loc, default or explicit */


  if probe_info.ct -> token.type >= end_token /* default commands */
    then do;
      requests_ptr = addr (DEFAULT_BREAK_REQUEST);
      requests_lth = length (DEFAULT_BREAK_REQUEST);

    end;
  else if probe_info.ct -> operator.type = COLON then do;
      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 goto SOME_ERROR;

      call reject_argument ();	/* nothing may follow the request line */

      probe_info.setting_break = "1"b;

      call probe_listen_$check_line (probe_info_ptr, requests_ptr,
	 requests_lth, code);
      if code ^= 0
        then goto SOME_ERROR;		/* check the syntax */

      probe_info.setting_break = "0"b;
    end;
  else call probe_error_ (probe_info_ptr, 0,
				/* probably commands */
	  "The break location and the requests to be executed must be separated by a colon."
	  );


  if probe_info.execute then do;	/* set the break */
      if search_sw then do;		/* b STRING */
	new_source_info = current_source;

	call probe_source_segment_$find_source
	     (probe_info_ptr, addr (new_source_info), (search_string), code)
	     ;
	if code ^= 0
	  then call probe_error_ (probe_info_ptr, code);
	  else do;
	    first_match = new_source_info.stmnt_map_entry_index;

	    done = "0"b;
	    do while (^done);

	      call set_break;

	      call probe_source_segment_$find_source (probe_info_ptr,
		 addr (new_source_info),
		 (search_string), code);
	      if code ^= 0
		 | new_source_info.stmnt_map_entry_index = first_match
	        then
		   done = "1"b;
	    end;
	    code = 0;
	  end;
        end;

        else call set_break;
    end;

  goto MAIN_RETURN;			/* end of code for after and before requests */



set_break:
  proc;

  call probe_break_mgr_$set_break (probe_info_ptr, addr (new_source_info),
       break_location, requests_ptr, requests_lth, code);
  if code ^= 0
    then goto SOME_ERROR;
  if ^probe_static_info.brief_sw
    then
         call ioa_$ioa_switch (probe_info.output_switch, "Break set ^a ^a",
	    PLACE (break_location),
	    probe_line_number_ (probe_info_ptr, new_source_info));

  end set_break;
%page;
enable_request:
  entry (P_probe_info_ptr);

  /* Undocumented request used when debugging probe itself. Resets the value
   (probe_static_info.last_break_segno, compared against .probe_segno)
   that tells probe it is already stopped at a break inside probe and therefore
   should ignore any recursively hit breaks. Despite "continue", cleanup, and
   other precautions to reset this value when leaving a break in probe, it is
   still sometimes inexplicably left set. */

  P_probe_info_ptr -> probe_info.static_info_ptr
       -> probe_static_info.last_break_segno = "0"b;

  goto MAIN_RETURN;
%page;

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


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


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 goto SYNTAX_ERROR;		/* some protection against mistakes */

  return;
  end;				/* bump_ct internal procedure */
%page;
rest_of_request:
  proc (P_str);

  /* Returns the rest of the request as a character string */

  dcl P_str		char (*) varying;
  dcl input_buffer		char (probe_info.buffer_lth)
			based (probe_info.buffer_ptr);
  dcl (start_pos, end_pos)	fixed bin (21);

  start_pos = probe_info.ct -> token.location;

  do while (probe_info.ct -> token.type < probe_info.end_token);

    call bump_ct ();
  end;

  end_pos = probe_info.ct -> token.location;

  P_str =
       rtrim (substr (input_buffer, start_pos, end_pos - start_pos + 1), NL);

  return;

  end rest_of_request;




set_iocb:
  proc (P_iocb_ptr, P_private_sw, P_new_iocb_ptr, P_new_private_sw);

  /* Destroys the old IOCB if it was private (created by ids or ods) and
   sets the static IOCB to the new value */

  dcl (P_iocb_ptr, P_new_iocb_ptr)
			ptr;
  dcl (P_private_sw, P_new_private_sw)
			bit (1) aligned;


  if P_private_sw & /* previous IOCB was set by ids or ods */
       P_iocb_ptr ^= iox_$user_input & P_iocb_ptr ^= iox_$user_output &
       P_iocb_ptr ^= iox_$error_output & P_iocb_ptr ^= iox_$user_io then do;
      call iox_$close (P_iocb_ptr, (0));
      call iox_$detach_iocb (P_iocb_ptr, (0));
      call iox_$destroy_iocb (P_iocb_ptr, (0));
    end;

  P_iocb_ptr = P_new_iocb_ptr;
  P_private_sw = P_new_private_sw;

  end set_iocb;

%page;
%include probe_info;
%page;
%include probe_static_info;
%page;
%include probe_tokens;
%page;
%include probe_references;
%page;
%include probe_level_frame;
%page;
%include probe_source_info;
%page;
%include stack_frame;
%page;
%include probe_operators;
%page;
%include std_descriptor_types;
%page;
%include probe_seg_info;
%page;
%include statement_map;
%page;
%include probe_break_slot;
%page;
%include probe_lang_types;
%page;
%include probe_info_constants;

  end probe_requests_;		/* external procedure */




		    probe_scan_data_.cds            10/24/88  1622.8rew 10/24/88  1344.0      181233



/* ***********************************************************
   *                                                         *
   * 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,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Modified as part of C-Probe Support.
                                                   END HISTORY COMMENTS */


probe_scan_data_: proc;				/* CDS source */

/* Modified June 83 JMAthane to add PASCAL */
/* Added PASCAL_RANGE and PASCAL_ASSIGN, and associated actions 07/26/83 S. Herbst */
/* Fixed to allow dots in entry names when running FORTRAN 02/15/84 S. Herbst */
/* Modified April 88 Hinatsu to add C operators */

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

	dcl     1 cds		 aligned like cds_args;

	dcl     code		 fixed bin (35);
	dcl     (addr, null, size)	 builtin;
	dcl     com_err_		 entry options (variable);

%include probe_scan_data;


	cds.sections (1).p = addr (probe_scan_data);
	cds.sections (1).len = size (probe_scan_data);
	cds.sections (1).struct_name = "probe_scan_data";
	cds.sections (2).p = null ();
	cds.sections (2).len = 0;
	cds.sections (2).struct_name = "";
	cds.seg_name = "probe_scan_data_";
	cds.num_exclude_names = 0;
	cds.exclude_array_ptr = null ();
	cds.switches = "0"b;
	cds.switches.have_text = "1"b;


	call build_data;

	call create_data_segment_ (addr (cds), code);
	if code ^= 0 then call com_err_ (code);
	return;

build_data: proc;

	dcl     rank		 builtin;


	doubles (1).pair = "^="; doubles (1).type = op_coder (NOT_EQUALS);
	doubles (2).pair = "^<"; doubles (2).type = op_coder (NOT_LESS_THAN);
	doubles (3).pair = "^>"; doubles (3).type = op_coder (NOT_GREATER_THAN);
	doubles (4).pair = ">="; doubles (4).type = op_coder (NOT_LESS_THAN);
	doubles (5).pair = "<="; doubles (5).type = op_coder (NOT_GREATER_THAN);
	doubles (6).pair = "->"; doubles (6).type = op_coder (ARROW);
	doubles (7).pair = "<>"; doubles (7).type = op_coder (NOT_EQUALS);
	doubles (8).pair = ".."; doubles (8).type = op_coder (PASCAL_RANGE);
	doubles (9).pair = ":="; doubles (9).type = op_coder (PASCAL_ASSIGN);
/* the special cases for C doubles */
	doubles (10).pair = "=="; doubles (10).type = op_coder (C_EQUAL);
	doubles (11).pair = "!="; doubles (11).type = op_coder (C_NOT_EQUAL);
	doubles (12).pair = "<<"; doubles (12).type = op_coder (C_LEFT_SHIFT);
	doubles (13).pair = ">>"; doubles (13).type = op_coder (C_RIGHT_SHIFT);

	fort_ops (1).name = "not "; fort_ops (1).op_code = op_coder (NOT_SIGN);
	fort_ops (2).name = "and "; fort_ops (2).op_code = op_coder (AMPERSAND);
	fort_ops (3).name = "or  "; fort_ops (3).op_code = op_coder (OR_BAR);
	fort_ops (4).name = "ge  "; fort_ops (4).op_code = op_coder (NOT_LESS_THAN);
	fort_ops (5).name = "le  "; fort_ops (5).op_code = op_coder (NOT_GREATER_THAN);
	fort_ops (6).name = "gt  "; fort_ops (6).op_code = op_coder (GREATER_THAN);
	fort_ops (7).name = "lt  "; fort_ops (7).op_code = op_coder (LESS_THAN);
	fort_ops (8).name = "eq  "; fort_ops (8).op_code = op_coder (EQUALS);
	fort_ops (9).name = "ne  "; fort_ops (9).op_code = op_coder (NOT_EQUALS);

	pasc_ops (1).name = "not"; pasc_ops (1).op_code = op_coder (NOT_SIGN);
	pasc_ops (2).name = "and"; pasc_ops (2).op_code = op_coder (AMPERSAND);
	pasc_ops (3).name = "or"; pasc_ops (3).op_code = op_coder (OR_BAR);


	call set_char_types;

	probe_scan_data.cobol_char_type,
	     probe_scan_data.fortran_char_type,
	     probe_scan_data.pascal_char_type,
	     probe_scan_data.c_char_type = probe_scan_data.pl1_char_type;

/* now for the exceptions to the rule */

	probe_scan_data.fortran_char_type (rank ("'")) = QUOTE_CHAR_TYPE;

	probe_scan_data.pascal_char_type (rank ("'")) = QUOTE_CHAR_TYPE;
	probe_scan_data.pascal_char_type (rank ("#")) = OTHER_OPS_CHAR_TYPE;
	probe_scan_data.pascal_char_type (rank ("@")) = PASCAL_ARROW_CHAR_TYPE;
	probe_scan_data.pascal_char_type (rank ("^")) = PASCAL_ARROW_CHAR_TYPE;
	probe_scan_data.c_char_type (rank ("!")) = NOT_CHAR_TYPE;
	probe_scan_data.c_char_type (rank ("'")) = QUOTE_CHAR_TYPE;
	probe_scan_data.c_char_type (rank ("&")) = C_ADDRESS_CHAR_TYPE;
	probe_scan_data.c_char_type (rank ("%")) = C_MOD_CHAR_TYPE;
 

	probe_scan_data.cobol_action_table,
	     probe_scan_data.pascal_action_table,
	     probe_scan_data.fortran_action_table,
	     probe_scan_data.c_action_table = probe_scan_data.pl1_action_table;

/* now for the exceptions */

	probe_scan_data.cobol_action_table (NAME_STATE, MINUS_CHAR_TYPE) = 36;

	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 0) = 99;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 1) = 59;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 2) = 59;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 3) = 58;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 4) = 59;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 5) = 59;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 6) = 59;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 7) = 59;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 8) = 59;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 9) = 59;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 10) = 59;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 11) = 59;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 12) = 59;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 13) = 59;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 14) = 59;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 15) = 57;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 16) = 57;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 17) = 57;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 18) = 57;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 19) = 57;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 20) = 59;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 21) = 59;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 22) = 57;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 23) = 59;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 24) = 59;
	probe_scan_data.fortran_action_table (IN_DOT_OP_STATE, 25) = 59;

	probe_scan_data.fortran_action_table (DOT_SEEN_STATE, LETTER_B_CHAR_TYPE) = 56;
	probe_scan_data.fortran_action_table (DOT_SEEN_STATE, LETTER_E_CHAR_TYPE) = 56;
	probe_scan_data.fortran_action_table (DOT_SEEN_STATE, LETTER_I_CHAR_TYPE) = 56;
	probe_scan_data.fortran_action_table (DOT_SEEN_STATE, LETTER_O_CHAR_TYPE) = 56;
	probe_scan_data.fortran_action_table (DOT_SEEN_STATE, LETTER_F_CHAR_TYPE) = 56;
	probe_scan_data.fortran_action_table (DOT_SEEN_STATE, OTHER_LETTER_CHAR_TYPE) = 56;

	probe_scan_data.pascal_action_table (NULL_STATE, PASCAL_ARROW_CHAR_TYPE) = 16;
	probe_scan_data.pascal_action_table (POSSIBLE_DOUBLE_STATE, PASCAL_ARROW_CHAR_TYPE) = 71;
	probe_scan_data.pascal_action_table (NAME_STATE, PASCAL_ARROW_CHAR_TYPE) = 32;
	probe_scan_data.pascal_action_table (STRING_STATE, PASCAL_ARROW_CHAR_TYPE) = 41;
	probe_scan_data.pascal_action_table (QUOTE_SEEN_STATE, PASCAL_ARROW_CHAR_TYPE) = 45;
	probe_scan_data.pascal_action_table (BIT_STR_END_STATE, PASCAL_ARROW_CHAR_TYPE) = 51;
	probe_scan_data.pascal_action_table (DOT_SEEN_STATE, PASCAL_ARROW_CHAR_TYPE) = 55;
	probe_scan_data.pascal_action_table (NUMBER_PRE_DOT_STATE, PASCAL_ARROW_CHAR_TYPE) = 23;
	probe_scan_data.pascal_action_table (NUMBER_POST_DOT_STATE, PASCAL_ARROW_CHAR_TYPE) = 23;
	probe_scan_data.pascal_action_table (NUMBER_EXP1_STATE, PASCAL_ARROW_CHAR_TYPE) = 23;
	probe_scan_data.pascal_action_table (NUMBER_EXP2_STATE, PASCAL_ARROW_CHAR_TYPE) = 23;
	probe_scan_data.pascal_action_table (IN_DOT_OP_STATE, PASCAL_ARROW_CHAR_TYPE) = 0; /* undefined */
	probe_scan_data.pascal_action_table (PTR_WORD_STATE, PASCAL_ARROW_CHAR_TYPE) = 64;
	probe_scan_data.pascal_action_table (PTR_BIT_STATE, PASCAL_ARROW_CHAR_TYPE) = 95;
	probe_scan_data.pascal_action_table (DOT_SEEN_STATE, DOT_CHAR_TYPE) = 71;
	probe_scan_data.pascal_action_table (NULL_STATE, COLON_CHAR_TYPE) = 15;
	probe_scan_data.pascal_action_table (POSSIBLE_DOUBLE_STATE, EQUAL_CHAR_TYPE) = 71;


	probe_scan_data.c_action_table (NULL_STATE, C_ADDRESS_CHAR_TYPE) = 13;
	probe_scan_data.c_action_table (POSSIBLE_DOUBLE_STATE, C_ADDRESS_CHAR_TYPE) = 70;
	probe_scan_data.c_action_table (NAME_STATE, C_ADDRESS_CHAR_TYPE) = 32;
	probe_scan_data.c_action_table (STRING_STATE, C_ADDRESS_CHAR_TYPE) = 41;
	probe_scan_data.c_action_table (QUOTE_SEEN_STATE, C_ADDRESS_CHAR_TYPE) = 45;
	probe_scan_data.c_action_table (BIT_STR_END_STATE, C_ADDRESS_CHAR_TYPE) = 51;
	probe_scan_data.c_action_table (DOT_SEEN_STATE, C_ADDRESS_CHAR_TYPE) = 55;
	probe_scan_data.c_action_table (NUMBER_PRE_DOT_STATE, C_ADDRESS_CHAR_TYPE) = 23;
	probe_scan_data.c_action_table (NUMBER_POST_DOT_STATE, C_ADDRESS_CHAR_TYPE) = 23;
	probe_scan_data.c_action_table (NUMBER_EXP1_STATE, C_ADDRESS_CHAR_TYPE) = 25;
	probe_scan_data.c_action_table (NUMBER_EXP2_STATE, C_ADDRESS_CHAR_TYPE) = 22;
	probe_scan_data.c_action_table (PTR_WORD_STATE, C_ADDRESS_CHAR_TYPE) = 64;
	probe_scan_data.c_action_table (PTR_BIT_STATE, C_ADDRESS_CHAR_TYPE) = 95;

	probe_scan_data.c_action_table (NULL_STATE, C_MOD_CHAR_TYPE) = 13;
	probe_scan_data.c_action_table (POSSIBLE_DOUBLE_STATE, C_MOD_CHAR_TYPE) = 70;
	probe_scan_data.c_action_table (NAME_STATE, C_MOD_CHAR_TYPE) = 32;
	probe_scan_data.c_action_table (STRING_STATE, C_MOD_CHAR_TYPE) = 41;
	probe_scan_data.c_action_table (QUOTE_SEEN_STATE, C_MOD_CHAR_TYPE) = 45;
	probe_scan_data.c_action_table (BIT_STR_END_STATE, C_MOD_CHAR_TYPE) = 51;
	probe_scan_data.c_action_table (DOT_SEEN_STATE, C_MOD_CHAR_TYPE) = 55;
	probe_scan_data.c_action_table (NUMBER_PRE_DOT_STATE, C_MOD_CHAR_TYPE) = 23;
	probe_scan_data.c_action_table (NUMBER_POST_DOT_STATE, C_MOD_CHAR_TYPE) = 23;
	probe_scan_data.c_action_table (NUMBER_EXP1_STATE, C_MOD_CHAR_TYPE) = 25;
	probe_scan_data.c_action_table (NUMBER_EXP2_STATE, C_MOD_CHAR_TYPE) = 22;
	probe_scan_data.c_action_table (PTR_WORD_STATE, C_MOD_CHAR_TYPE) = 64;
	probe_scan_data.c_action_table (PTR_BIT_STATE, C_MOD_CHAR_TYPE) = 95;


op_coder: proc (opt) returns (fixed bin);
	dcl     opt		 bit (18) aligned parameter;

	dcl     (bin, substr)	 builtin;

	return (bin (substr (opt, 13)));
     end op_coder;
     end build_data;

set_char_types: proc;


/* this proc is set off from build data because it is so boring */

	probe_scan_data.pl1_char_type (0) = ILLEGAL_CHAR_TYPE; /* \000 */
	probe_scan_data.pl1_char_type (1) = ILLEGAL_CHAR_TYPE; /* \001 */
	probe_scan_data.pl1_char_type (2) = ILLEGAL_CHAR_TYPE; /* \002 */
	probe_scan_data.pl1_char_type (3) = ILLEGAL_CHAR_TYPE; /* \003 */
	probe_scan_data.pl1_char_type (4) = ILLEGAL_CHAR_TYPE; /* \004 */
	probe_scan_data.pl1_char_type (5) = ILLEGAL_CHAR_TYPE; /* \005 */
	probe_scan_data.pl1_char_type (6) = ILLEGAL_CHAR_TYPE; /* \006 */
	probe_scan_data.pl1_char_type (7) = ILLEGAL_CHAR_TYPE; /* \007 */
	probe_scan_data.pl1_char_type (8) = ILLEGAL_CHAR_TYPE; /* \010 */
	probe_scan_data.pl1_char_type (9) = WHITE_SPACE_CHAR_TYPE; /* \011 */
	probe_scan_data.pl1_char_type (10) = OTHER_OPS_CHAR_TYPE; /* \012 */
	probe_scan_data.pl1_char_type (11) = ILLEGAL_CHAR_TYPE; /* \013 */
	probe_scan_data.pl1_char_type (12) = WHITE_SPACE_CHAR_TYPE; /* \014 */
	probe_scan_data.pl1_char_type (13) = OTHER_OPS_CHAR_TYPE; /* \015 */
	probe_scan_data.pl1_char_type (14) = ILLEGAL_CHAR_TYPE; /* \016 */
	probe_scan_data.pl1_char_type (15) = ILLEGAL_CHAR_TYPE; /* \017 */
	probe_scan_data.pl1_char_type (16) = ILLEGAL_CHAR_TYPE; /* \020 */
	probe_scan_data.pl1_char_type (17) = ILLEGAL_CHAR_TYPE; /* \021 */
	probe_scan_data.pl1_char_type (18) = ILLEGAL_CHAR_TYPE; /* \022 */
	probe_scan_data.pl1_char_type (19) = ILLEGAL_CHAR_TYPE; /* \023 */
	probe_scan_data.pl1_char_type (20) = ILLEGAL_CHAR_TYPE; /* \024 */
	probe_scan_data.pl1_char_type (21) = ILLEGAL_CHAR_TYPE; /* \025 */
	probe_scan_data.pl1_char_type (22) = ILLEGAL_CHAR_TYPE; /* \026 */
	probe_scan_data.pl1_char_type (23) = ILLEGAL_CHAR_TYPE; /* \027 */
	probe_scan_data.pl1_char_type (24) = ILLEGAL_CHAR_TYPE; /* \030 */
	probe_scan_data.pl1_char_type (25) = ILLEGAL_CHAR_TYPE; /* \031 */
	probe_scan_data.pl1_char_type (26) = ILLEGAL_CHAR_TYPE; /* \032 */
	probe_scan_data.pl1_char_type (27) = ILLEGAL_CHAR_TYPE; /* \033 */
	probe_scan_data.pl1_char_type (28) = ILLEGAL_CHAR_TYPE; /* \034 */
	probe_scan_data.pl1_char_type (29) = ILLEGAL_CHAR_TYPE; /* \035 */
	probe_scan_data.pl1_char_type (30) = ILLEGAL_CHAR_TYPE; /* \036 */
	probe_scan_data.pl1_char_type (31) = ILLEGAL_CHAR_TYPE; /* \037 */
	probe_scan_data.pl1_char_type (32) = WHITE_SPACE_CHAR_TYPE; /* \040  <SPACE> */
	probe_scan_data.pl1_char_type (33) = ILLEGAL_CHAR_TYPE; /* \041  ! */
	probe_scan_data.pl1_char_type (34) = QUOTE_CHAR_TYPE; /* \042  " */
	probe_scan_data.pl1_char_type (35) = ILLEGAL_CHAR_TYPE; /* \043  # */
	probe_scan_data.pl1_char_type (36) = OTHER_LETTER_CHAR_TYPE; /* \044   $ */
	probe_scan_data.pl1_char_type (37) = OTHER_LETTER_CHAR_TYPE; /* \045  % */
	probe_scan_data.pl1_char_type (38) = OTHER_OPS_CHAR_TYPE; /* \046  & */
	probe_scan_data.pl1_char_type (39) = ILLEGAL_CHAR_TYPE; /* \047 */
	probe_scan_data.pl1_char_type (40) = LEFT_PAREN_CHAR_TYPE; /* \050 */
	probe_scan_data.pl1_char_type (41) = RIGHT_PAREN_CHAR_TYPE; /* \051 */
	probe_scan_data.pl1_char_type (42) = OTHER_OPS_CHAR_TYPE; /* \052 */
	probe_scan_data.pl1_char_type (43) = PLUS_CHAR_TYPE; /* \053 */
	probe_scan_data.pl1_char_type (44) = OTHER_OPS_CHAR_TYPE; /* \054 , */
	probe_scan_data.pl1_char_type (45) = MINUS_CHAR_TYPE; /* \055 */
	probe_scan_data.pl1_char_type (46) = DOT_CHAR_TYPE; /* \056 */
	probe_scan_data.pl1_char_type (47) = OTHER_OPS_CHAR_TYPE; /* \057 / */
	probe_scan_data.pl1_char_type (48) = ZERO_CHAR_TYPE; /* \060  0 */
	probe_scan_data.pl1_char_type (49) = RADIX_DIGITS_CHAR_TYPE; /* \061 */
	probe_scan_data.pl1_char_type (50) = RADIX_DIGITS_CHAR_TYPE; /* \062 */
	probe_scan_data.pl1_char_type (51) = RADIX_DIGITS_CHAR_TYPE; /* \063 */
	probe_scan_data.pl1_char_type (52) = RADIX_DIGITS_CHAR_TYPE; /* \064 */
	probe_scan_data.pl1_char_type (53) = OCTAL_DIGITS_CHAR_TYPE; /* \065 */
	probe_scan_data.pl1_char_type (54) = OCTAL_DIGITS_CHAR_TYPE; /* \066 */
	probe_scan_data.pl1_char_type (55) = OCTAL_DIGITS_CHAR_TYPE; /* \067 */
	probe_scan_data.pl1_char_type (56) = OTHER_DIGITS_CHAR_TYPE; /* \070 */
	probe_scan_data.pl1_char_type (57) = OTHER_DIGITS_CHAR_TYPE; /* \071 */
	probe_scan_data.pl1_char_type (58) = COLON_CHAR_TYPE; /* \072 */
	probe_scan_data.pl1_char_type (59) = OTHER_OPS_CHAR_TYPE; /* \073 */
	probe_scan_data.pl1_char_type (60) = LESS_CHAR_TYPE; /* \074 */
	probe_scan_data.pl1_char_type (61) = EQUAL_CHAR_TYPE; /* \075 */
	probe_scan_data.pl1_char_type (62) = GREATER_CHAR_TYPE; /* \076 */
	probe_scan_data.pl1_char_type (63) = OTHER_OPS_CHAR_TYPE; /* \077 */
	probe_scan_data.pl1_char_type (64) = ILLEGAL_CHAR_TYPE; /* \100 */
	probe_scan_data.pl1_char_type (65) = OTHER_LETTER_CHAR_TYPE; /* \101  A */
	probe_scan_data.pl1_char_type (66) = OTHER_LETTER_CHAR_TYPE; /* \102  B */
	probe_scan_data.pl1_char_type (67) = OTHER_LETTER_CHAR_TYPE; /* \103  C */
	probe_scan_data.pl1_char_type (68) = OTHER_LETTER_CHAR_TYPE; /* \104 */
	probe_scan_data.pl1_char_type (69) = OTHER_LETTER_CHAR_TYPE; /* \105 */
	probe_scan_data.pl1_char_type (70) = OTHER_LETTER_CHAR_TYPE; /* \106 */
	probe_scan_data.pl1_char_type (71) = OTHER_LETTER_CHAR_TYPE; /* \107 */
	probe_scan_data.pl1_char_type (72) = OTHER_LETTER_CHAR_TYPE; /* \110 */
	probe_scan_data.pl1_char_type (73) = OTHER_LETTER_CHAR_TYPE; /* \111 */
	probe_scan_data.pl1_char_type (74) = OTHER_LETTER_CHAR_TYPE; /* \112 */
	probe_scan_data.pl1_char_type (75) = OTHER_LETTER_CHAR_TYPE; /* \113 */
	probe_scan_data.pl1_char_type (76) = OTHER_LETTER_CHAR_TYPE; /* \114 */
	probe_scan_data.pl1_char_type (77) = OTHER_LETTER_CHAR_TYPE; /* \115 */
	probe_scan_data.pl1_char_type (78) = OTHER_LETTER_CHAR_TYPE; /* \116 */
	probe_scan_data.pl1_char_type (79) = OTHER_LETTER_CHAR_TYPE; /* \117 */
	probe_scan_data.pl1_char_type (80) = OTHER_LETTER_CHAR_TYPE; /* \120 */
	probe_scan_data.pl1_char_type (81) = OTHER_LETTER_CHAR_TYPE; /* \121 */
	probe_scan_data.pl1_char_type (82) = OTHER_LETTER_CHAR_TYPE; /* \122 */
	probe_scan_data.pl1_char_type (83) = OTHER_LETTER_CHAR_TYPE; /* \123 */
	probe_scan_data.pl1_char_type (84) = OTHER_LETTER_CHAR_TYPE; /* \124 */
	probe_scan_data.pl1_char_type (85) = OTHER_LETTER_CHAR_TYPE; /* \125 */
	probe_scan_data.pl1_char_type (86) = OTHER_LETTER_CHAR_TYPE; /* \126 */
	probe_scan_data.pl1_char_type (87) = OTHER_LETTER_CHAR_TYPE; /* \127 */
	probe_scan_data.pl1_char_type (88) = OTHER_LETTER_CHAR_TYPE; /* \130 */
	probe_scan_data.pl1_char_type (89) = OTHER_LETTER_CHAR_TYPE; /* \131 */
	probe_scan_data.pl1_char_type (90) = OTHER_LETTER_CHAR_TYPE; /* \132 */
	probe_scan_data.pl1_char_type (91) = OTHER_OPS_CHAR_TYPE; /* \133 */
	probe_scan_data.pl1_char_type (92) = ILLEGAL_CHAR_TYPE; /* \134 */
	probe_scan_data.pl1_char_type (93) = OTHER_OPS_CHAR_TYPE; /* \135 */
	probe_scan_data.pl1_char_type (94) = NOT_CHAR_TYPE; /* \136 */
	probe_scan_data.pl1_char_type (95) = OTHER_LETTER_CHAR_TYPE; /* \137 */
	probe_scan_data.pl1_char_type (96) = ILLEGAL_CHAR_TYPE; /* \140 */
	probe_scan_data.pl1_char_type (97) = OTHER_LETTER_CHAR_TYPE; /* \141  a */
	probe_scan_data.pl1_char_type (98) = LETTER_B_CHAR_TYPE; /* \142 */
	probe_scan_data.pl1_char_type (99) = OTHER_LETTER_CHAR_TYPE; /* \143 */
	probe_scan_data.pl1_char_type (100) = OTHER_LETTER_CHAR_TYPE; /* \144 */
	probe_scan_data.pl1_char_type (101) = LETTER_E_CHAR_TYPE; /* \145 */
	probe_scan_data.pl1_char_type (102) = LETTER_F_CHAR_TYPE; /* \146 */
	probe_scan_data.pl1_char_type (103) = OTHER_LETTER_CHAR_TYPE; /* \147 */
	probe_scan_data.pl1_char_type (104) = OTHER_LETTER_CHAR_TYPE; /* \150 */
	probe_scan_data.pl1_char_type (105) = LETTER_I_CHAR_TYPE; /* \151 */
	probe_scan_data.pl1_char_type (106) = OTHER_LETTER_CHAR_TYPE; /* \152 */
	probe_scan_data.pl1_char_type (107) = OTHER_LETTER_CHAR_TYPE; /* \153 */
	probe_scan_data.pl1_char_type (108) = OTHER_LETTER_CHAR_TYPE; /* \154 */
	probe_scan_data.pl1_char_type (109) = OTHER_LETTER_CHAR_TYPE; /* \155 */
	probe_scan_data.pl1_char_type (110) = OTHER_LETTER_CHAR_TYPE; /* \156 */
	probe_scan_data.pl1_char_type (111) = LETTER_O_CHAR_TYPE; /* \157 */
	probe_scan_data.pl1_char_type (112) = OTHER_LETTER_CHAR_TYPE; /* \160 */
	probe_scan_data.pl1_char_type (113) = OTHER_LETTER_CHAR_TYPE; /* \161 */
	probe_scan_data.pl1_char_type (114) = OTHER_LETTER_CHAR_TYPE; /* \162 */
	probe_scan_data.pl1_char_type (115) = OTHER_LETTER_CHAR_TYPE; /* \163 */
	probe_scan_data.pl1_char_type (116) = OTHER_LETTER_CHAR_TYPE; /* \164 */
	probe_scan_data.pl1_char_type (117) = OTHER_LETTER_CHAR_TYPE; /* \165 */
	probe_scan_data.pl1_char_type (118) = OTHER_LETTER_CHAR_TYPE; /* \166 */
	probe_scan_data.pl1_char_type (119) = OTHER_LETTER_CHAR_TYPE; /* \167 */
	probe_scan_data.pl1_char_type (120) = OTHER_LETTER_CHAR_TYPE; /* \170 */
	probe_scan_data.pl1_char_type (121) = OTHER_LETTER_CHAR_TYPE; /* \171 */
	probe_scan_data.pl1_char_type (122) = OTHER_LETTER_CHAR_TYPE; /* \172 */
	probe_scan_data.pl1_char_type (123) = ILLEGAL_CHAR_TYPE; /* \173 */
	probe_scan_data.pl1_char_type (124) = VERTICAL_BAR_CHAR_TYPE; /* \174 */
	probe_scan_data.pl1_char_type (125) = ILLEGAL_CHAR_TYPE; /* \175 */
	probe_scan_data.pl1_char_type (126) = ILLEGAL_CHAR_TYPE; /* \176 */
	probe_scan_data.pl1_char_type (127) = ILLEGAL_CHAR_TYPE; /* \177 */


     end set_char_types;


%include cds_args;


/* ;;;;;;; */

%include probe_operators;

%include probe_scan_dcls;

     end probe_scan_data_;




		    probe_scan_input_.pl1           10/27/88  1250.2r w 10/27/88  1224.8      299394



/****^  ***********************************************************
        *                                                         *
        * 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-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Modified code in the internal procedure 'build_operator_from_char' to
     evaluate the * character. The * character may be either the TIMES operator
     or the C_INDIRECTION operator. The operator type is resolved based on the
     previous token.
  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_scan_input_:
  procedure (P_probe_info_ptr, P_input_ptr, P_input_lth, P_area_ptr,
       P_language_type,
       P_input_used_lth, P_first_token, P_code);

  /* * 11 Sep 81, S. Herbst:
   *    Changed to handle virtual entries of the form path|N.
   * 05 Oct 81, S. Herbst:
   *    Changed to handle regular expressions.
   * 01 Dec 81, S. Herbst:
   *    Fixed to report illegal char correctly.
   * 18 Oct 82, S. Herbst:
   *    Fixed to handle regular expression containing quotes.
   * ?? Jun 83, JMAthane:
   *    To add PASCAL.
   * 27 Jul 83, S. Herbst:
   *    Changed to accomodate new COLON_CHAR_TYPE, translate Pascal ".." 
   *    to colon.
   * 08 Aug 83, S. Herbst:
   *    Fixed to put current executiogn ring number in createdSSS|OOO
   *    value.
   * 15 Feb 84, S. Herbst:
   *    Fixed to allow dots in entry names when running FORTRAN.
   * 09 Mar 84, S. Herbst:
   *    Changed to allow ".." as double operator anywhere in line.
   * 30 Mar 84, S. Herbst:
   *    Made to save the input ptr & len in probe_info.buffer_(ptr lth).
   * 20 Sep 84, S. Herbst:
   *    Fixed to put -'s in COBOL identifiers, not translate them to _'s.
   * ?? Apr 88, C. Hinatsu:
   *    To add C operators.
   * */

  /* *	Input string scanner for probe debugger.
   Initially coded sometime in the past as part of probe main procedure, J. M. Broughton.
   Split off into external procedure for added versatility, 04/21/79 W. Olin Sibert.
   made  trilingual (and a lot prettier, if I say so myself) JRDavis 3 Aug 79
   bug fixes JRD 7 Feb 80
   extended ptr constants, sp|NNN, lp|NNN, tp|NNN JRD 8 Mar 80 */

  /* This procedure converts an input string into probe tokens. It reads 
 * up to the first statement delimiter, and returns a pointer to       
 * a chain of tokens allocated in the caller-supplied area. It can     
 * return an error code if it encounters a syntax error, or if it runs 
 * out of input string without hitting a plausible delimiter.          
 *                                                                     
 * Arguments:                                                          
 *                                                                     
 * P_probe_info_ptr                                                    
 *   is a pointer to the probe_info structure for this invocation of
 *   probe.
 *
 * P_input_ptr
 *   is a pointer to the start of the input string.
 *
 * P_input_lth
 *   is the length of the input string.
 *
 * P_area_ptr
 *   is a pointer to an area in which the scanner will allocate tokens.
 *
 * P_language_type
 *   is the language type for scanning.
 *
 * P_input_used_lth (Output)
 *   is the count of characters read from the input string; in the case of most
 *   errors, it will be zero; otherwise, it is the index of the unhappy 
 *   character.
 *
 * P_first_token (Output)
 *   is a pointer to the first token in the chain allocated by this procedure.
 *
 * P_code (Output)
 *   is an error code; a value of zero indicates that all has gone well, and 
 *   any other value indicates an error, except for 
 *   probe_et_$input_exhausted, which indicates that we ran out of 
 *   input prematurely.
 */
%page;
  dcl (
      P_probe_info_ptr	pointer,
      P_input_ptr		pointer,	/* pointer to input buffer */
      P_input_lth		fixed bin (21),
				/* length of input buffer */
      P_area_ptr		pointer,	/* pointer to working area for token allocations, etc. */
      P_language_type	fixed bin (21),
				/* type of language syntax, for parsing */
      P_input_used_lth	fixed bin (21),
				/* (Output) count of chars used from input buffer */
      P_first_token		pointer,	/* (Output) pointer to first token in our output chain */
      P_code		fixed bin (35)
      )			parameter;/* (Output) error code */


  /* IMPORTANT VARIABLES */

  dcl Cur_state		fixed bin,/* what state we are in (computational, not political) */
      Cur_pos		fixed bin (21),
				/* index into Input_str of current char */
      Cur_char		char (1) aligned,
				/* the char we are now parsing */
      Char_type		fixed bin;/* what kind of char it is */
  dcl First_token		ptr;	/* to the first token we allocate */
  dcl Last_token		ptr;	/* to the last token we allocated */
  dcl Paren_level		fixed bin;/* keep count of ((()())) */
  dcl Token_pos		fixed bin (21);
				/* where in buffer the chars of the token begin */

  dcl regexp_sw		bit (1) aligned;
				/* inside /regular expression/ instead of quoted string */

  dcl (ptr_segno, ptr_wordno, ptr_offset, ptr_bitno)
			fixed bin;/* used in building ptr constants */
  dcl i			fixed bin;/* every program needs one of these */
  dcl code		fixed bin (35);

  dcl token_area		area based (token_area_ptr);
				/* where we do our work */
  dcl token_area_ptr	pointer;

  dcl input_string		char (input_string_lth)
			based (input_string_ptr);
  dcl input_string_ptr	pointer;
  dcl input_string_lth	fixed bin (21);

  dcl string_buffer		character (256) varying aligned;
				/* place to put strings while building them */

  dcl char_type		(0:127) fixed bin (17) unaligned
			based (char_type_ptr);
				/* the char type array we use */
  dcl char_type_ptr		ptr;
  dcl action_table		(14, 0:27) fixed bin (17) unaligned
			based (action_table_ptr);
				/* the all-important table */
  dcl action_table_ptr	ptr;


  dcl (
      probe_scan_data_$pl1_char_type,	/* char_types for three languages */
      probe_scan_data_$fortran_char_type,
      probe_scan_data_$pascal_char_type,
      probe_scan_data_$cobol_char_type,
      probe_scan_data_$c_char_type
      )			(0:127) fixed bin (17) unaligned external
			static;

  dcl (
      probe_scan_data_$pl1_action_table,
      probe_scan_data_$fortran_action_table,
      probe_scan_data_$pascal_action_table,
      probe_scan_data_$cobol_action_table,
      probe_scan_data_$c_action_table
      )			(14, 0:27) fixed bin (17) unaligned
			external static;

  dcl probe_scan_data_$operator_type
			(0:127) fixed bin (17) unaligned external
			static;

  dcl 1 probe_scan_data_$doubles
			(13) external static,
       2 pair		char (2),
       2 type		fixed bin;

  dcl 1 probe_scan_data_$fort_ops
			(9) external static,
       2 name		char (4) aligned,
       2 op_code		fixed bin;

  dcl 1 probe_scan_data_$pasc_ops
			(3) external static,
       2 name		char (4) aligned,
       2 op_code		fixed bin;


  dcl (
      probe_et_$recorded_message,
      probe_et_$unbalanced_parens,
      probe_et_$string_long,
      probe_et_$illegal_char
      )			fixed bin (35) external static;

  dcl CR			char (1) aligned internal static
			options (constant) init ("
");


  dcl (cv_dec_check_, cv_oct_check_)
			entry (char (*), fixed bin (35))
			returns (fixed bin (35));
  dcl get_ring_		entry returns (fixed bin (3));
  dcl probe_error_$record	entry options (variable);

  dcl (addr, baseno, bin, binary, bit, divide, fixed, hbound, index, length,
      maxlength)		builtin;
  dcl (mod, null, pointer, rank, rel, reverse, substr, translate, unspec)
			builtin;
%page;
  P_code = 0;
  code = 0;
  probe_info_ptr = P_probe_info_ptr;

  input_string_ptr, probe_info.buffer_ptr = P_input_ptr;
  input_string_lth, probe_info.buffer_lth = P_input_lth;

  token_area_ptr = P_area_ptr;

  if P_language_type = FORTRAN_lang_type then do;
				/* select proper tables */
      char_type_ptr = addr (probe_scan_data_$fortran_char_type);
      action_table_ptr = addr (probe_scan_data_$fortran_action_table);
    end;
  else if P_language_type = COBOL_lang_type then do;
      char_type_ptr = addr (probe_scan_data_$cobol_char_type);
      action_table_ptr = addr (probe_scan_data_$cobol_action_table);
    end;
  else if P_language_type = PASCAL_lang_type then do;
      char_type_ptr = addr (probe_scan_data_$pascal_char_type);
      action_table_ptr = addr (probe_scan_data_$pascal_action_table);
    end;
  else if P_language_type = C_lang_type then do;
      char_type_ptr = addr (probe_scan_data_$c_char_type);
      action_table_ptr = addr (probe_scan_data_$c_action_table);
    end;
  else do;
    char_type_ptr = addr (probe_scan_data_$pl1_char_type);
    action_table_ptr = addr (probe_scan_data_$pl1_action_table);
  end;


  First_token = null ();
  Last_token = null ();
  Paren_level = 0;

  Cur_state = NULL_STATE;





  /* ***** FINITE STATE MACHINE ***** */


  do Cur_pos = 1 to length (input_string);

    Cur_char = substr (input_string, Cur_pos, 1);
    if rank (Cur_char) > hbound (char_type, 1)
      then Char_type = ILLEGAL_CHAR_TYPE;
      else Char_type = char_type (rank (Cur_char));

    /* Can come here after an action has changed states to re-interpret Cur_char in new state */

REPROC:
    goto ACTION (action_table (Cur_state, Char_type));

AR:				/* most actions jump back here when done */

  end;

  /* if last char wasn't a new-line, pretend we have another one-

   this is a bit of a kludge, because all routines jump back to AR or REPROC.
   But we have do do it, so that numbers and identifiers get finished off.
   And we can't just stick a NL after the string.
   Fortunately, nobody is looking at Cur_pos, because this pseduo-CR has no valid position.
*/

  if Cur_char ^= CR then do;
      Cur_char = CR;
      Char_type = char_type (rank (Cur_char));
      goto REPROC;
    end;

  /* once that's done, we can check for unbalanced parens, quotes,  dot-operators, etc. */

  if Paren_level ^= 0
    then call LOSS (probe_et_$unbalanced_parens);
  if Cur_state = STRING_STATE then do;
      if regexp_sw
        then call probe_error_$record (probe_info_ptr, 0,
	        "No closing / for regular expression.");
        else call probe_error_$record (probe_info_ptr, 0, "Unbalanced quotes")
	        ;
      goto RECORDED_MESSAGE;
    end;

  if Cur_state = IN_DOT_OP_STATE then do;
      call probe_error_$record (probe_info_ptr, 0,
	 "Ends in an incomplete FORTRAN logical operator or constant");
      goto RECORDED_MESSAGE;
    end;

EXIT:				/* all returns come through here */
  P_code = code;
  P_input_used_lth = Cur_pos;		/* fencepost maybe possible ?? */
  P_first_token = First_token;

MAIN_RETURN:

  return;

LOSS:
  proc (ecode);			/* call me to set error and return */
  dcl ecode		fixed bin (35) parameter;
  code = ecode;
  Cur_pos = 0;			/* show our disgust */
  goto EXIT;
  end LOSS;

RECORDED_MESSAGE:
  code = probe_et_$recorded_message;
  goto EXIT;

  /* NOW COME THE ACTIONS - begining on next page  */

ACTION (1):			/* when white space is seen in NULL state, it means
						   that previous token was followed by white - set its flag */
  if Last_token ^= null ()
    then Last_token -> token.header.flags.trailing_whitespace = "1"b;

  goto AR;



ACTION (11):			/* a left paren */
  Paren_level = Paren_level + 1;
  Token_pos = Cur_pos;
  call build_operator_from_char (Cur_char);
  goto AR;


ACTION (12):			/* right paren */
  Paren_level = Paren_level - 1;
  if Paren_level < 0
    then call LOSS (probe_et_$unbalanced_parens);
  Token_pos = Cur_pos;
  call build_operator_from_char (Cur_char);
  goto AR;



ACTION (13):			/* random ops */
  Token_pos = Cur_pos;
  if Cur_char = "/" & Last_token = First_token then do;
				/* "/" right after the request name */
      Cur_state = STRING_STATE;	/* starts a regular expression */
      regexp_sw = "1"b;
      string_buffer = "/";
    end;
    else call build_operator_from_char (Cur_char);
  goto AR;



ACTION (14):			/* a dot */
  Cur_state = DOT_SEEN_STATE;
  Token_pos = Cur_pos;
  goto AR;



ACTION (15):			/* first op of a possible double op series */
  string_buffer = Cur_char;		/* save it */
  Cur_state = POSSIBLE_DOUBLE_STATE;
  Token_pos = Cur_pos;
  goto AR;



ACTION (16):			/* PASCAL_ARROW char encountered in NULL STATE */
  Token_pos = Cur_pos;
  call build_operator (bin (substr (PASCAL_ARROW, 13)));
  go to AR;

ACTION (20):			/* a digit - starts a number */
  Cur_state = NUMBER_PRE_DOT_STATE;
  Token_pos = Cur_pos;
  string_buffer = Cur_char;
  goto AR;


ACTION (21):			/* saw a dot then a number */
  Cur_state = NUMBER_POST_DOT_STATE;
  string_buffer = ".";
  call append (Cur_char);
  goto AR;


ACTION (22):			/* more numbers */
  call append (Cur_char);
  goto AR;


ACTION (23):			/* something that can't go in a number */
  call build_number;		/* finish the number */
  Cur_state = NULL_STATE;
  goto REPROC;			/* re-interpret the char */


ACTION (24):			/* a dot in middle */
  call append (Cur_char);
  Cur_state = NUMBER_POST_DOT_STATE;
  goto AR;


ACTION (25):			/* sign is part of exponent */
  Cur_state = NUMBER_EXP2_STATE;	/* only one + or - per exponnet, tho */
  call append (Cur_char);
  goto AR;

ACTION (26):			/* saw an "e" or an "f" build exponent */
  call append (Cur_char);
  Token_pos = Cur_pos;
  Cur_state = NUMBER_EXP1_STATE;
  goto AR;


ACTION (27):			/* an i - end of number */
  call append (Cur_char);
  call build_number;
  Cur_state = NULL_STATE;
  goto AR;


ACTION (28):			/* an "o" - interp as octal */
  call build_octal;
  Cur_state = NULL_STATE;
  goto AR;

ACTION (30):			/* name begins */
  Cur_state = NAME_STATE;
  Token_pos = Cur_pos;
  string_buffer = Cur_char;
  goto AR;

ACTION (31):			/* name continues */
  call append (Cur_char);
  goto AR;


ACTION (32):			/* name ends */
  if P_language_type = PASCAL_lang_type then do;
      do i = 1 to hbound (probe_scan_data_$pasc_ops, 1);
        if probe_scan_data_$pasc_ops (i).name = string_buffer then do;
	  call build_operator (probe_scan_data_$pasc_ops (i).op_code);
	  Cur_state = NULL_STATE;
	  goto REPROC;
	end;
      end;
    end;
  call build_name;
  Cur_state = NULL_STATE;
  goto REPROC;

ACTION (36):			/* have hyphen in COBOL mode */
  call append ("-");
  goto AR;			/* treat it same as an underscore */

ACTION (40):			/* begin quoted */
  Cur_state = STRING_STATE;
  regexp_sw = "0"b;
  Token_pos = Cur_pos;
  string_buffer = "";
  goto AR;


ACTION (41):			/* anything but quote */
  call append (Cur_char);
  if Cur_char = "/" & regexp_sw then do;/* another slash inside regular expression */
      if length (string_buffer) > 2
        then
	   if substr (string_buffer, length (string_buffer) - 2, 2) = "\c"
	     then go to AR;		/* literal slash */
      Cur_state = QUOTE_SEEN_STATE;
    end;
  goto AR;


ACTION (42):
  if regexp_sw
    then call append (Cur_char);	/* quota means nothing inside regular expression */
    else Cur_state = QUOTE_SEEN_STATE;	/* prepare for end of string */
  goto AR;



ACTION (45):			/* almost anything after a quote is true end */
END_STRING:
  call build_char_string;
  Cur_state = NULL_STATE;
  goto REPROC;


ACTION (46):			/* b after quote - is bit string */
  if regexp_sw
    then go to END_STRING;
  Cur_state = BIT_STR_END_STATE;	/* but what kind? b1? b2? b3? */
  goto AR;			/* we'll find out next char */


ACTION (47):			/* o after ", is octal string */
  if regexp_sw
    then go to END_STRING;
  call build_bit_string (3);		/* radix 3 */
  Cur_state = NULL_STATE;
  goto AR;


ACTION (48):			/* another quote - is quote doubling */
  if regexp_sw
    then go to END_STRING;
  call append (Cur_char);
  Cur_state = STRING_STATE;
  goto AR;

ACTION (50):			/* a digit from 1 to 4 after  "b */
  call build_bit_string (fixed (Cur_char));
  Cur_state = NULL_STATE;
  goto AR;


ACTION (51):			/* anthing else after "b default radix is 1 */
  call build_bit_string (1);
  Cur_state = NULL_STATE;
  goto REPROC;








ACTION (55):			/* after a dot, a non-letter */
  call build_operator_from_char (".");
  Cur_state = NULL_STATE;
  goto REPROC;


ACTION (56):			/* letter after dot (FORTRAN only ) */
  Cur_state = IN_DOT_OP_STATE;
  string_buffer = Cur_char;
  goto AR;


ACTION (57):			/* a letter in DOT_OP_STATE */
  call append (Cur_char);
  goto AR;


ACTION (58):			/* final dot delimts */
  do i = 1 to hbound (probe_scan_data_$fort_ops, 1);
    if probe_scan_data_$fort_ops (i).name = string_buffer then do;
FORTRAN_DOT_OPERATOR:
        call build_dot;
        Cur_state = NULL_STATE;
        go to AR;
      end;
  end;
  if string_buffer = "true" | string_buffer = "false"
    then go to FORTRAN_DOT_OPERATOR;
  go to NOT_FORTRAN_DOT_OPERATOR;


ACTION (59):			/* .foo<not .> might be an entryname (FORTRAN) */
NOT_FORTRAN_DOT_OPERATOR:
  call append (Cur_char);
  call build_name;
  Cur_state = NULL_STATE;
  go to REPROC;

ACTION (60):			/* ptr begins with | after digits */
  ptr_segno = cv_oct_check_ ((string_buffer), code);
  if code ^= 0
    then call segno_err (substr (string_buffer, code, 1));
  ptr_wordno, ptr_bitno, ptr_offset = 0;
  string_buffer = "";
  Cur_state = PTR_WORD_STATE;
  goto AR;


ACTION (61):			/* digits for wordno or bitno */
  call append (Cur_char);
  goto AR;


ACTION (62):			/* paren begins bit offset */
  ptr_wordno = cv_oct_check_ ((string_buffer), code);
  if code ^= 0
    then call wordno_err (substr (string_buffer, code, 1));
  string_buffer = "";
  Cur_state = PTR_BIT_STATE;
  goto AR;


ACTION (63):			/* right paren ends bit offset */
  ptr_bitno = cv_dec_check_ ((string_buffer), code);
  if code ^= 0
    then call bitno_err (substr (string_buffer, code, 1));

  call build_pointer;
  Cur_state = NULL_STATE;
  goto AR;


ACTION (64):			/* other char, while in word no */
  ptr_wordno = cv_oct_check_ ((string_buffer), code);
  if code ^= 0
    then call wordno_err (substr (string_buffer, code, 1));
  call build_pointer;
  Cur_state = NULL_STATE;
  goto REPROC;

ACTION (65):			/* vertical bar after name */
  begin;
    dcl init_ptr		  ptr;
    if string_buffer = "sp"
      then init_ptr = current_source.stack_ptr;
    else if string_buffer = "lp"
      then init_ptr = current_source.seg_info_ptr -> seg_info.linkage_ptr;
    else if string_buffer = "tp"
      then init_ptr = pointer (current_source.instruction_ptr, 0);
    else if string_buffer = "ip"
      then init_ptr = current_source.instruction_ptr;
    else do;
      call append (Cur_char);		/* a virtual entry of the form path|N */
      go to AR;
    end;

    ptr_segno = binary (baseno (init_ptr), 18);
    ptr_offset = binary (rel (init_ptr), 18);
  end;				/* begin */

  Cur_state = PTR_WORD_STATE;
  string_buffer = "";
  goto AR;

ACTION (70):			/* another char after poss. double op
						   but we dont form a double op */
  call build_operator_from_char (substr (string_buffer, 1, 1));
  Cur_state = NULL_STATE;
  goto REPROC;


ACTION (71):			/* possible double */
  if Cur_state = DOT_SEEN_STATE
    then string_buffer = ".";		/* first dot seen doesn't normally get saved */

  call append (Cur_char);

  if P_language_type = PASCAL_lang_type
       & index (reverse (string_buffer), "..") = 1 then do;
				/* number.. = Pascal range */
      if length (string_buffer) > 2 then do;
	string_buffer =
	     substr (string_buffer, 1, length (string_buffer) - 2);
	call build_number;
        end;
      call build_operator_from_char (":");
				/* Pascal ".." becomes cross-section */
      Cur_state = NULL_STATE;
      go to AR;
    end;

  do i = 1 to hbound (probe_scan_data_$doubles, 1);
    if string_buffer = probe_scan_data_$doubles (i).pair then do;
        if string_buffer = ".." & P_language_type = PASCAL_lang_type
	then
	     call build_operator_from_char (":");
				/* Pascal ".." becomes cross-section */
	else call build_operator (probe_scan_data_$doubles (i).type);
        Cur_state = NULL_STATE;
        goto AR;
      end;
  end;
  call build_operator_from_char (substr (string_buffer, 1, 1));
  Token_pos = Cur_pos;
  call build_operator_from_char (Cur_char);
  Cur_state = NULL_STATE;
  goto AR;



  /* Action Specific for C to handle the address (&) and mod (%) operators */


  /* ACTION (80): */



  /* THESE ARE ERROR ACTIONS */


ACTION (90):
  call probe_error_$record (probe_info_ptr, 0,
       "Too many decimal points in number (after: ""^a"")", string_buffer);
  goto RECORDED_MESSAGE;


ACTION (91):
  call probe_error_$record (probe_info_ptr, 0,
       "Syntax error in segment number of pointer constant");
  goto RECORDED_MESSAGE;



ACTION (92):
  call probe_error_$record (probe_info_ptr, 0,
       "Bad character in number: ^a after ^a",
       safety (Cur_char), string_buffer);
  goto RECORDED_MESSAGE;


ACTION (93):
  call wordno_err (Cur_char);
  goto RECORDED_MESSAGE;


ACTION (95):
  call bitno_err (Cur_char);
  goto RECORDED_MESSAGE;



ACTION (99):
  call probe_error_$record (probe_info_ptr, probe_et_$illegal_char, "^a",
       safety (Cur_char));
  goto RECORDED_MESSAGE;



wordno_err:
  proc (c);
  dcl c			char (1) aligned parameter;
  call probe_error_$record (probe_info_ptr, 0,
       "Non octal char in word offset of pointer constant: ^a", safety (c));
  goto RECORDED_MESSAGE;

segno_err:
  entry (c);
  call probe_error_$record (probe_info_ptr, 0,
       "Non octal char in segment number of pointer constant: ^a", safety (c))
       ;
  goto RECORDED_MESSAGE;


bitno_err:
  entry (c);
  call probe_error_$record (probe_info_ptr, 0,
       "Non decimal char in bit offset of pointer constant: ^a", safety (c));
  goto RECORDED_MESSAGE;
  end;


safety:
  proc (cc) returns (char (6) aligned);
  dcl cc			char (1) aligned parameter;
  dcl (digit1, digit2, digit3, ncc)
			fixed;
  dcl rsc			char (6) aligned;
  dcl ioa_$rsnnl		entry options (variable);

  dcl printable_chars	char (94) internal static
			options (constant) init
			(
			"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789,<.>/?;+:*`@_}]~^-=)('&%$#""!{[|\"
			);

  ncc = rank (cc);
  digit1 = divide (ncc, 64, 17, 0);
  ncc = ncc - digit1 * 64;
  digit2 = divide (ncc, 8, 17, 0);
  digit3 = ncc - digit2 * 8;
  call ioa_$rsnnl ("""^[^a^3s^;^s\^d^d^d^]""", rsc, (0),
       index (printable_chars, cc) > 0, cc, digit1, digit2, digit3);
  return (rsc);
  end safety;


append:
  proc (c);
  dcl c			char (1) aligned parameter;

  if length (string_buffer) = maxlength (string_buffer)
    then call LOSS (probe_et_$string_long);
  string_buffer = string_buffer || c;
  end append;


  /* CONSTRUCTORS  called to build tokens and thread them on.  They often take input in
   string_buffer, and convert it to right thing.

   build_operator (op_type)
   build_operator_from_char (op_char)
   build_name
   build_char_string
   build_bit_string(radix)
   build_dot
   build_number
   build_octal
   build_pointer

*/

build_operator_from_char:
  proc (op_name);
  dcl op_name		char (1) aligned parameter;
  dcl a			ptr;	/* to the op we allocate */
  dcl op_type		fixed bin;

  op_type = probe_scan_data_$operator_type (rank (op_name));

  goto com;

build_operator:
  entry (pop_type);
  dcl pop_type		fixed bin parameter;

  op_type = pop_type;

com:

  allocate operator in (token_area) set (a);
  call init_token (a);

  a -> token.header.type = OPERATOR_TYPE | bit (fixed (op_type, 18));

  call thread (a);

  /* Here we try to account for the C indirection. eg 'v *tempstr'. We don't
   want to multiply, we want to get the value of whatever tempstr is 
   pointing to. If the previous token is an operator, then the '*' is 
   assumed to mean indirection.  If the previous token is a right 
   paren then the '*' is assumed to be the TIMES operator. */

  if (a -> token.type = TIMES) & (P_language_type = C_lang_type) then do;
      if (Last_token -> token.header.prev ^= null ()) then do;
	if (((Last_token -> token.header.prev -> token.header.type
	     > OPERATOR_TYPE) &
	     (Last_token -> token.header.prev -> token.header.type
	     ^= RIGHT_PAREN) &
	     (Last_token -> token.header.prev -> token.header.type
	     ^= RIGHT_BRACKET)) |
	     (Last_token -> token.header.prev -> token.header.prev = null))
	  then
	       a -> token.header.type = C_INDIRECTION;
        end;
        else a -> token.header.type = C_INDIRECTION;
    end;
				/*
          else if (a->token.type = ARROW) & (Planguage_type = C_lang_type) then
	    a->token.header.type = PERIOD;
*/

  end;


build_name:
  proc;
  dcl a			ptr;

  allocate identifier in (token_area) set (a);
  call init_token (a);

  a -> token.header.type = NAME_TYPE;
  a -> identifier.name = ptr_to_nth_char (Token_pos);
  a -> identifier.length = length (string_buffer);
  call thread (a);

  return;

ptr_to_nth_char:
  proc (cp) returns (ptr);
  dcl cp			fixed bin (21) parameter;
  dcl char_array		(input_string_lth) char (1) unal
			based (input_string_ptr);
  return (addr (char_array (cp)));
  end ptr_to_nth_char;
  end build_name;


build_char_string:
  proc;

  dcl a			ptr;
  dcl based_chars		char (char_len) based;
  dcl char_len		fixed bin (21);

  a = new_constant (char_dtype * 2);
  a -> constant.scale = 0;
  char_len,
       a -> constant.precision,
       a -> constant.scale_and_precision = length (string_buffer);

  allocate based_chars in (token_area) set (a -> constant.data_ptr);

  a -> constant.data_ptr -> based_chars = string_buffer;

  call thread (a);
  end build_char_string;


build_bit_string:
  proc (radix);
  dcl radix		fixed bin parameter;
  dcl a			ptr;
  dcl based_bits		bit (bit_len) based;
  dcl bit_len		fixed bin (24);

  a = new_constant (bit_dtype * 2);
  a -> constant.encoded_precision.scale = 0;
  bit_len, a -> constant.encoded_precision.precision,
       a -> constant.scale_and_precision = length (string_buffer) * radix;

  allocate based_bits in (token_area) set (a -> constant.data_ptr);

convert_chars_to_bit:
  begin;

    dcl output_index	  fixed bin;
    dcl c			  char (1) aligned;
				/* current char being converted */
    dcl input_index		  fixed bin;
				/* index of c in input_chars */
    dcl fb4		  fixed bin (4);

    dcl radix_chars		  (4) char (16) static internal
			  options (constant)
			  init /*   the chars valid in radix */
			  ("0100000000000000",
				/* we will take index of these */
			  "0123000000000000",
			  "0123456700000000",
			  "0123456789ABCDEF");

    output_index = 1;

    do input_index = 1 to length (string_buffer);
				/* for each char in input */
      c = substr (string_buffer, input_index, 1);
      if radix = 4
        then c = translate (c, "ABCDEF", "abcdef");
				/* hex can be in either case */
      fb4 = index (radix_chars (radix), c) - 1;
				/* "0" has index 1, but "is" 0 */
      if fb4 < 0 then do;
	call probe_error_$record (probe_info_ptr, 0,
	     "Non-^[binary^;quaternary^;octal^;hex^] character ^a in bit string",
	     radix, safety (c));
	goto RECORDED_MESSAGE;
        end;

      /* *	Now fb4 is the number whose bit value is to inserted into the string., that is,
   *	if c is "A" (which implies radix = 4), then fb4 is decimal 10, or "1010"b
   *	For radices lower than four we want  to strip of the leading zeroes. The index
   *	of the first significant bit is given by (5 - radix). */

      substr (a -> constant.data_ptr -> based_bits, output_index, radix) =
	 /* write as many bits as called for */
	 substr (bit (fb4), 5 - radix, radix);
      output_index = output_index + radix;
				/* where next string will begin */
    end;				/* loop through characters */

  end convert_chars_to_bit;		/* begin block */


  call thread (a);
  end build_bit_string;

build_dot:
  proc;
  dcl a			ptr;
  dcl based_logical		bit (1) aligned based;
  dcl i			fixed bin;


  if string_buffer = "true" | string_buffer = "false"
    then do;
      a = new_constant (bit_dtype * 2);
      a -> constant.encoded_precision.scale = 0;
      a -> constant.encoded_precision.precision,
	 a -> constant.scale_and_precision = 1;

      allocate based_logical in (token_area) set (a -> constant.data_ptr);

      if string_buffer = "true"
        then a -> constant.data_ptr -> based_logical = "1"b;
        else a -> constant.data_ptr -> based_logical = "0"b;
      call thread (a);

    end;				/* logical constant */
    else do;			/* hope its an operator */
      do i = 1 to hbound (probe_scan_data_$fort_ops, 1);
        if probe_scan_data_$fort_ops (i).name = string_buffer
	then goto MATCH;
      end;

      /* fell out - bad name */

      call probe_error_$record (probe_info_ptr, 0,
	 """^a"" is not a recognized FORTRAN operator ", string_buffer);
      goto RECORDED_MESSAGE;

MATCH:
      call build_operator (probe_scan_data_$fort_ops (i).op_code);
    end;				/* making operator */
  end build_dot;


build_number:
  proc;

  dcl dtype_found		fixed bin (35);
  dcl scale_prec_found	fixed bin (35);
  dcl temp_target		char (256);
				/* no arith constant can exceed 64 words */
  dcl data_size		fixed bin;/* how many bits data is */
  dcl based_bits		bit (data_size) based;
  dcl a			ptr;
  dcl numbuf		char (128) aligned;
  dcl char_to_numeric_	entry (ptr, fixed bin (35), fixed bin (35), ptr,
			fixed bin);
  dcl get_size_in_bits_	entry (fixed bin, fixed bin (35),
			bit (1) aligned) returns (fixed bin);

  numbuf = string_buffer;
  call char_to_numeric_ (addr (temp_target), dtype_found, scale_prec_found,
       addr (numbuf), length (string_buffer));

  a = new_constant ((dtype_found));
  a -> constant.scale_and_precision = scale_prec_found;
  unspec (a -> constant.encoded_precision) = unspec (scale_prec_found);

  data_size =
       get_size_in_bits_ (divide (dtype_found, 2, 17, 0), scale_prec_found,
       bit (mod (dtype_found, 2)));

  allocate based_bits in (token_area) set (a -> constant.data_ptr);

  a -> constant.data_ptr -> based_bits = addr (temp_target) -> based_bits;

  call thread (a);
  end build_number;


build_octal:
  proc;

  dcl a			ptr;
  dcl code		fixed bin (35);
  dcl based_fixed		fixed bin (35) based;


  a = new_constant (real_fix_bin_1_dtype * 2);

  a -> constant.scale = 0;
  a -> constant.precision, a -> constant.scale_and_precision = 35;

  allocate based_fixed in (token_area) set (a -> constant.data_ptr);

  a -> constant.data_ptr -> based_fixed =
       cv_oct_check_ ((string_buffer), code);
  if code ^= 0 then do;
      call probe_error_$record (probe_info_ptr, 0,
	 "Non octal difgit in ""^a""o", string_buffer);
      goto RECORDED_MESSAGE;
    end;

  call thread (a);
  end build_octal;


build_pointer:
  proc;

  dcl a			ptr;
  dcl based_ptr		based ptr;

  dcl 1 its_you		aligned like its_unsigned;


  unspec (its_you) = "0"b;
  its_you.segno = ptr_segno;
  its_you.offset = ptr_offset + ptr_wordno;
  its_you.bit_offset = ptr_bitno;
  its_you.ringno = get_ring_ ();
  its_you.its_mod = ITS_MODIFIER;

  a = new_constant (pointer_dtype * 2);
  a -> constant.encoded_precision,
       a -> constant.scale_and_precision = 0;

  allocate based_ptr in (token_area) set (a -> constant.data_ptr);
  unspec (a -> constant.data_ptr -> based_ptr) = unspec (its_you);

  call thread (a);
  end build_pointer;


new_constant:
  proc (dt) returns (ptr);
  dcl dt			fixed bin parameter;
  dcl a			ptr;


  allocate constant in (token_area) set (a);
  call init_token (a);
  a -> token.header.type = CONSTANT_TYPE;
  a -> constant.data_type = dt;
  return (a);
  end new_constant;



init_token:
  proc (tp);
  dcl tp			ptr parameter;


  tp -> token.header.next = null ();
  tp -> token.header.prev = Last_token;
  tp -> token.header.buffer_ptr = input_string_ptr;
  tp -> token.header.location = Token_pos;
  tp -> token.header.flags = "0"b;
  if Last_token ^= null ()
    then tp -> token.header.flags.leading_whitespace =
	    Last_token -> token.header.trailing_whitespace;
  end init_token;



thread:
  proc (t);
  dcl t			ptr parameter;


  if First_token = null ()
    then First_token = t;
    else Last_token -> token.next = t;
  Last_token = t;
  end thread;

  /*	INCLUDE FILES		*/

%include probe_info;
%include probe_tokens;
%include probe_lang_types;
%include probe_operators;
%include probe_scan_dcls;
%include probe_source_info;
%include probe_seg_info;

%include std_descriptor_types;
%include encoded_precision;
%include its;

  end probe_scan_input_;




		    probe_seg_info_.pl1             10/27/88  1250.2rew 10/27/88  1221.7      238869



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

/****^  HISTORY COMMENTS:
  1) change(87-05-27,JRGray), approve(87-06-24,MCR7711), audit(87-06-24,Huen),
     install(87-07-15,MR12.1-1040):
     Modified to allow breakpoint in more than one component of a bound module
     at a time (probe 111).
  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.  If the
     'probe_info.entry_method' field is set to 1, we free the previous
     'seg_info', because it may not reflect the current situation. This
     way we get new accurate information, particularily regarding the
     status of the statement map. Other modules affected to implement
     this feature are 'probe_command_' and 'probe_find_procedure_'. 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_seg_info_:
  proc (P_probe_info_ptr, P_segment_ptr, P_code) returns (ptr);

  /* This procedure is used to retrieve information about a segment or component from its
   symbol table.  Once extracted, the information is stored in the scratch data
   segment for future reference.

   Initial Version:  12 August 1974 by Jeffrey M. Broughton
   Modified:  20 June 1975 by JMB for version 2 object_info structure
   Modified:  26 August 1975 by JMB to change calling sequence
   Converted to probe 4.0 05/19/79 WOS
   Major reorganization for new source ptr and seg_info JRD 25 June 79
   Fix ignore_casep to not always return "1" b for sake of FORTRAN JRD Valentines Day 1980
   09/21/80 WOS -- fixed bugs in forgetting components, and names (#187, #190)
   Modified 17 April 1981 by M. N. Davidoff to fix unitialized variable bug.
   Fixed to check for damaged source map 01/06/83 S. Herbst
   Made to ignore case for Pascal, as for COBOL 08/11/83 S. Herbst

   ENTRIES -
   probe_seg_info_		- to get info set up
   probe_seg_info_$name	- to return the name,  given ptr to seg
   probe_seg_info_$flush	- to discard info
*/

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

  dcl info		pointer;	/* to procedure source information */

  dcl segment_ptr		ptr;	/* copy of P_segment_ptr */
  dcl segment_number	fixed bin;/* its segment number */
  dcl segment_offset	fixed bin (35);
				/* its word offset */
  dcl offset		bit (18); /* offset into scratch seg for our info */
  dcl bsinfo		ptr;	/* to info for bound seg as a whole */
  dcl hdr			ptr;	/* to symbol table header */
  dcl code		fixed bin (35);
  dcl directory_name	char (168);
  dcl entry_name		char (32);
  dcl time_created		fixed bin (71);

  dcl 1 oi		aligned like object_info;

  dcl (
      probe_et_$non_standard,
      probe_et_$no_table,
      probe_et_$old_format,
      probe_et_$no_map
      )			fixed bin (35) external static;

  dcl hcs_$fs_get_path_name	entry (pointer, character (*), fixed bin,
			character (*), fixed bin (35));
  dcl hcs_$status_mins	entry (pointer, fixed bin (2), fixed bin (24),
			fixed bin (35));
  dcl component_info_$offset	entry (pointer, fixed bin (18), pointer,
			fixed bin (35));
  dcl object_info_$display	entry (pointer, fixed bin (24), pointer,
			fixed bin (35));

  dcl probe_error_$warning	entry options (variable);
  dcl probe_lang_type_	entry (char (*)) returns (fixed bin);

  dcl (addr, addrel, baseno, binary, divide, fixed, index, null, pointer, rel,
      size, stackbaseptr, unspec)
			builtin;
				/**/

  probe_info_ptr = P_probe_info_ptr;
  segment_ptr = P_segment_ptr;

  call get_info_pointer ();		/* look up the info for segment_ptr */

  if info = null ()
    then
         info = probe_static_info.null_seg_info_ptr;

  P_code = code;			/* return the error, if any */
  return (info);

  /**/

probe_seg_info_$name:
  entry (P_probe_info_ptr, P_segment_ptr, P_code) returns (char (32));

  /* *	This entry returns the "canonical" name of the procedure, nothing else */

  probe_info_ptr = P_probe_info_ptr;
  segment_ptr = P_segment_ptr;

  call get_info_pointer ();		/* look up the info for segment_ptr */
  P_code = code;			/* reflect error, if any */

  if info = null ()
    then /* couldn't find out */
         return ("?Unknown?");
  else if (info -> seg_info.segname ^= "")
    then
         return (info -> seg_info.segname);
  else if (info -> seg_info.entry_name ^= "")
    then
         return (info -> seg_info.entry_name);
  else return ("?Unknown?");		/* all cases covered here */

  /**/

probe_seg_info_$flush:
  entry (P_probe_info_ptr, P_segment_ptr);

  /* *	This entry attempts to flush any known saved pointers which refer to
   *	the segment specified. This means it flushes the major seg_info block, and
   *	also any component seg_info's if it was a bound segment. It also flushes
   *	various other random things, which are known about only in free_seg_info. */


  if P_segment_ptr = null () then do;	/* can't flush null pointer -- just return */
      return;
    end;

  probe_info_ptr = P_probe_info_ptr;
  segment_ptr = pointer (P_segment_ptr, 0);
				/* we're dealing with whole segment here */
  segment_number = binary (baseno (segment_ptr), 15);

  if (seg_info_offset (segment_number) = ""b)
    then /* flush the seg_info */
         info = null ();
    else info =
	    pointer (probe_info.scratch_area_ptr,
	    seg_info_offset (segment_number));

  call free_seg_info ();		/* flush it */
  return;				/* end of code for $flush entrypoint */

  /**/

get_info_pointer:
  proc ();

  /* *	This procedure sets the pointer "info" to point to a seg_info block for the
   *	specified pointer. It's major responsibility is to verify that the segment
   *	has not changed out from under us. It also sets some global variables. */


  code = 0;

  if segment_ptr = null () then do;
      info = probe_static_info.null_seg_info_ptr;
				/* "null" seg_info */
      return;			/* all done */
    end;

  segment_offset = binary (rel (segment_ptr), 18);
  segment_number = binary (baseno (segment_ptr), 15);

  entry_name = "?Unknown?";
  info = null ();
  offset = seg_info_offset (segment_number);

  if offset ^= (18)"0"b then do;	/* we have met before */
      info = pointer (probe_info.scratch_area_ptr, offset);
				/* find out whether anything has happened */
      hdr = info -> seg_info.symbol_header_ptr;
      if (probe_info.entry_method = 1 | seg_changedp(info, hdr)) then

	call free_seg_info ();	/* get rid of old entry (entries) */
       probe_info.entry_method = 0;
	call get_seg_info ();	/* get new info */
    end;				/* make a new block for a bound component this time */

    else do;			/* otherwise, we must construct info anew */
      info = null ();		/* indicate that there is nothing presently available */
      call get_seg_info ();		/* and call to get info */
    end;

  if info ^= null ()
    then /* get stuff like current LP, etc. */
         call get_current_runtime_info ();
  return;				/* all done, one way or another */
  end get_info_pointer;		/* internal procedure */

  /**/

get_seg_info:
  proc ();

  /* *	This procedure sets info to point the correct seg_info block, creating one if necessary */

  dcl bitcount		fixed bin (24);

  if info ^= null () then do;		/* have valid entry? */
      if info -> seg_info.bits.bound_segment then do;
				/* it's for a bound segment -- find the component info */
				/* modified to ensure time_created is set through this code path */
	time_created = info -> seg_info.identifier;
				/* time object bound */
	bsinfo = info;		/* save ptr to info blck for the seg */

	info = search_bound_info ();	/* look through bound segment for segment_offset */
	if info ^= null ()
	  then /* if we already know this seg, we're all done */
	       return;

	call create_component_seg_info ();
				/* otherwise, create new info block for component and */
        end;			/* fall through to fill it in */

        else 
	   return;		/* unbound seg, so saved info guaranteed still good */
    end;				/* familiar, valid entry */

    else do;			/* the entry is new this time (might have changed, but old */
      
      call hcs_$fs_get_path_name (segment_ptr, directory_name, (0),
	 entry_name, code);		/* one is all gone) */
      if code ^= 0
        then /* any of these failures are catastrophic */
	   goto MAJOR_LOSSAGE;

      call hcs_$status_mins (segment_ptr, (0), bitcount, code);
      if code ^= 0
        then
	   goto MAJOR_LOSSAGE;

      oi.version_number = object_info_version_2;
      call object_info_$display (pointer (segment_ptr, 0), bitcount, addr (oi),
	 code);
      if code ^= 0
        then
	   goto MAJOR_LOSSAGE;

      hdr = oi.symbp;		/* set this here, for segment is new */
      time_created = hdr -> std_symbol_header.object_created;

      if oi.bound then do;
	call create_bound_seg_info ();/* creates and initializes a seg_info block, setting bsinfo */
	call create_component_seg_info ();
				/* This will set info to point to the block the the component */
        end;			/* new seg, which is bound */

        else do;			/* new seg, not bound */
	if oi.old_format then do;	/* intolerable for unbound seg */
	    code = probe_et_$old_format;
	    goto MAJOR_LOSSAGE;
	  end;

	call create_unbound_seg_info ();
				/* creates and initializes a block for this */
        end;			/* making new seg_info for unbound */
    end;				/*  meeting a new seg */

  if info = null ()
    then goto MAJOR_LOSSAGE;		/* somethins has clearly gone amiss */

  /* *	When we reach here, segment may or may not be new; however, we are
   *	guaranteed that the component is new if a bound seg is being processed.
   *	In any event we have created the seg_info block we must find out things
   *	about it - anything that one finds out that requires knowing if
   *	the seg is bound or not is known already, this still leaves looking for
   *	maps, symbol tables, language type etc... */

  call fill_in_info ();		/* fill in, with info common for both bound segs & components */
  return;


MAJOR_LOSSAGE:			/* the other way out of this subroutine */
  info = null ();			/* code is already set */
  return;
  end get_seg_info;			/* internal procedure */

  /**/

fill_in_info:
  proc ();

  /* *	This procedure fills in binding independent information about the segment */

  dcl ltype		fixed bin;
  dcl hdr_ptr		pointer;
  dcl based_string_lth	fixed bin (21);
  dcl based_string		char (based_string_lth) based;
  dcl pl1			pointer;
  dcl map_length		fixed bin (21);

  info -> seg_info.linkage_ptr = get_linkage_ptr ();
  info -> seg_info.break_info = null ();

  info -> seg_info.map_size = 0;
  info -> seg_info.error_code = 0;
  info -> seg_info.bound_sym_header = hdr;
  info -> seg_info.bound_create_time = time_created;


  /* The two above are used by breaks.  If the seg is unbound they are the time the seg was compiled and a ptr
   to its symbol section header.  If bound, they are the time it was bound in,
   as distinct from the compile time, and a ptr to the header for the bound seg
*/
  info -> seg_info.pad (*) = 0;

  hdr_ptr = info -> seg_info.symbol_header_ptr;
				/* symbol header for component */

  ltype = probe_lang_type_ ((hdr_ptr -> std_symbol_header.generator));
  info -> seg_info.language_type = ltype;

  if ltype = COBOL_lang_type | ltype = PASCAL_lang_type
    then
         info -> seg_info.ignore_case = "1"b;
				/* always, for COBOL and Pascal */
  else if ltype = FORTRAN_lang_type
    then
         info -> seg_info.ignore_case = ignore_casep (hdr_ptr);

  info -> seg_info.original_source_ptr =
       addrel (hdr_ptr, hdr_ptr -> std_symbol_header.source_map);

  pl1 = addrel (hdr_ptr, hdr_ptr -> std_symbol_header.area_pointer);
  if pl1 -> pl1_symbol_block.identifier ^= "pl1info" then do;
      code = probe_et_$no_table;
      info -> seg_info.error_code = code;
				/* record it */
      info -> seg_info.segname = "";	/* and give null values to the rest */
      info -> seg_info.statement_map_ptr = null ();
				/* no map, of course */
      info -> seg_info.map_size = 0;
      return;			/* ignore the rest of this */
    end;

  based_string_lth = fixed (pl1 -> pl1_symbol_block.segname.size, 21);
  info -> seg_info.segname = /* name of "main" entry */
       addrel (hdr_ptr, pl1 -> segname.offset) -> based_string;

  if pl1 -> pl1_symbol_block.map.first ^= "0"b then do;
      info -> seg_info.statement_map_ptr =
	 addrel (hdr_ptr, pl1 -> pl1_symbol_block.map.first);
      map_length =
	 fixed (pl1 -> pl1_symbol_block.last, 18)
	 - fixed (pl1 -> pl1_symbol_block.first, 18);
      info -> seg_info.map_size =
	 divide (map_length, size (statement_map), 17, 0) - 1;
    end;

    else do;			/* otherwise, record the problem */
      code = probe_et_$no_map;
      info -> seg_info.error_code = code;
      info -> seg_info.statement_map_ptr = null ();
				/* provide values to indicate that this is missing */
      info -> seg_info.map_size = 0;
      return;
    end;
  return;
  end fill_in_info;			/* internal procedure */

  /**/

create_bound_seg_info:
  proc ();

  /* *	This procedure creates and initializes a seg_info block for an entire bound
   *	segment, and sets bsinfo to point to it. hdr_ptr is pointing at
   *	std_symbol_header for whole bound seg. Numerous global variables
   *	are imported from above. */

  dcl bindmap_ptr		pointer;


  bindmap_ptr = addrel (hdr, hdr -> std_symbol_header.area_pointer);

  seg_info_nfiles = 1;		/* should be 0, but PL/I won't allow dimension (0) */

  allocate seg_info in (scratch_area) set (bsinfo);

  bsinfo -> seg_info.nfiles = seg_info_nfiles;
  bsinfo -> seg_info.file_pointers (*) = null ();

  bsinfo -> seg_info.language_type = OTHER_lang_type;
  bsinfo -> seg_info.bits = "0"b;
  bsinfo -> seg_info.bits.bound_segment = "1"b;
				/* indicates primary entry for bound seg */

  bsinfo -> seg_info.directory_name = directory_name;
  bsinfo -> seg_info.entry_name = entry_name;
  bsinfo -> seg_info.segname = "<<Bound Segment>>";
  bsinfo -> seg_info.identifier = time_created;

  bsinfo -> seg_info.symbol_header_ptr = hdr;
  bsinfo -> seg_info.original_source_ptr = bindmap_ptr;
  bsinfo -> seg_info.statement_map_ptr = null ();
  bsinfo -> seg_info.break_info = null ();
  bsinfo -> seg_info.chain = null ();
  bsinfo -> seg_info.linkage_ptr = get_linkage_ptr ();
				/* filters out various kinds of badness */

  bsinfo -> seg_info.text_bounds.start = 0;
  bsinfo -> seg_info.text_bounds.end = 0;
  bsinfo -> seg_info.symbol_bounds.start = 0;
  bsinfo -> seg_info.symbol_bounds.end = 0;

  bsinfo -> seg_info.map_size = 0;
  bsinfo -> seg_info.error_code = 0;
  bsinfo -> seg_info.pad (*) = 0;

  seg_info_offset (segment_number) = rel (bsinfo);
				/* remember where the bound seg info is */
  return;
  end create_bound_seg_info;		/* internal procedure */

  /**/

create_unbound_seg_info:
  proc ();

  /* *	This procedure creates and initializes a seg_info block for an unbound
   *	segment, and sets info to point to it. Numerous global variables
   *	are imported from above. */

  dcl source_map_ptr	pointer;
  dcl ub_info		pointer;


  if hdr -> std_symbol_header.source_map = "000000"b3 then do;
				/* haven't got a source map at all */
      source_map_ptr = null ();
      seg_info_nfiles = 1;		/* should be 0, but dimension (0) is invalid PL/I */
    end;

    else do;			/* otherwise, get information about the source map */
      source_map_ptr = addrel (hdr, hdr -> std_symbol_header.source_map);
      seg_info_nfiles = source_map_ptr -> source_map.number;
    end;


  allocate seg_info in (scratch_area) set (ub_info);

  ub_info -> seg_info.nfiles = seg_info_nfiles;
  ub_info -> seg_info.file_pointers (*) = null ();

  ub_info -> seg_info.bits = ""b;

  ub_info -> seg_info.directory_name = directory_name;
  ub_info -> seg_info.entry_name = entry_name;
  ub_info -> seg_info.identifier = time_created;

  ub_info -> seg_info.symbol_header_ptr = hdr;
  ub_info -> seg_info.original_source_ptr = source_map_ptr;

  ub_info -> seg_info.text_bounds.start = 0;
  ub_info -> seg_info.text_bounds.end = 0;
  ub_info -> seg_info.symbol_bounds.start = 0;
  ub_info -> seg_info.symbol_bounds.end = 0;
  ub_info -> seg_info.chain = null;

  info = ub_info;			/* all done */
  seg_info_offset (segment_number) = rel (ub_info);
				/* record the location */
  return;

  end create_unbound_seg_info;	/* internal procedure */

  /**/

create_component_seg_info:
  proc ();

  /* *	This procedure creates and initializes a seg_info block for a component
   *	of the current bound segment. */

  dcl ct_info		ptr;
  dcl hdr_ptr		pointer;
  dcl source_map_ptr	pointer;

  /* assume bsinfo is set - we need to alloc a new block, which is one of the components of the bound seg */


  call component_info_$offset (pointer (segment_ptr, 0), (segment_offset),
       addr (ci), code);
  if code ^= 0 then do;		/* screwed up, it appears */
      info = null ();
      return;
    end;

  if ^ci.standard then do;
      code = probe_et_$non_standard;	/* FATAL */
      info = null ();
      return;
    end;

  hdr_ptr = ci.symb_start;

  if hdr_ptr -> std_symbol_header.source_map = "000000"b3 then do;
				/* haven't got a source map at all */
NO_SOURCE_MAP:
      source_map_ptr = null ();
      seg_info_nfiles = 1;		/* should be 0, but dimension (0) is invalid PL/I */
    end;

    else do;			/* otherwise, get information about the source map */
      source_map_ptr =
	 addrel (hdr_ptr, hdr_ptr -> std_symbol_header.source_map);
      if source_map_ptr -> source_map.version < 1
	 | source_map_ptr -> source_map.version > 30
        then
	   go to NO_SOURCE_MAP;	/* source map is damaged */
      seg_info_nfiles = source_map_ptr -> source_map.number;
      if seg_info_nfiles < 1 | seg_info_nfiles > 256
        then go to NO_SOURCE_MAP;	/* count damaged */
    end;

  allocate seg_info in (scratch_area) set (ct_info);

  /* set up stuff that is different for a component seg_info than for an unbound one */

  ct_info -> seg_info.nfiles = seg_info_nfiles;
  ct_info -> seg_info.file_pointers (*) = null ();

  ct_info -> seg_info.bits = ""b;
  ct_info -> seg_info.bits.component = "1"b;
				/* indicates component entry for bound seg */

  ct_info -> seg_info.directory_name = bsinfo -> seg_info.directory_name;
  ct_info -> seg_info.entry_name = bsinfo -> seg_info.entry_name;
				/* copy entry name */
  ct_info -> seg_info.identifier = ci.compile_time;

  ct_info -> seg_info.symbol_header_ptr = hdr_ptr;
  ct_info -> seg_info.original_source_ptr = source_map_ptr;

  ct_info -> seg_info.text_bounds.start = fixed (rel (ci.text_start), 18);
  ct_info -> seg_info.text_bounds.end =
       fixed (rel (ci.text_start), 18) + ci.text_lng - 1;
  ct_info -> seg_info.symbol_bounds.start = fixed (rel (ci.symb_start), 18);
  ct_info -> seg_info.symbol_bounds.end =
       fixed (rel (ci.symb_start), 18) + ci.symb_lng - 1;

  ct_info -> seg_info.chain = bsinfo -> seg_info.chain;
				/* add to head of list */
  bsinfo -> seg_info.chain = ct_info;

  info = ct_info;			/* leave it set for our caller */

  return;				/* and return */
  end create_component_seg_info;	/* internal procedure */

  /**/

free_seg_info:
  proc ();

  dcl pi_ptr		pointer;
  dcl next_info		ptr;

  if info ^= null () then do;
      info =
	 pointer (probe_info.scratch_area_ptr,
	 seg_info_offset (segment_number));
      seg_info_offset (segment_number) = ""b;
				/* and clear it out immediately */

      if ^info -> seg_info.bound_segment
        then /* easy to free nonbound seg_info, just free it */
	   free info -> seg_info in (scratch_area);

        else do;			/* loop through all the bound seg infos, freeing them all */
	do info = info repeat next_info while (info ^= null ());
	  next_info = info -> seg_info.chain;
				/* save before destorying */
	  if baseno (info) = baseno (probe_info.scratch_area_ptr)
	    then /* hedge for bad chains */
	         free info -> seg_info in (scratch_area);
	end;
        end;			/* of bound seg case */

      info = null ();		/* and make sure nobody tries to use it again */
    end;

  pi_ptr = probe_info_ptr;		/* loop through the probe_info chain, invalidating any */
  do while (pi_ptr ^= null ());	/* source_infos associated with the */
    call flush_source_info /* segment number in question */
         (pi_ptr -> probe_info.ptr_to_initial_source);
    call flush_source_info
         (pi_ptr -> probe_info.ptr_to_current_source);
    pi_ptr = pi_ptr -> probe_info.previous;
  end;

  probe_static_info.good_stack = "0"b;	/* flush the saved stach trace as well, for good measure */
				/* this isn't strictly necessary, since we could just flush */
				/* individual entries, but this is easiest. */
  return;
  end free_seg_info;		/* internal procedure */

  /**/

flush_source_info:
  proc (P_source_info_ptr);

  /* *	This procedure checks a supplied source_info for any pointers containing the segment number
   *	being flushed, and if it finds any, re-initializes the source_info. */

  dcl P_source_info_ptr	pointer parameter;
  dcl 1 flush_source	aligned like source_info
			based (P_source_info_ptr);


  if P_source_info_ptr = null ()
    then
         return;			/* nothing to do */

  if binary (baseno (flush_source.instruction_ptr), 18)
       = segment_number /* if we are flushing the same segment  */
       | binary (baseno (flush_source.entry_ptr), 18)
       = segment_number /* number as is known in this source_info */
       | binary (baseno (flush_source.block_ptr), 18) = segment_number
    then do;			/* then we must then flush it. */

      flush_source.instruction_ptr = null ();
      flush_source.entry_ptr = null ();
      flush_source.block_ptr = null ();
      flush_source.stack_ptr = null ();
      flush_source.stmnt_map_entry_index = -1;
      flush_source.seg_info_ptr = probe_static_info.null_seg_info_ptr;
    end;
  return;
  end flush_source_info;		/* internal procedure */

  /**/


get_current_runtime_info:
  proc ();

  /* *	It is the responsibility of this procedure to get the current values for various pieces
   *	of runtime information which may change at times other than recompilations. */


  if info -> seg_info.linkage_ptr = null ()
    then
         info -> seg_info.linkage_ptr = get_linkage_ptr ();

  return;				/* for the moment, only the linkage pointer is in this class */
  end get_current_runtime_info;	/* internal procedure */

  /**/

get_linkage_ptr:
  proc () returns (pointer);

  /* *	This procedure returns the linkage pointer for the segment identified by
   *	segment_ptr; it filters out LOT faults and the like */


  lotp = stackbaseptr () -> stack_header.lot_ptr;

  if unspec (lotp -> lot.lp (segment_number)) = lot_fault then do;
      if probe_modes.debug
        then call probe_error_$warning
	        (probe_info_ptr, 0,
	        "LOT Fault linkage pointer for segno ^o.", segment_number);
      return (null ());
    end;
  return (lotp -> lot.lp (segment_number));

  end get_linkage_ptr;		/* internal procedure */

  /**/

ignore_casep:
  proc (P_hp) returns (bit (1) aligned);

  dcl P_hp		ptr parameter;

  dcl compiler_comment	char (
			binary (P_hp -> std_symbol_header.comment.size,
			21)) based (commentp);
  dcl commentp		ptr;


  commentp = addrel (P_hp, P_hp -> std_symbol_header.comment.offset);

  return (index (compiler_comment, "card") > 0 |
       index (compiler_comment, "fold") > 0);

  end ignore_casep;

seg_changedp:
  proc (infop, hdr) returns (bit (1) aligned);

  dcl infop		ptr parameter;
  dcl hdr			ptr parameter;


  if hdr = null ()			/* others have set this, to let us know */
    then return ("1"b);
  if infop -> seg_info.identifier ^= hdr -> std_symbol_header.object_created
    then return ("1"b);
  return ("0"b);

  end seg_changedp;


search_bound_info:
  proc () returns (ptr);

  dcl seginfop		ptr;	/* to seg_info blocks in chain of bsi */


  do seginfop = bsinfo -> seg_info.chain
       repeat (seginfop -> seg_info.chain) while (seginfop ^= null ());
    if inside (seginfop, segment_offset)
      then
	 return (seginfop);
  end;				/* loop */
  return (null);			/* not found */


inside:
  proc (sip, so) returns (bit (1) aligned);
  dcl sip			ptr;	/* to seg_info for a component */
  dcl so			fixed bin (35) parameter;
				/* offset in the seg */

  return (
       (so >= sip -> seg_info.text_bounds.start
       & so <= sip -> seg_info.text_bounds.end) |
       (so >= sip -> seg_info.symbol_bounds.start
       & so <= sip -> seg_info.symbol_bounds.end)
       );

  end inside;
  end search_bound_info;

%page;
%include probe_info;
%page;
%include probe_static_info;
%page;
%include probe_modes;
%page;
%include probe_seg_info;
%page;
%include probe_source_info;
%page;
%include probe_lang_types;
%page;
%include source_map;
%page;
%include std_symbol_header;
%page;
%include pl1_symbol_block;
%page;
%include statement_map;
%page;
%include runtime_symbol;
%page;
%include object_info;
%page;
%include component_info;
%page;
%include lot;
%page;
%include stack_header;

  end probe_seg_info_;		/* external procedure */




		    probe_seg_mgr_.pl1              10/27/88  1250.2r w 10/27/88  1225.1      151614



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

/****^  HISTORY COMMENTS:
  1) change(87-05-27,JRGray), approve(87-06-24,MCR7711), audit(87-06-24,Huen),
     install(87-07-15,MR12.1-1040):
     Modifed to allow breakpoints in more than one component of a bound module
     at a time (probe 111).
  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_seg_mgr_:
  proc;


  call probe_error_$malfunction ();

  /* Interface to the probe seg (also known as the break seg).  All permanent information is kept here
   This consists of an entry for every procedure that probe has set a break in.

   It may one day also hold modes, macros, and variables

   ENTRIES HERE -

   get_breakseg_ptr		- initialize breakseg, create if need be
   first_procedure_ptr	- to find first procedure entry in chain
   get_procedure_entry	- given ptr to seg_info, find the procedure entry for it
   create_procedure_entry	- given ptr to seg info, find or create a procedure entry
   delete_procedure_entry	- given ptr to procedure_entry delete it


   Jim Davis Aug -  Sept 79 */
  /* Improved error message if can't get ptr to seg 08/31/81 S. Herbst */
  /* Changed $get_breakseg_ptr not to create, and added $create_breakseg 10/02/81 S. Herbst */
  /* Fixed bug that allows $first_procedure_ptr to take a null ptr fault 01/15/85 Steve Herbst */
  /* Fixed $first_procedure_ptr to test for null static_info_ptr too 01/23/85 Steve Herbst */


  dcl (
      P_probe_info_ptr	ptr,
      P_ent		ptr,
      P_bmp		ptr,
      P_seginfop		ptr,
      P_code		fixed bin (35)
      )			parameter;

  dcl (
      CREATE		init ("1"b),
      DONT_CREATE		init ("0"b)
      )			bit (1) aligned;

  dcl seginfop		ptr;	/* copy of P_seginfop */

  dcl (add, addrel, binary, bit, divide, fixed, mod, multiply, null, pointer,
      rel, rtrim, size, subtract)
			builtin;

  dcl error_table_$action_not_performed
			fixed bin (35) ext;

  dcl probe_error_$malfunction
			entry options (variable);

  dcl com_err_		entry options (variable);
  dcl hcs_$set_bc_seg	entry (ptr, fixed bin (24), fixed bin (35));

get_breakseg_ptr:
  entry (P_code) returns (ptr);


  P_code = 0;
  call initialize_breakseg (DONT_CREATE);
				/* sets break_segp and P_code */
  return (break_segp);



create_breakseg:
  entry (P_code) returns (ptr);


  P_code = 0;
  call initialize_breakseg (CREATE);
  return (break_segp);



first_procedure_ptr:
  entry (P_probe_info_ptr, P_code) returns (ptr);


  P_code = 0;
  if P_probe_info_ptr = null
    then
         return (null);

  probe_info_ptr = P_probe_info_ptr;

  if probe_info.static_info_ptr = null
    then
         return (null);

  break_segp = probe_static_info.break_segment_ptr;
  if break_segp = null
    then
         return (null);
  if break_segment.first_procedure_entry = (18)"0"b
    then return (null ());
    else return (pointer (break_segp, break_segment.first_procedure_entry));



get_procedure_entry:
  entry (P_probe_info_ptr, P_seginfop, P_ent, P_bmp, P_code);


  probe_info_ptr = P_probe_info_ptr;
  seginfop = P_seginfop;
  P_code = 0;

  break_segp = probe_static_info.break_segment_ptr;

  call search_for_proc_entry ();
  P_ent = ent;
  P_bmp = bmp;
  return;



delete_procedure_entry:
  entry (P_probe_info_ptr, P_ent, P_code);

  probe_info_ptr = P_probe_info_ptr;
  P_code = 0;

  break_segp = probe_static_info.break_segment_ptr;
  call delete_proc ((P_ent));
  return;



create_procedure_entry:
  entry (P_probe_info_ptr, P_seginfop, P_ent, P_bmp, P_code);


  probe_info_ptr = P_probe_info_ptr;
  seginfop = P_seginfop;
  P_code = 0;

  break_segp = probe_static_info.break_segment_ptr;

  call search_for_proc_entry ();
  P_ent = ent;
  P_bmp = bmp;
  if ent ^= null ()
    then
         return;			/* already had one */
  call create_proc ();
  P_ent = ent;			/* the entry just created */
  P_bmp = null ();			/* obviously, 'cause we just made it */
  return;


initialize_breakseg:
  proc (P_create_sw);

  dcl P_create_sw		bit (1) aligned;

  dcl dirname		character (168);
				/* directory portion of pathname of break seg */
  dcl entryname		character (32);
				/* entry portion of name */
  dcl code		fixed bin (35);

  dcl user_info_		entry options (variable);
  dcl user_info_$homedir	entry (char (*));
  dcl hcs_$initiate		entry (char (*), char (*), char (*),
			fixed bin (1), fixed bin (2), ptr,
			fixed bin (35));
  dcl hcs_$make_seg		entry (char (*), char (*), char (*),
			fixed bin (5), ptr, fixed bin (35));

  dcl probe_data_$break_segment_suffix
			char (32) external static;


  call user_info_ (entryname);	/* get user's id and project */
  call user_info_$homedir (dirname);	/* get directory in which to place seg */

  entryname =
       rtrim (entryname) || "." || rtrim (probe_data_$break_segment_suffix);

  if P_create_sw then do;
      call hcs_$make_seg (dirname, entryname, "", 01010b, break_segp, code);
      if break_segp = null () then do;	/* something went wrong */
	call com_err_ (code, "probe", "^a^[>^]^a", dirname, dirname ^= ">",
	     entryname);
	P_code = error_table_$action_not_performed;
	return;
        end;
    end;
    else do;
      call hcs_$initiate (dirname, entryname, "", 0, 0, break_segp, code);
      code = 0;
      if break_segp = null
        then
	   return;
    end;

  if break_segment.version = 1 then do; /* old style break segment, convert to new style */
      break_segment.upper_bound = /* builtins are so powerful..... */
	 bit (
	 subtract (
	 multiply (divide (add (binary (break_segment.word_count, 18, 0),
	 1023, 18, 0), 1024, 18, 0), 1024, 18, 0), 4, 18, 0));
      call hcs_$set_bc_seg (break_segp,
	 multiply (binary (break_segment.upper_bound, 18, 0) + 4, 36, 24, 0)
	 , (0));
    end;

  else if break_segment.version ^= 2 then do;
				/* this segment has not been initialized */
      break_segment.version = 2;
      break_segment.name = "breakseg";
      break_segment.word_count =
	 bit (
	 binary (size (break_segment) + mod (size (break_segment), 2), 18,
	 0));
      break_segment.upper_bound = bit (binary (1020, 18, 0));
				/* know that header not more than a page */
      call hcs_$set_bc_seg (break_segp,
	 multiply (binary (break_segment.upper_bound, 18, 0), 36, 24, 0),
	 (0));
    end;
  return;

  end initialize_breakseg;

search_for_proc_entry:
  proc ();

  /* GLOBAL! seginfop ent bmp */


  dcl goal_id		fixed bin (71) aligned;
  dcl next		ptr;

  goal_id = seginfop -> seg_info.bound_create_time;

  do ent = pointer (break_segp, break_segment.first_procedure_entry)
       repeat next while (rel (ent) ^= "0"b);

    next = pointer (break_segp, procedure_entry.chain);

    if procedure_entry.time_stamp = goal_id
      then
	 /* confirm by checking against entry and seg names,
		     necessary as bound object components share bound_create_times */
	 if procedure_entry.entry = seginfop -> seg_info.entry_name &
	      procedure_entry.segname = seginfop -> seg_info.segname
	   then do;
	     bmp = pointer (seginfop -> seg_info.symbol_header_ptr,
				/* any ptr would be as good */
		procedure_entry.break_map);
	     if procedure_entry.time_stamp = break_map.identifier
	       then
		  return;
	       else call delete_proc (ent);
				/* its obsolete */
	   end;
  end;				/* loop */

  ent, bmp = null ();		/* failed */
  end search_for_proc_entry;



create_proc:
  proc;

  /* GLOBAL import seginfop ent

   make a new procedure entry for the segment seginfop describes, put it in the
   breakseg and initialize it
*/
  ent = allocate_in_breakseg (size (procedure_entry));
				/* make room for it */
  procedure_entry.item_type = PROCEDURE_ITEM;
				/* record that this is a segment entry */
  procedure_entry.directory = seginfop -> seg_info.directory_name;
				/* fill in data */

  procedure_entry.entry = seginfop -> seg_info.entry_name;
  procedure_entry.segname = seginfop -> seg_info.segname;
  procedure_entry.pad = 0;
  procedure_entry.time_stamp = seginfop -> seg_info.bound_create_time;

  procedure_entry.first_statement = (18)"0"b;
  procedure_entry.first_symbol = (18)"0"b;
  procedure_entry.first_macro = (18)"0"b;
  procedure_entry.statement_map =
       rel (seginfop -> seg_info.statement_map_ptr);
  procedure_entry.statement_map_size =
       bit (fixed (seginfop -> seg_info.map_size, 18, 0));
  procedure_entry.source_map = rel (seginfop -> seg_info.original_source_ptr);
  procedure_entry.symbol_header =
       rel (seginfop -> seg_info.symbol_header_ptr);
  procedure_entry.bounds = seginfop -> seg_info.bounds;
  procedure_entry.language_type = seginfop -> seg_info.language_type;
  procedure_entry.break_map = "0"b;	/* none yet */
  procedure_entry.chain = break_segment.first_procedure_entry;
  break_segment.first_procedure_entry = rel (ent);
  end create_proc;




delete_proc:
  proc (ent);

  dcl ent			pointer parameter;
  dcl lent		pointer;

  /* unchain item, by searching chain for the previous item */


  if break_segment.first_procedure_entry = rel (ent)
    then break_segment.first_procedure_entry = ent -> procedure_entry.chain;
    else do;
      do lent = pointer (break_segp, break_segment.first_procedure_entry)
	 repeat pointer (lent, lent -> procedure_entry.chain)
	 while (rel (ent) ^= lent -> procedure_entry.chain);
        if lent -> procedure_entry.chain = (18)"0"b
	then call probe_error_$malfunction (probe_info_ptr);
      end;
      lent -> procedure_entry.chain = ent -> procedure_entry.chain;
    end;
  call release_in_breakseg (ent);	/* free it, it is no longer needed */

  return;

  end delete_proc;

  /* This routine is used to allocate space for an item in either the break segment.   It attempts
   to find the first free item containing enough space to hold the item, failing that it is placed at
   the end of the segment */

allocate_in_breakseg:
  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;

  needed = required + mod (required, 2);/* 0 mod 2 size */
  lfip = null ();
  do fip = pointer (break_segp, break_segment.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_segment.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 (break_segp, break_segment.word_count);
  fip -> item.size = needed;
  break_segment.word_count =
       bit (add (binary (break_segment.word_count, 18, 0), needed, 18, 0));

  /* must check if this allocation has overflowed the area, if so we will extend it */

  if break_segment.word_count > break_segment.upper_bound then do;
      break_segment.upper_bound =
	 bit (
	 subtract (
	 multiply (divide (add (binary (break_segment.word_count, 18, 0),
	 1023, 18, 0), 1024, 18, 0), 1024, 18, 0), 4, 18, 0));

      call hcs_$set_bc_seg (break_segp,
	 multiply (binary (break_segment.upper_bound, 18, 0) + 4, 36, 24, 0)
	 , (0));
				/* an error here will only cause move problems */
    end;
  return (fip);
  end;				/* internal procedure allocate_in_breakseg */





  /* This routine is used to handle the freeing of items in the break segment.
   When an item is frees it is chained together with other free items.
   if two or three then turn out to be continguous, they are combined.
*/

release_in_breakseg:
  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) based aligned;
  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_segment.word_count, 18, 0) /* it is at the end */
    then do;
      break_segment.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 (break_segp, break_segment.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_segment.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_segment.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_segment.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 (break_segp, break_segment.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 /* the last one and the 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_segment.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_segment.first_free_item = rel (ip);
  ip -> free_item.chain = (18)"0"b;
  ip -> free_item.size = ip -> item.size;
  return;

  end release_in_breakseg;


%include probe_info;

  /* ;;;;;;; */

%include probe_static_info;

  /* ;;;;;;; */


%include probe_seg_info;

  /* ;;;;;;; */

%include probe_break_info;

  end probe_seg_mgr_;




		    probe_source_segment_.pl1       10/27/88  1250.2r w 10/27/88  1225.2      219996



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

/****^  HISTORY COMMENTS:
  1) change(87-06-18,RWaters), approve(87-06-18,MCR7687), audit(87-06-24,Huen),
     install(87-07-15,MR12.1-1040):
     Probe error #108: allow the object command to work w/o source code.
  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_source_segment_:
  proc ();

  call probe_error_$malfunction ();	/* dummy entry */

  /* This module is used to examine the source of a program.	It can list source
   statements,  search for a string in the source,  and check if a given
   statement is within the statement map.

   Initial Version:  13 August 1974 by Jeffrey M. Broughton
   Modified: 20 Sept 78 by James R Davis to not  print anything if ps "string"	fails,
   and to ident lines properly on output
   Converted to probe 4.0 05/19/79 WOS
   Fixed to implement ps "", May 79 JRD
/* Added $position_source_lines for relative positioning by number of lines 10/08/81 S. Herbst */
  /* Changed $find_source to handle regular expressions 10/09/81 S. Herbst */
  /* Changed to handle long PL/1 and FORTRAN statements (>256 chars) 10/23/81 S. Herbst */
  /* Added $get_file_ptr for use by probe_find_location_ */
  /* Fixed not to print to end of seg for some cases of symbol table mismatch 06/01/82 S. Herbst */
  /* Fixed bug in regular expression searching for complicated programs 07/14/82 S. Herbst */
  /* Fixed $list_statement to not stray beyond text into int proc statements 09/13/82 S. Herbst */
  /* Fixed "b /REGEXP/" loop bug 10/18/82 S. Herbst */
  /* Modified:  7 April 1983, TO - Add 'line_start' routine to correct for
	line start modulus 256K in source.  Add line counting to 
	'file_pointer' to setup line breaks. */
  /* Modified: 13 April 1983, TO - Modify archive checking to presume archive
	component implied.  Fix bug in 'get_stmt_length' in which the first
	statment can start at character 1, and have a length of 0.  If so,
	the max function prevents a character check at character position 0. */
  /* Modified: 11 May 1983, RG - To use find_source_file_$look_in_wdir which
	supports archive components implied/explicit. */
  /* Fixed regexp search with internal procedures 08/05/83 S. Herbst */
  /* Modified: 31 Aug 1983, Lee A. Newcomb: to use probe search lists. */
  /* Fixed to detect when saved source pointer points to wrong thing 09/01/83 S. Herbst */
  /* Fixed "ps /foo   /" to not ignore the trailing white space 02/09/84 S. Herbst */
  /* Fixed "ps +N" for case where last int proc is not end of program 02/10/84 S. Herbst */
  /* Fixed get_stmt_length for zero-length statements listed in map 02/13/84 S. Herbst */
  /* Fixed line_start int proc to test if seg_info.per_file(file).break_line(i) = 0 02/24/84 S. Herbst */
  /* Fixed not to check seg_info.(directory_name entry_name) since these usually
   refer to the object not the source 11/07/84 Steve Herbst */
  /* Fixed file_pointer proc to always search for source seg, not trust stored ptr 11/28/84 Steve Herbst */
  /* Fixed to return null on error if entered through $get_file_ptr 01/03/85 Steve Herbst */
  /* Fixed bug that caused a fault when stmt map shows 0 as a stmt's start position 01/16/85 Steve Herbst */
  /* Fixed loop caused by 2 stmt map entries for an on statement 01/16/85 Steve Herbst */
  /* Fixed undefined source bug when last match for regexp is last statement 01/23/85 Steve Herbst */
  /* Changed the procedure file_pointer to return an error code so the object command will work without a source file. 05/21/87 RWaters */


  dcl (
      P_probe_info_ptr	pointer,
      P_number_to_list	fixed bin,/* number of statements to list */
      P_search_string	character (*),
				/* string to be searched for */
      P_origin_source_info_ptr
			ptr,
      P_relocate		fixed bin,/* move source pointer this number of stmts */
      P_code		fixed bin (35)
      )			parameter;

  dcl 1 origin_source_info	aligned based (origin_source_info_ptr)
			like source_info;
  dcl origin_source_info_ptr	ptr;

  dcl position_lines	bit (1) aligned;
				/* position N lines instead of N statements */
  dcl returns_ptr_sw	bit (1) aligned;
  dcl line_number		fixed bin;
  dcl statement_number	fixed bin;
  dcl smp			pointer;	/* to first statement map entry of interest */
  dcl file_number		fixed bin;/* number of file that we are currently using */
  dcl filep		pointer;	/* to current file */
  dcl info		pointer;	/* seg_info pointer for origin_source_info */
  dcl based_string		character (1) aligned based;
				/* dummy string to overlay segment, and output buffer */

  dcl number		fixed bin initial (1);
				/* number of statements that we have listed */
  dcl start		fixed bin (35);
				/* character offset of start of statement's text */
  dcl len			fixed bin (35);
				/* length of the statement in characters */
  dcl offset		fixed bin;/* collumn in which statement starts */
  dcl p			ptr;
  dcl last_file_number	fixed bin;/* last source file scaned */
  dcl (stmt_len, stmt_start)	fixed bin (21);
  dcl code		fixed bin (35);
  dcl (i, j, last_source_index)
			fixed bin;

  dcl 1 map_array		(map_size) aligned based (smp)
			like statement_map;
				/* overlay for entire statement map */
  dcl map_size		fixed bin (21);
  dcl find_source_file_$search_path
			entry (char (*), char (*), char (*), char (*),
			ptr, fixed bin (24), fixed bin (35));
  dcl ioa_$ioa_switch_nnl	entry options (variable);
  dcl iox_$put_chars	entry (pointer, pointer, fixed binary (21),
			fixed binary (35));

  dcl probe_find_location_	entry (ptr, ptr, fixed bin, fixed bin,
			fixed bin, bit (36) aligned, ptr, fixed bin);

  dcl (
      probe_et_$bad_line,
      probe_et_$no_saved_string,
      probe_et_$string_search_failed,
      probe_et_$no_statement_map,
      probe_et_$recorded_message
      )			fixed bin (35) external static;

  dcl probe_error_		entry options (variable);
  dcl probe_error_$malfunction
			entry options (variable);
  dcl probe_error_$record	entry options (variable);

  dcl newline		char (1) aligned internal static
			options (constant) initial ("
");
  dcl TAB_BS		char (2) internal static options (constant)
			init ("	");

  dcl (addrel, addr, binary, divide, fixed, index, length, max, min)
			builtin;
  dcl (mod, null, pointer, reverse, rtrim, string, substr, unspec)
			builtin;
%page;
list_statement:
  entry (P_probe_info_ptr, P_origin_source_info_ptr, P_number_to_list, P_code)
       ;

  returns_ptr_sw = "0"b;

  call common_setup;

  if statement_number < 1 | statement_number > map_size
    then call probe_error_ (probe_info_ptr, probe_et_$bad_line, "", "");
				/* segment does not have a table of source lines */

  smp = addr (smp -> map_array (statement_number));
				/* make smp point only to the part of the source map we */
				/* are interested in. This is sorta kludgy. */

  last_file_number = -1;		/* no such file number; for comparison */

  do while (number <= P_number_to_list);/* loop until we have processed all statements */
    file_number = fixed (map_array (number).file) + 1;
    if file_number = last_file_number
      then goto MAIN_RETURN;		/* gone beyond text into int proc statements */
    last_file_number = file_number;
    filep = file_pointer (P_code);	/* get a pointer to the file */
    if P_code ^= 0
      then goto MAIN_RETURN;
    start = line_start (number - 1 + statement_number) + 1;
				/* where in segment does statement begin */

    /* get character offset of statement from beginning of line */

    i = start
         -
         index (reverse (substr (filep -> based_string, 1, start - 1)),
         newline);
    if i = start
      then i = 0;			/* find location of first preceding newline */

    offset = 0;			/* at start of line, no padding needed */
    do i = i + 1 to start - 1;	/* compute indentation of the line */
      j = index (TAB_BS, substr (filep -> based_string, i, 1));
				/* check if tab, backspace or something else */
      if j = 0
        then offset = offset + 1;	/* and have a width of one */
      else if j = 1
        then /* a tab */
	   offset = offset + 10 - mod (offset, 10);
				/* compute how far to tabulate */
      else if j = 2
        then offset = offset - 1;	/* backspace */
    end;

    /* get all lines that we can print in this part -- all that belong to the same file,
   and which have monotonically increasing line and statement numbers */

    do number = number + 1 by 1
         to P_number_to_list /* look for a statement not in current group */
         while (file_number = fixed (map_array (number).file) + 1
         & string (map_array (number).source_id)
         >= string (map_array (number - 1).source_id));
    end;
    len = line_start (statement_number - 1 + number - 1) - start +
         get_stmt_length (fixed (map_array (number - 1).length, 17, 0),
         (number)) + 1;

    if len = 0
      then call probe_error_ (probe_info_ptr, probe_et_$bad_line, "", "");
				/* may happen for dcl statement */
      else do;			/* write out the lines */
        call ioa_$ioa_switch_nnl (probe_info.output_switch, "^v( ^)", offset);
        p = addr (substr (filep -> based_string, start, 1));
        call iox_$put_chars (probe_info.output_switch, p, (len), code);
        if code ^= 0
	then call probe_error_ (probe_info_ptr, code, "Writing output");
        call iox_$put_chars (probe_info.output_switch, addr (newline), 1,
	   code);
      end;

    if string (map_array (number).source_id) = (27)"1"b
      then goto MAIN_RETURN;
				/* we have reached the end of the program */

  end;				/* and loop back for next file, if there is one */

  goto MAIN_RETURN;
%page;
position_source:
  entry (P_probe_info_ptr, P_origin_source_info_ptr, P_relocate, P_code);

  position_lines = "0"b;
  go to POSITION;


position_source_lines:
  entry (P_probe_info_ptr, P_origin_source_info_ptr, P_relocate, P_code);

  position_lines = "1"b;

POSITION:
  returns_ptr_sw = "0"b;

  call common_setup;

  if statement_number < 0 | statement_number > map_size
    then do;
      P_code = probe_et_$bad_line;
      goto SOME_ERROR;
    end;

  if position_lines then do;
POSITION_LINES:
      line_number = fixed (map_array (statement_number).line);
				/* ps +N lines, ps -N lines */
      line_number = line_number + P_relocate;
      if line_number < 1 then do;
	call probe_error_$record (probe_info_ptr, 0,
	     "Attempt to position before first line.");
	go to RECORDED_MESSAGE;
        end;

      call probe_find_location_ (probe_info_ptr,
	 origin_source_info.seg_info_ptr,
	 0, line_number, 1, "1110"b, (null), statement_number);
      if statement_number = -1 then do;
	call probe_error_$record (probe_info_ptr, 0,
	     "No source line number ^d", line_number);
	go to RECORDED_MESSAGE;
        end;
    end;

    else do;			/* ps +N, ps -N */
      if statement_number + P_relocate < 0
	 | statement_number + P_relocate > map_size then do;
	position_lines = "1"b;
	go to POSITION_LINES;	/* next best thing */
        end;
      statement_number = statement_number + P_relocate;
    end;

  goto CALCULATE_BLOCK_ETC;
%page;
find_source:
  entry (P_probe_info_ptr, P_origin_source_info_ptr, P_search_string, P_code);

  /* this entry implements the search for a quoted string - it remembers the string used for
   use if a "" is upplied */

  dcl search_string		char (256) varying;
				/* string to search for */
  dcl regexp_string		char (256) varying;
				/* search_string /.../ without the slashes */
  dcl previous_search_string	char (256) varying internal static init ("");
				/* last string searched for */

  dcl (found_start, search_end, search_start)
			fixed bin (21);
  dcl search_file_		entry (ptr, fixed bin (21), fixed bin (21), ptr,
			fixed bin (21), fixed bin (21), fixed bin (21),
			fixed bin (21), fixed bin (35));

  returns_ptr_sw = "0"b;

  call common_setup;

  if P_search_string = "" then do;	/* wants same string as last time */
      if previous_search_string = "" then do;
				/* but there was no last time */
	P_code = probe_et_$no_saved_string;
				/* failure */
	goto SOME_ERROR;
        end;
      search_string = previous_search_string;
    end;

    else do;
      search_string = P_search_string;
      previous_search_string = P_search_string;
				/* and save it for posterity */
    end;

  if substr (search_string, 1, 1) = "/"
       & substr (search_string, length (rtrim (search_string)), 1) = "/"
    then do;
				/* regular expression */
      regexp_string =
	 substr (search_string, 2, length (rtrim (search_string)) - 2);

      search_end = line_start ((map_size)) +
	 fixed (map_array (map_size).length, 17, 0) - 1;

      if statement_number < 1 | statement_number > map_size then do;
	search_start = line_start (1);
	statement_number = 0;
        end;
      else if statement_number = map_size
        then search_start = search_end;
      else do;
        if unspec (map_array (statement_number).source_info) =
	   unspec (map_array (statement_number + 1).source_info)
	then
	     statement_number = statement_number + 1;
				/* there are 2 stmt map entries for an on statement */
        search_start = line_start (statement_number + 1);
      end;

      file_number =
	 fixed (map_array (min (map_size, statement_number + 1)).file, 17,
	 0) + 1;
      filep = file_pointer (code);
      if code ^= 0
        then
	   call probe_error_ (probe_info_ptr, code);

      search_end = 0;
      do i = 1 to map_size;
        j = line_start (i);
        if j > search_end then do;
	  search_end = j;
	  last_source_index = i;
	end;
      end;
      search_end =
	 search_end + fixed (map_array (last_source_index).length, 17, 0)
	 - 1;

      if statement_number < 1 | statement_number > map_size then do;
	search_start = max (1, fixed (map_array (1).start, 17, 0));
	statement_number = 0;
        end;
      else if statement_number = map_size
        then search_start = search_end;
      else search_start =
	      max (1, fixed (map_array (statement_number + 1).start, 17, 0))
	      ;

SEARCH:
      call search_file_ (addrel (addr (regexp_string), 1), 1,
	 length (regexp_string),
	 filep, search_start, search_end, found_start, 0, code);
      if code ^= 0 then do;		/* search previous portion too, like ps "STRING" */

	call search_file_ (addrel (addr (regexp_string), 1), 1,
	     length (regexp_string),
	     filep, 1, search_start - 1, found_start, 0, code);
	if code ^= 0 then do;
	    P_code = probe_et_$string_search_failed;
	    goto MAIN_RETURN;
	  end;
        end;

      do i = 1 to map_size;		/* find the statement corresponding to this text position */
        stmt_start = line_start (i);
        stmt_len = fixed (map_array (i).length, 21, 0);
        if found_start >= stmt_start & found_start < stmt_start + stmt_len
	then
	     go to FOUND_STRING;
      end;

      search_start = found_start + 1;	/* must be in a comment; keep searching */
      go to SEARCH;
    end;


  if statement_number < 1 | statement_number > map_size
    then statement_number = 0;	/* start at beginnning, if undefined loc now */

  /* Scan through all executable statements looking for "string" */

  last_file_number = -1;		/* shouldn't be any file with this number */
  do i = statement_number + 1 to info -> seg_info.map_size,
       1 to statement_number;
    file_number = fixed (map_array (i).file, 17, 0) + 1;
				/* get file number */
    if file_number ^= last_file_number	/* if not in last file, get new filep */
      then filep = file_pointer (code);

    start = line_start (i) + 1;	/* where in source is the line */
    len = get_stmt_length (fixed (map_array (i).length, 17, 0), i + 1);

    if index (substr (filep -> based_string, start, len), search_string) ^= 0
      then goto FOUND_STRING;

    last_file_number = file_number;	/* not in current line try again */
  end;				/* of loop through statements */

  P_code = probe_et_$string_search_failed;
				/* sorry */
  goto MAIN_RETURN;

FOUND_STRING:
  statement_number = i;

  goto CALCULATE_BLOCK_ETC;



CALCULATE_BLOCK_ETC:

  dcl loc			bit (18);
  dcl hp			ptr;
  dcl stu_$find_containing_block
			entry (ptr, fixed bin (18) unsigned)
			returns (ptr);
  dcl probe_stack_trace_$find_block_frame
			entry (ptr, ptr);

  loc = map_array (statement_number).location;
  hp = info -> seg_info.symbol_header_ptr;

  origin_source_info.block_ptr =
       stu_$find_containing_block (hp, binary (loc, 18, 0));

  if origin_source_info.block_ptr ^= null ()
    then call probe_stack_trace_$find_block_frame (probe_info_ptr,
	    origin_source_info_ptr);

  /* must set these after searching stack */

  origin_source_info.instruction_ptr = pointer (hp, loc);
  origin_source_info.stmnt_map_entry_index = statement_number;

  goto MAIN_RETURN;			/* end for position and search */
%page;
get_file_ptr:
  entry (P_probe_info_ptr, P_origin_source_info_ptr, P_file_number)
       returns (ptr);

  dcl P_file_number		fixed bin;

  returns_ptr_sw = "1"b;

  call common_setup;

  if P_file_number = 0
    then file_number = 1;
    else file_number = P_file_number;
  return (file_pointer (0));
%page;
common_setup:
  proc;

  /* all three entries call this internal proc to do common setup and checking */


  probe_info_ptr = P_probe_info_ptr;
  origin_source_info_ptr = P_origin_source_info_ptr;
  P_code = 0;

  info = origin_source_info.seg_info_ptr;
  if info = null ()
    then do;
      P_code = probe_et_$bad_line;
      goto SOME_ERROR;
    end;

  smp = info -> seg_info.statement_map_ptr;
  if smp = null ()
    then do;
      P_code = probe_et_$no_statement_map;
      goto SOME_ERROR;
    end;

  map_size = info -> seg_info.map_size;

  statement_number = origin_source_info.stmnt_map_entry_index;
  end common_setup;
RECORDED_MESSAGE:
  P_code = probe_et_$recorded_message;
  goto MAIN_RETURN;

SOME_ERROR:
  if returns_ptr_sw
    then
         return (null);

MAIN_RETURN:
  return;
%page;
get_stmt_length:
  proc (P_len, P_next_number) returns (fixed bin (35));

  /* Looks for the statement delimiter; since the statement map's length number
   is mod (256), end of stmt is either N, 256+N, 512+N, etc. */

  dcl (P_len, P_next_number, len, limit)
			fixed bin (35);
  dcl lang		fixed bin;
  dcl char		char (1);
  dcl max			builtin;


  if P_len = 0
    then
         return (0);

  lang = info -> seg_info.language_type;
  if lang ^= PL1_lang_type & lang ^= PASCAL_lang_type
       & lang ^= FORTRAN_lang_type
    then
         return (P_len);		/* nothing we can do */

  len = P_len;
  limit = line_start ((P_next_number)) - start;
				/* up to start of next statement in map */

  do while (len < limit);

    char = substr (filep -> based_string, max (start + len - 1, 1), 1);
    if lang = FORTRAN_lang_type then do;
        if char = ";" | char = newline
	then
	     return (len);
      end;
    else if char = ";"
      then
	 return (len);

    len = len + 256;
  end;

  return (P_len);

  end get_stmt_length;
%page;
file_pointer:
  procedure (e_code) returns (pointer);

  /* global imports:
   info ptr to seg_info
   file_number the number of the file of interest
*/

  dcl e_code		fixed bin (35);
  dcl bitcount		fixed bin (24);
  dcl char_count		fixed bin (21);
  dcl (i, j, k, start, limit) fixed bin (21);
  dcl line		fixed bin;
  dcl string		char (char_count) unaligned based (try);
  dcl NL			char (1) static options (constant) initial ("
");
  dcl try			pointer;
  dcl osrc		pointer;	/* to original source map */
  dcl relpath		char (relpath_l) based (relpath_p);
				/* the rel path we must expand */
  dcl relpath_l		fixed bin;
  dcl relpath_p		ptr;
  dcl relpath_ename		char (32);/* the entryname part of relpath as */
				/* returned by find_source_file_$search_path */

  e_code = 0;
  osrc = info -> seg_info.original_source_ptr;

  /* get pointer to the segment */
  try = info -> seg_info.file_pointers (file_number);

  if try = null () then do;
      relpath_p =
	 addrel (info -> seg_info.symbol_header_ptr,
	 osrc -> source_map.offset (file_number));
      relpath_l = (fixed (osrc -> source_map (file_number).size));
				/* and get length of files path */
      call find_source_file_$search_path ((relpath), "", "probe",
	 relpath_ename, try, bitcount, e_code);

      /* If we are attempting to execute the object request, then just return
an error code all the way back to probe_requests_$object and let it handle it.
Otherwise call probe_error_
*/
      if e_code ^= 0
        then
	   if probe_info.request_name = "object"
	     then
		return (null ());
    end;

  if try = null () then do;
      call probe_error_ (probe_info_ptr, e_code,
	 "Cannot find source file ^a using probe search list.",
	 relpath_ename);
      return (null ());
    end;

  if try ^= info -> seg_info.file_pointers (file_number) then do;

      /* if the file is beyond the 256K character limit then we need to fill in
   the line break points. Do this by counting lines in all 256K character
   sections which are filled, and fill in the line_break point table.  The last
   table entry is always the maximum possible 18-bit line number to stop the
   scan. */

      char_count = divide (bitcount, 9, 21, 0);

      line = 1;
      j = 0;
      do i = 1 to divide (char_count, 2 ** 18, 18, 0);
        start = (i - 1) * 2 ** 18 + 1;
        limit = 2 ** 18;
        k = index (substr (string, start, limit), NL);
        do line = line repeat line + 1 while (k ^= 0);
	limit = limit - k;
	k = index (substr (string, start, limit), NL);
	start = start + k;
        end /* do line (count lines)*/;

        info -> seg_info.per_file (file_number).break_line (j) = line;
        j = j + 1;
      end /* do i (scan char blocks) */;
      info -> seg_info.per_file (file_number).break_line (j) = 2 ** 18 - 1;

      /* Having just gotton ptr to source file, we might want to check it to see if
   it has changed since the object seg was compiled, and WARN if so. */

      info -> seg_info.file_pointers (file_number) = try;
    end;
  return (info -> seg_info.file_pointers (file_number));

  end file_pointer;
%page;
line_start:
  procedure (line_number) returns (fixed bin (21));

  /* Procedure to scan the segment information line_break and convert the
   line character offset in the map, with the line character modulus info
   in the seg_info structure to a true character address. */

  dcl address		fixed bin (21);
				/* character address */
  dcl file		fixed bin;/* current file */
  dcl i			fixed bin;
  dcl source_line		fixed bin;/* line in source */
  dcl break_line		fixed bin;
  dcl line_number		fixed bin;
  dcl smp			ptr;


  smp = info -> seg_info.statement_map_ptr;
  file = fixed (smp -> map_array (line_number).file, 17, 0) + 1;
  source_line = fixed (smp -> map_array (line_number).line, 14, 0);
  address = fixed (smp -> map_array (line_number).start, 18, 0);

  do i = 0 to 3;
    break_line = info -> seg_info.per_file (file).break_line (i);
    if break_line <= 0
      then
	 return (address);		/* no info stored for this entry */
    else if source_line > break_line
      then address = address + 2 ** 18;
    else
         return (address);
  end;
  return (address);

  end line_start;
%page;
%include access_mode_values;
%page;
%include probe_info;
%page;
%include probe_lang_types;
%page;
%include probe_seg_info;
%page;
%include probe_source_info;
%page;
%include source_map;
%page;
%include statement_map;


  end probe_source_segment_;




		    probe_stack_trace_.pl1          10/27/88  1250.2r w 10/27/88  1225.2      133524



/****^  ***********************************************************
        *                                                         *
        * 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_stack_trace_:
  proc ();

  call probe_error_$malfunction ();	/* dummy entry */

  /* this module is the interface to the Multics stack - it is the only authorized caller of
   probe_trace_a_stack_, and shares with it and only it the knowledge of the internal
   probe stack.  We have a variety of entries to return information about the invocations of
   entries on the stack


   print_stack_history 	- dump the stack in nice format

   find_previous_invocation	- ???
   find_condition_frame	- find info for condition
   get_level		- find info for frame N
   find_frame		- find info for first frame with SP = x
   find_block_frame		- find info for frame of given BP
   find_proc_frame		 -find info for the N'th frame of given entry_ptr
   condition_raised		- return name of condition raised in frame of given SP, or ""

   where_source_info	-interprets a source_info, setting level number and block name for caller


   Initial Version:  13 August 1974 by Jeffrey M. Broughton
   Modified:  19 August 1975 by JMB to allocate level structures
   Modified:   7 June 78 by James R. Davis fix TR1326
   Modified:28 June 78 By JRD to not lose with new_fortran
   Modified: 20 Sept 78 by JRDto not include find_physical_block
   Converted to probe 4.0 05/19/79 WOS
   yet more conversion JRD 1 July 79 */
  /* Added $current_level function entrypoint for use in "ps level +N" 10/09/81 S. Herbst */
  /* Changed to use level_frame.printed_number 12/10/81 S. Herbst */
  /* Fixed to call probe_block_name_ with "0"b (brief form) 08/26/83 S. Herbst */

  dcl (
      P_probe_info_ptr	pointer,
      P_entry_ptr		pointer,	/* (Input) pointer to desired procedure */
      P_invocation		fixed bin,/* what this number of levels back */
      P_level_number	fixed bin,/* (Input) desired level_number */
      P_level_decimal	fixed bin,/* (Input) support frame decimal M in N.M */
      P_block_name		char (*), /* name of a block found */
      P_cond_name		char (32),/* (output) name of the condition found */
      P_sourcep		ptr,	/* to callers source_info to be filled in or used as input */
      P_invoc_count		fixed bin,/* (input): number of invocations back to search for */
      P_stack_frame_ptr	pointer
      )			parameter;/* pointer to stack frame we are interested in */


  /* many of these entries take a source_info struc, using some of the values as input, or perhaps
   filling the struc in as output.  All entries that need this struc have as parameter P_sourcep,
   which is assigned to level_source_ptr, and the struc found_source_info is referenced */
  dcl 1 found_source_info	aligned like source_info
			based (level_source_ptr);
  dcl level_source_ptr	ptr;



  dcl count		fixed bin;/* number of invocations found thus far */
  dcl last_invocation	pointer;	/* last invocation found */
  dcl saved_lfp		pointer;
  dcl i			fixed bin;
  dcl continue_tracing	bit (1) aligned;
  dcl code		fixed bin (35);

  dcl 1 cond_info		aligned like condition_info automatic;

  dcl find_condition_info_	entry (pointer, pointer, fixed bin (35));

  dcl probe_error_$malfunction
			entry options (variable);
  dcl probe_block_name_	entry (ptr, ptr, bit (1) aligned)
			returns (character (256) varying);
  dcl probe_trace_a_stack_	entry (ptr, ptr, bit (1) aligned);

  dcl (addr, max, null)
			builtin;
				/*  */
MAIN_RETURN:
  return;
				/*  */
probe_stack_trace_$find_proc_frame:
  entry (P_probe_info_ptr, P_sourcep, P_entry_ptr, P_invoc_count);


  level_source_ptr = P_sourcep;
  call setup;
  count = 0;
  last_invocation = null ();

  lfp = stack_info.level_chain;
  continue_tracing = "1"b;		/* curse pl1, which lacks do ... until */
  do while (continue_tracing);
    if level_frame.entry_ptr = P_entry_ptr then do;
        last_invocation = lfp;	/* remember in case this is the last one found */
        count = count + 1;
      end;

    if (count >= P_invoc_count) | (level_frame.number >= stack_info.max_level)
      then
	 continue_tracing = "0"b;
      else lfp = level_frame.next;	/* look at the next frame */
  end;

  if last_invocation = null () then do; /* didn't find any */
      found_source_info.entry_ptr,
	 found_source_info.stack_ptr,
	 found_source_info.block_ptr,
	 found_source_info.instruction_ptr = null ();
      found_source_info.stmnt_map_entry_index = -1;

      /* the old code set the entry_ptr to that passed to us */
      goto MAIN_RETURN;
    end;

  lfp = last_invocation;
  found_source_info = level_frame.source_info;

  goto MAIN_RETURN;			/* end of code for $find_proc_frame entry point */

  /*  */


  /* used by get_invocation_level - whateverit is called now */

probe_stack_trace_$find_previous_invocation:
  entry (P_probe_info_ptr, P_sourcep, P_invocation);


  call setup;
  level_source_ptr = P_sourcep;

  count = 0;
  last_invocation = null ();

  if found_source_info.stack_ptr ^= null & found_source_info.block_ptr ^= null
    then do;			/* look for it */
      lfp = stack_info.level_chain;
      continue_tracing = "1"b;	/* curse pl1, which lacks do ... until */
      do while (continue_tracing);	/* look for [invocation]th occurence of frame */
        if count <= 0 then do;
	  if found_source_info.stack_ptr = level_frame.stack_ptr
	    then /* look for starting level */
	         if found_source_info.block_ptr = level_frame.block_ptr
		 then do;		/* found */
		   count = 1;
		   last_invocation = lfp;
		 end;
	end;

        else if found_source_info.block_ptr = level_frame.block_ptr then do;
	  count = count + 1;	/* found one, now look for previous */
	  last_invocation = lfp;
	end;

        if (count >= P_invocation)
	   | (level_frame.number >= stack_info.max_level)
	then
	     continue_tracing = "0"b;
	else lfp = level_frame.next;	/* consider the previous frame */
      end;
    end;

  if last_invocation = null () then do; /* not even one */
      found_source_info.stack_ptr, found_source_info.instruction_ptr = null;
      goto MAIN_RETURN;
    end;

  found_source_info = last_invocation -> level_frame.source_info;

  goto MAIN_RETURN;			/* end of code for $find_previous_invocation entry */

  /*  */
probe_stack_trace_$condition_raised:
  entry (P_probe_info_ptr, P_sourcep, P_cond_name);


  call setup;
  level_source_ptr = P_sourcep;

  do lfp = stack_info.level_chain repeat level_frame.next
       while (level_frame.number <= stack_info.max_level);
    if level_frame.stack_ptr = found_source_info.stack_ptr
      then do;
        if level_frame.condition_frame_ptr = null () then do;
				/* don't let f_c_i_ do this, it does it wrong */
	  P_cond_name = "";		/* no condition */
	  goto MAIN_RETURN;
	end;

        call find_condition_info_ ((level_frame.condition_frame_ptr),
	   addr (cond_info), (0));
        P_cond_name = cond_info.condition_name;
        goto MAIN_RETURN;
      end;
  end;				/* loop */
  P_cond_name = "";			/* not found ! unlikely */
  goto MAIN_RETURN;			/* end of code for condition_raised */

probe_stack_trace_$find_condition_frame:
  entry (P_probe_info_ptr, P_sourcep, P_cond_name);

  call setup;

  level_source_ptr = P_sourcep;

  begin;
    dcl other_frame		  ptr;
    dcl error_frame		  ptr;

    other_frame, error_frame = null ();
    lfp = stack_info.level_chain;
    continue_tracing = "1"b;		/* curse pl1, which lacks do ... until */
    do while (continue_tracing);
      if level_frame.condition_frame_ptr ^= null
        then
	   if level_frame.error_signalled
				/* "error" is less interesting then others */
	     then if error_frame = null
		  then error_frame = lfp;
				/* first instance of "error" */
		  else ;		/* not the first, leave ptr alone */
	     else other_frame = lfp;	/* more interesting error, search done */

      if (level_frame.number >= stack_info.max_level)
	 | (other_frame ^= null ())
        then
	   continue_tracing = "0"b;
        else lfp = level_frame.next;
    end;				/* loop through frames */

    if other_frame = null
      then /* got no interesting one? */
	 other_frame = error_frame;	/* so use "error" */

    if other_frame = null then do;
        P_cond_name = "";
        found_source_info.stack_ptr,
	   found_source_info.entry_ptr,
	   found_source_info.block_ptr,
	   found_source_info.instruction_ptr = null ();
      end;
      else do;
        call find_condition_info_
	   ((other_frame -> level_frame.condition_frame_ptr),
	   addr (cond_info), code);
        P_cond_name = cond_info.condition_name;
        found_source_info = other_frame -> level_frame.source_info;
      end;
  end;				/* begin block */

  goto MAIN_RETURN;			/* end of code for $find_condition_frame entry point */

  /*  */

probe_stack_trace_$current_level:
  entry (P_probe_info_ptr) returns (fixed bin);

  /* Returns the number (as traced by "stack") of the current frame */


  call setup;

  lfp = stack_info.level_chain;
  return (level_frame.printed_number);

  /* end of code for $current_level entrypoint */

  /*  */

probe_stack_trace_$get_level:
  entry (P_probe_info_ptr, P_sourcep, P_level_number, P_level_decimal);


  call setup;
  level_source_ptr = P_sourcep;

  i = max (1, P_level_number);	/* must be positive */

  lfp = stack_info.level_chain;
  continue_tracing = "1"b;		/* curse pl1, which lacks do ... until */
  do while (continue_tracing & lfp ^= null);
				/* find indicated frame */

    saved_lfp = lfp;

    if level_frame.printed_number = i
         & level_frame.printed_decimal = P_level_decimal
      then
	 continue_tracing = "0"b;
      else lfp = lfp -> level_frame.next;
  end;

  if lfp = null
    then lfp = saved_lfp;		/* asked for too high a number; give highest */
  P_sourcep -> source_info = level_frame.source_info;

  goto MAIN_RETURN;			/* end of code for $get_level entrypoint */

  /*  */

probe_stack_trace_$find_frame:
  entry (P_probe_info_ptr, P_sourcep, P_stack_frame_ptr);


  call setup;
  level_source_ptr = P_sourcep;

  lfp = stack_info.level_chain;
  continue_tracing = "1"b;		/* curse pl1, which lacks do ... until */
  do while (continue_tracing);	/* search all frames for one that matches */
    if level_frame.stack_ptr = P_stack_frame_ptr then do;
				/* found it */
        found_source_info = level_frame.source_info;
        goto MAIN_RETURN;
      end;
    if level_frame.number >= stack_info.max_level
      then
	 continue_tracing = "0"b;
      else lfp = level_frame.next;
  end;

  found_source_info.stack_ptr,
       found_source_info.block_ptr,
       found_source_info.instruction_ptr,
       found_source_info.entry_ptr = null ();
  goto MAIN_RETURN;			/* end of code for $find_frame entrypoint */

  /*  */

probe_stack_trace_$find_block_frame:
  entry (P_probe_info_ptr, P_sourcep);

  /* given a block pointer, search the stack for the first frame whose block is the given
   block - if not found, then found_source_info.stack_ptr will be null () */


  call setup;
  level_source_ptr = P_sourcep;

  if found_source_info.block_ptr = null ()
    then call probe_error_$malfunction (probe_info_ptr, 0,
	    "null block ptr in call to find_block_frame");

  continue_tracing = "1"b;		/* I wish we had do ... until */
  lfp = stack_info.level_chain;
  do while (continue_tracing);
    if level_frame.block_ptr = found_source_info.block_ptr then do;
        found_source_info = level_frame.source_info;
        goto MAIN_RETURN;
      end;

    if level_frame.number >= stack_info.max_level
      then
	 continue_tracing = "0"b;
      else lfp = level_frame.next;
  end;				/* of loop through frames */

  found_source_info.stack_ptr = null ();
  goto MAIN_RETURN;
				/* end of code for $find_block_frame entrypoint */

  /*  */

probe_stack_trace_$where_source_info:
  entry (P_probe_info_ptr, P_sourcep, P_level_number, P_block_name);


  call setup;
  level_source_ptr = P_sourcep;

  continue_tracing = "1"b;		/* I wish we had do ... until */
  lfp = stack_info.level_chain;
  do while (continue_tracing);	/* look for the frame for the current block */
    if level_frame.stack_ptr = found_source_info.stack_ptr
         & level_frame.block_ptr = found_source_info.block_ptr then do;
        P_level_number = level_frame.printed_number;
        P_block_name =
	   probe_block_name_ (probe_info_ptr,
	   addr (level_frame.source_info), "0"b);
        goto MAIN_RETURN;
      end;

    if level_frame.number >= stack_info.max_level
      then
	 continue_tracing = "0"b;
      else lfp = level_frame.next;
  end;

  /* not found, so make the name by using the input, and hope there's enough
   information there to make a coherent name */

  P_block_name =
       probe_block_name_ (probe_info_ptr, addr (found_source_info), "0"b);
  P_level_number = -1;		/*  show failure */

  goto MAIN_RETURN;			/* no frame for block */

  /*  */
setup:
  proc;


  probe_info_ptr = P_probe_info_ptr;

  call probe_trace_a_stack_ (probe_info_ptr,
       probe_info.current_stack_frame -> frame.back,
       (stack_info.traced_with_all));
  end setup;


  /*	INCLUDE FILES	*/

  /* ;;;;;;; */

%include probe_info;

  /* ;;;;;;; */

%include probe_static_info;

  /* ;;;;;;; */

%include probe_source_info;

  /* ;;;;;;; */

%include probe_seg_info;

  /* ;;;;;;; */

%include probe_level_frame;

  /* ;;;;;;; */

%include stack_frame;

  /* ;;;;;;; */

%include stack_header;

  /* ;;;;;;; */

%include lot;

  /* ;;;;;;; */

%include stu_frame;

  /* ;;;;;;; */

%include condition_info;

  /* ;;;;;;; */

%include runtime_symbol;

  /* ;;;;;;; */

%include std_symbol_header;

  /* ;;;;;;; */

%include pl1_symbol_block;

  /* ;;;;;;; */

%include probe_lang_types;

  /* ;;;;;;; */

%include statement_map;

  end;				/* probe_stack_trace_ external procedure */




		    probe_statement_number_.pl1     10/24/88  1622.9rew 10/24/88  1343.2       35046



/****^  ***********************************************************
        *                                                         *
        * 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_statement_number_:
  proc (P_probe_info_ptr, P_location, P_seg_info_ptr) returns (fixed bin);

  /* *	This routine is used to find the statement number (the index in the
   *	array of map_array entries) of a given location in the object program.
   *	In order to save time, it first estimates the location of the entry.
   *
   *	Created in the mists of antiquity, probably by J. M. Broughton
   *	Converted to probe 4.0 and renamed to probe_statement_number_, 05/28/79 W. Olin Sibert */

  dcl (
      P_probe_info_ptr	pointer,
      P_location		bit (18), /* offset in object program */
      P_seg_info_ptr	pointer
      )			parameter;

  dcl found_statement	fixed bin;

  dcl 1 map_array		(1) aligned based like statement_map;

  dcl probe_info_ptr	pointer;	/* to avoid including probe_info */
  dcl seg_info_ptr		pointer;
  dcl loc			fixed bin (24);
				/* binary version of location */
  dcl sp			pointer;	/* start of statement map */
  dcl first		fixed bin (24);
				/* first location in program */
  dcl last		fixed bin (24);
				/* last location plus one */
  dcl try			fixed bin;/* first estimate of statement number */
  dcl (i, j)		fixed bin;

  dcl (binary, divide, fixed, null)
			builtin;
				/*  */

  /* get pointers to statemen_map, etc, and make guess as to where entry is */

  probe_info_ptr = P_probe_info_ptr;
  seg_info_ptr = P_seg_info_ptr;

  if seg_info_ptr = null ()
    then /* something wrong with it */
         goto NOT_FOUND;

  loc = binary (P_location, 18, 0);
  sp = seg_info_ptr -> seg_info.statement_map_ptr;
  if sp = null
    then goto NOT_FOUND;		/* caller may worry about error */

  first = binary (sp -> map_array (1).location, 18, 0);
  if loc < first
    then goto NOT_FOUND;		/* location is before beginning */
  last =
       binary (sp -> map_array (seg_info_ptr -> seg_info.map_size).location,
       18, 0);
  if loc >= last
    then goto NOT_FOUND;		/* location is after end */

  try = divide (seg_info_ptr -> seg_info.map_size * (loc - first),
       (last - first), 17, 0) + 1;

  /* look for appropriate map entry, ie one containing location */

  do i = try by 1 /* if too big, look for entry above loc wanted */
       while (loc > fixed (sp -> map_array (i).location));
  end;

  do j = i by -1 /* look for one below loc, if too small */
       while (loc < fixed (sp -> map_array (j).location));
  end;

  found_statement = j;		/* if it was equal, it will fall through */

  return (found_statement);


NOT_FOUND:
  found_statement = -1;
  return (found_statement);

  /*  */

%include probe_seg_info;

  /* ;;;;;;; */

%include statement_map;

  end;				/* probe_statement_number_ external procedure */




		    probe_subsys_util_.pl1          10/27/88  1250.2r w 10/27/88  1225.2      161919



/****^  ***********************************************************
        *                                                         *
        * 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_subsys_util_:
  proc ();

  return;				/* dummy entry */

  /* *	This procedure contains some utility routines for the "probe" debugger. */
  /* *	Shamelessly stolen from subsystem_util_, 04/22/79 W. Olin Sibert */
  /* *	Efficiency improved (it uses about 10% of all time in conditional bk), 28 Feb 80 JRD */
  /* Changed not to create breakseg (done now by probe_break_mgr_) 09/28/81 S. Herbst */
  /* Changed to store probe_static_info.probe_segno for use by probe_break_handler_ 10/07/81 S. Herbst */
  /* Changed to use 1 scratch segment per ring 12/29/81 S. Herbst */

  dcl (
      P_version		fixed bin,/* version number for validity check */
      P_invocation_ptr	pointer,	/* -> new/old invocation data created/to destroy */
      P_code		fixed binary (35)
      )			parameter;/* status code */

  dcl code		fixed bin (35);
  dcl old_invocation_ptr	pointer;
  dcl probe_scratch_ptr	pointer;
  dcl probe_static_info_ptr	pointer;

  dcl based_area		area based;

  dcl com_err_		entry options (variable);
  dcl cu_$cl		entry (bit (1) aligned);
  dcl define_area_		entry (pointer, fixed bin (35));
  dcl get_temp_segment_	entry (char (*), ptr, fixed bin (35));
  dcl hcs_$truncate_seg	entry (pointer, fixed bin (19), fixed (35));
  dcl probe_modes_mgr_$init	entry (pointer);

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

  dcl probe_request_table_$	fixed bin external static;
  dcl probe_data_$major_version
			fixed bin external static;
  dcl probe_data_$minor_version
			fixed bin external static;
  dcl probe_data_$version_string
			char (32) aligned external static;
  dcl probe_data_$info_directory
			char (168) aligned external static;
  dcl probe_data_$prompt_string
			char (32) varying external static;

  dcl probe_data_$invocation_list_ptr
			pointer external static;
  dcl probe_data_$probe_static_info_ptr
			pointer external static;
  dcl probe_data_$probe_scratch_ptr
			pointer external static;

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

  dcl RW_MODE		fixed bin (5) internal static
			options (constant) init (01010b);

  dcl (addr, baseno, codeptr, copy, hbound, null, size,
      string, unspec)	builtin;

  /*  */

probe_subsys_util_$create_invocation:
  entry (P_version, P_invocation_ptr, P_code);

  /* *	This entry creates a new invocation of probe. It strings it on the list of
   *	active invocations; the head of this list is in external static, called
   *	probe_data_$invocation_list_ptr. P_invocation_ptr is a pointer (output) to
   *	a probe_info structure and associated items which is allocated (in system_free_4_)
   *	by this procedure. The caller must correctly supply P_version. As long as at least
   *	one invocation of a probe is active, the values of listener_info.depth will
   *	never be repeated. */

  if P_version ^= probe_info_version_1 then do;
				/* our only validity check */
      P_code = error_table_$unimplemented_version;
      return;
    end;

  code = 0;			/* we're successful */
  old_invocation_ptr = probe_data_$invocation_list_ptr;
  probe_static_info_ptr = probe_data_$probe_static_info_ptr;
  P_invocation_ptr = null ();

  if probe_static_info_ptr = null () then do;
				/* similarly, create probe_static_info if not there */

      call create_probe_scratch ();	/* get temp segment */

      call create_probe_static_info (); /* this sets probe_static_info_ptr */
    end;
    else probe_scratch_ptr = probe_data_$probe_scratch_ptr;

  if code ^= 0
    then goto INITIALIZATION_ERROR;

  call create_probe_info ();		/* set up the database we were called about */

  probe_info.listener_info.previous = old_invocation_ptr;
				/* chain into recursion list */
  probe_info.listener_info.next = null ();

  if old_invocation_ptr ^= null () then do;
				/* new level, not first */
      probe_info.listener_info.depth =
	 old_invocation_ptr -> probe_info.listener_info.depth + 1;
      old_invocation_ptr -> probe_info.listener_info.next = probe_info_ptr;
    end;
    else probe_info.listener_info.depth = 1;
				/* first level */

  probe_data_$invocation_list_ptr = probe_info_ptr;
				/* update invocation chain */
  P_invocation_ptr = probe_info_ptr;

INITIALIZATION_ERROR:
  P_code = code;

  return;				/* end of code for $create_invocation entry */

  /*  */

probe_subsys_util_$destroy_invocation:
  entry (P_invocation_ptr);

  /* *	This entry destroys an invocation of probe. */

  probe_info_ptr = P_invocation_ptr;
  old_invocation_ptr = probe_data_$invocation_list_ptr;
  probe_scratch_ptr = probe_data_$probe_scratch_ptr;
  probe_static_info_ptr = probe_data_$probe_static_info_ptr;

  if probe_info_ptr = null ()
    then return;			/* decide whether we can do anything */
  if probe_static_info_ptr = null ()
    then return;
  if probe_scratch_ptr = null ()
    then return;
  if old_invocation_ptr = null ()
    then return;

  if probe_data_$invocation_list_ptr = P_invocation_ptr
    then
         probe_data_$invocation_list_ptr = probe_info.listener_info.previous;
				/* pop back a level iff one to destroy is last */

  if probe_info.listener_info.previous ^= null ()
    then
         probe_info.listener_info.previous -> probe_info.listener_info.next =
	    probe_info.listener_info.next;

  if probe_info.listener_info.next ^= null ()
    then
         probe_info.listener_info.next -> probe_info.listener_info.previous =
	    probe_info.listener_info.previous;

  free probe_info.ptr_to_current_source
       -> current_source in (probe_scratch_ptr -> based_area);
  free probe_info.ptr_to_initial_source
       -> initial_source in (probe_scratch_ptr -> based_area);

  free probe_info in (probe_scratch_ptr -> based_area);
				/* get rid of the last trace */

  return;				/* end of code for $destroy_invocation entry */

  /*  */

NULL_LABEL:
  call com_err_ (0, "probe",
       "Attempt to goto null label variable. Returning to command level.");

  call cu_$cl ("0"b);

  goto NULL_LABEL;

  /*  */

create_probe_info:
  proc ();

  /* *	This procedure sets all the values in probe_info to their default settings */

  allocate probe_info in (probe_scratch_ptr -> based_area)
       set (probe_info_ptr);

  allocate current_source in (probe_scratch_ptr -> based_area)
       set (probe_info.ptr_to_current_source);

  allocate initial_source in (probe_scratch_ptr -> based_area)
       set (probe_info.ptr_to_initial_source);

  probe_info.probe_info_version = probe_info_version_1;

  probe_info.static_info_ptr = probe_data_$probe_static_info_ptr;
  probe_info.modes_ptr = probe_static_info.modes_ptr;

  probe_info.machine_cond_ptr = null ();

  probe_info.first_token = null ();
  probe_info.ct = null ();
  probe_info.end_token = "000000"b3;
  probe_info.buffer_ptr = null ();
  probe_info.buffer_lth = 0;

  probe_info.current_stack_frame = null ();
  probe_info.input_type = 0;
  probe_info.language_type = 0;
  probe_info.return_method = 0;
  probe_info.entry_method = 0;

  probe_info.break_slot_ptr = null ();	/* initialize the break_info substructure */
  probe_info.last_break_slot_ptr = null ();
  probe_info.break_reset = "0"b;
  probe_info.real_break_return_loc = null ();

  probe_info.break_segment_ptr = probe_static_info.break_segment_ptr;
  probe_info.break_area_ptr = null ();
  probe_info.scratch_area_ptr = probe_data_$probe_scratch_ptr;
  probe_info.probe_area_ptr = null ();
  probe_info.work_area_ptr = null ();
  probe_info.expression_area_ptr = null ();

  string (probe_info.flags) = ""b;
  probe_info.flags.execute = "1"b;

  probe_info.input_switch = probe_static_info.input_switch;
  probe_info.output_switch = probe_static_info.output_switch;

  probe_info.error_code = 0;
  probe_info.error_message = "<<NO MESSAGE>>";

  probe_info.request_name = "<<NO REQUEST>>";
  probe_info.abort_probe_label = NULL_LABEL;
  probe_info.abort_line_label = NULL_LABEL;
  probe_info.depth = 0;
  probe_info.previous = null ();
  probe_info.next = null ();

  current_source.stmnt_map_entry_index = -1;
  current_source.instruction_ptr = null ();
  current_source.stack_ptr = null ();	/* now initialize things probe_info refers to */
  current_source.entry_ptr = null ();
  current_source.block_ptr = null ();
  current_source.seg_info_ptr = null ();

  initial_source.stmnt_map_entry_index = -1;
  initial_source.instruction_ptr = null ();
  initial_source.stack_ptr = null ();	/* now initialize things probe_info refers to */
  initial_source.entry_ptr = null ();
  initial_source.block_ptr = null ();
  initial_source.seg_info_ptr = null ();

  return;
  end;				/* create_probe_info internal procedure */

  /*  */

create_probe_scratch:
  proc ();

  /* *	This procedure creates the probe_scratch_ segment in the process dir,
   *	and initializes its area. It contains nothing but a segment size area;
   *	all information for managing it is kept in probe_static_info. */

  dcl 1 scratch_area_info	aligned like area_info;
				/* automatic copy */

  call get_temp_segment_ ("probe_scratch_", probe_scratch_ptr, code);
  if probe_scratch_ptr = null ()
    then goto INITIALIZATION_ERROR;	/* punt if it fails; Note that this will */
				/* re-use an old scratch seg if one was present */

  call hcs_$truncate_seg (probe_scratch_ptr, 0, (0));
				/* eliminate its former contents, if any */

  unspec (scratch_area_info) = ""b;

  scratch_area_info.version = area_info_version_1;
				/* prepare to initialize the area */

  string (scratch_area_info.control) = ""b;
				/* set all the flags */
  scratch_area_info.extend = "0"b;
  scratch_area_info.zero_on_alloc = "0"b;
  scratch_area_info.zero_on_free = "0"b;
  scratch_area_info.dont_free = "0"b;
  scratch_area_info.no_freeing = "0"b;
  scratch_area_info.system = "0"b;

  scratch_area_info.owner = "probe scratch area";
  scratch_area_info.size = sys_info$max_seg_size;
				/* a whole segment, more or less */

  scratch_area_info.areap = probe_scratch_ptr;

  call define_area_ (addr (scratch_area_info), code);
  if code ^= 0
    then goto INITIALIZATION_ERROR;	/* sorry, we lose */

  probe_data_$probe_scratch_ptr = probe_scratch_ptr;
				/* remember it in our external static */

  return;
  end;				/* create_probe_scratch niternal procedure */

  /*  */

create_probe_static_info:
  proc ();

  /* *	This procedure allocates and initializes the probe_static_info structure.
   *	It is allocated in the probe scratch area, which is pointed to by probe_scratch_ptr.
   *	At the end, probe_data_$probe_static_info_ptr is set to point to it.  There is one
   *	of these structures per process; it contains global probe data. */

  dcl probe_modes_ptr	pointer unaligned;
  dcl seg_info_ptr		pointer unaligned;
  dcl probe_seg_mgr_$get_breakseg_ptr
			entry (fixed bin (35)) returns (ptr);

  allocate probe_static_info in (probe_scratch_ptr -> based_area)
       set (probe_static_info_ptr);

  unspec (probe_static_info_ptr -> probe_static_info) =
       copy ("777043777043"b3, size (probe_static_info));

  probe_static_info_ptr -> probe_static_info.probe_info_version =
       probe_info_version_1;

  probe_static_info_ptr -> probe_static_info.major_version =
       probe_data_$major_version;
  probe_static_info_ptr -> probe_static_info.minor_version =
       probe_data_$minor_version;
  probe_static_info_ptr -> probe_static_info.version_string =
       probe_data_$version_string;

  probe_static_info_ptr -> probe_static_info.name = "probe";
  probe_static_info_ptr -> probe_static_info.prompt =
       probe_data_$prompt_string;
  unspec (probe_static_info_ptr -> probe_static_info.switches) = "0"b;

  probe_static_info_ptr -> probe_static_info.break_segment_ptr =
       probe_seg_mgr_$get_breakseg_ptr (code);
  if code ^= 0
    then return;
				/* initialize breakseg only before setting a break */
  probe_static_info_ptr -> probe_static_info.scratch_segment_ptr =
       probe_scratch_ptr;

  probe_static_info_ptr -> probe_static_info.probe_segno =
       baseno (codeptr (probe_subsys_util_));
				/* probe's own segment number */
  probe_static_info_ptr -> probe_static_info.last_break_segno = "0"b;

  probe_static_info_ptr -> probe_static_info.stack_info.traced_with_all =
       "0"b;
  probe_static_info_ptr -> probe_static_info.stack_info.max_level = -1;
  probe_static_info_ptr -> probe_static_info.stack_info.level_chain = null ();

  probe_static_info_ptr -> probe_static_info.request_table_ptr_array (*) =
       null ();
  probe_static_info_ptr -> probe_static_info.info_directory_name_array (*) =
       "";
  probe_static_info_ptr -> probe_static_info.exclude_name_array (*) = "";

  probe_static_info_ptr -> probe_static_info.input_switch = iox_$user_input;
  probe_static_info_ptr -> probe_static_info.output_switch = iox_$user_output;

  probe_static_info_ptr -> probe_static_info.request_table_ptr_array (1) =
       addr (probe_request_table_$);
  probe_static_info_ptr -> probe_static_info.info_directory_name_array (1) =
       probe_data_$info_directory;

  probe_static_info_ptr -> probe_static_info.request_table_info.array_ptr =
       addr (probe_static_info_ptr
       -> probe_static_info.request_table_ptr_array);
  probe_static_info_ptr -> probe_static_info.request_table_info.array_size =
       1;
  probe_static_info_ptr
       -> probe_static_info.request_table_info.array_max_size =
       hbound (probe_static_info.request_table_ptr_array, 1);
  probe_static_info_ptr
       -> probe_static_info.request_table_info.using_internal_array = "1"b;

  probe_static_info_ptr -> probe_static_info.info_directory_info.array_ptr =
       addr (probe_static_info_ptr
       -> probe_static_info.info_directory_name_array);
  probe_static_info_ptr -> probe_static_info.info_directory_info.array_size =
       1;
  probe_static_info_ptr
       -> probe_static_info.info_directory_info.array_max_size =
       hbound (probe_static_info.info_directory_name_array, 1);
  probe_static_info_ptr
       -> probe_static_info.info_directory_info.using_internal_array = "1"b;

  probe_static_info_ptr -> probe_static_info.exclude_name_info.array_ptr =
       addr (probe_static_info_ptr -> probe_static_info.exclude_name_array);
  probe_static_info_ptr -> probe_static_info.exclude_name_info.array_size = 0;
  probe_static_info_ptr
       -> probe_static_info.exclude_name_info.array_max_size =
       hbound (probe_static_info.exclude_name_array, 1);
  probe_static_info_ptr
       -> probe_static_info.exclude_name_info.using_internal_array = "1"b;

  seg_info_offset_count = 1023;	/* start out with 1024 entries, until the LOT exceeds it */
  allocate probe_seg_info_array in (probe_scratch_ptr -> based_area)
       set (probe_static_info_ptr -> probe_static_info.seg_info_offset_ptr);
  probe_static_info_ptr -> probe_static_info.seg_info_offset_ptr
       -> probe_seg_info_array.count =
       seg_info_offset_count;

  allocate probe_modes in (probe_scratch_ptr -> based_area)
       set (probe_modes_ptr);

  call probe_modes_mgr_$init ((probe_modes_ptr));
				/* get default values for modes */

  probe_static_info_ptr -> probe_static_info.modes_ptr = probe_modes_ptr;
				/* copy it into static structure */

  seg_info_nfiles = 1;		/* allocate the "null" seg_info block */
  allocate seg_info in (probe_scratch_ptr -> based_area) set (seg_info_ptr);

  seg_info_ptr -> seg_info.language_type = OTHER_lang_type;
				/* and fill it in */
  string (seg_info_ptr -> seg_info.bits) = ""b;
  seg_info_ptr -> seg_info.directory_name = "<<NO DIRECTORY>>";
  seg_info_ptr -> seg_info.entry_name = "<<NO ENTRY NAME>>";
  seg_info_ptr -> seg_info.segname = "<<NO ENTRYPOINT>>";
  seg_info_ptr -> seg_info.identifier = -1;
				/* better than zero, even */
  seg_info_ptr -> seg_info.pointers = null ();
				/* set them all to null */
  seg_info_ptr -> seg_info.bounds = 0;	/* set all the bounds information to zeros */
  seg_info_ptr -> seg_info.map_size = -1;
  seg_info_ptr -> seg_info.error_code = -1;
  seg_info_ptr -> seg_info.pad (*) = -1;
  seg_info_ptr -> seg_info.nfiles = 1;
  seg_info_ptr -> seg_info.file_pointers (1) = null ();

  probe_static_info_ptr -> probe_static_info.null_seg_info_ptr = seg_info_ptr;
				/* remember where it is */

  probe_data_$probe_static_info_ptr = probe_static_info_ptr;
				/* remember it in external static */

  return;
  end create_probe_static_info;

  /*  */

%include probe_info;

  /* ;;;;;;; */

%include probe_static_info;

  /* ;;;;;;; */

%include probe_modes;

  /* ;;;;;;; */

%include probe_source_info;

  /* ;;;;;;; */

%include probe_seg_info;

  /* ;;;;;;; */

%include probe_info_constants;

  /* ;;;;;;; */

%include probe_lang_types;

  /* ;;;;;;; */

%include area_info;

  end;				/* probe_subsys_util_ external procedure */




		    probe_trace_a_stack_.pl1        10/27/88  1250.2r w 10/27/88  1225.2      119736



/****^  ***********************************************************
        *                                                         *
        * 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.
                                                   END HISTORY COMMENTS */


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

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

probe_trace_a_stack_:
  proc (P_probe_info_ptr, P_first, P_all);

  /* trace the stack, starting at the frame P_first - build structure of levels   in the area scratch_area

   James R. Davis 22 June 79
   Modified 25 Aug 79 JRD */
  /* Changed to store component info for each stack frame 09/18/81 S. Herbst */
  /* Changed to store printed frame number I.J, J^=0 for support frames 12/10/81 S. Herbst */
  /* Changed to detect caller loop in symbol table, and stop 02/25/82 S. Herbst */
  /* Removed remaining call to stu_$get_runtime_block (calling stu_find_containing_block instead) 10/31/83 M. Weaver */
  /* Changed not to print funny quick-block levels for which no instruction_ptr 02/17/84 S. Herbst */

  dcl P_probe_info_ptr	ptr aligned parameter;
  dcl P_first		ptr aligned parameter;
  dcl P_all		bit (1) aligned parameter;
				/* include support frames? */

  dcl include_support	bit (1) aligned;
  dcl (p, prev_lfp, saved_lfp, test_lfp)
			ptr;
  dcl (frame_decimal, frame_number)
			fixed bin;
  dcl code		fixed bin (35);
  dcl condition_frame	ptr;	/*  to most recent frame where a condition occured */
  dcl was_error		bit (1) aligned;
				/* was that condition "error" ? */

  dcl component_info_$offset	entry (ptr, fixed bin (18), ptr, fixed bin (35))
			;
  dcl find_condition_info_	entry (ptr, ptr, fixed bin (35));
  dcl stack_frame_exit_	entry (ptr, ptr, ptr, bit (1) aligned, ptr,
			char (32) aligned, ptr);
  dcl is_condition_frame_	entry (ptr) returns (bit (1) aligned);

  dcl 1 frame_situation	aligned like stack_frame_exit_str;
  dcl 1 cond_info		aligned like condition_info;

  dcl probe_seg_info_	entry (ptr, ptr, fixed bin (35)) returns (ptr);

  dcl (addr, addrel, baseno, bin, binary, null, ptr, rel,
      string, stackbaseptr, unspec)
			builtin;

  dcl area		condition;


  probe_info_ptr = P_probe_info_ptr;
  include_support = P_all;
  if stack_info.good_stack & include_support = stack_info.traced_with_all
    then return;

  stack_info.max_level = 0;		/* haven't got any frames yet */
  stack_info.traced_with_all = include_support;
  lfp, prev_lfp = null ();		/* have no frames at the start */
  condition_frame = null ();		/* there are no conditions */
  was_error = "0"b;			/* and none are "error" */

  do sp = P_first repeat (sp -> stack_frame.prev_sp) while (sp ^= null);
    if is_condition_frame_ (sp)
      then do;
        condition_frame = sp;		/* it happended here */
        call find_condition_info_ (sp, addr (cond_info), (0));
        was_error = is_this_an_error_frame ();
      end;			/* condition framing */
      else cond_info.mc_ptr, cond_info.wc_ptr = null ();

    if this_frame_should_be_traced () then do;
        lfp = new_level ();

        level_frame.support = sp -> stack_frame_flags.support;

        level_frame.condition_frame_ptr = condition_frame;
        level_frame.flags.error_signalled = was_error;
        condition_frame = null ();	/* has been claimed */
        was_error = "0"b;

        call stack_frame_exit_ (sp, cond_info.mc_ptr, cond_info.wc_ptr,
	   (sp -> stack_frame_flags.crawl_out),
	   p, (""), addr (frame_situation));

        level_frame.instruction_ptr = p;
        level_frame.stack_ptr = sp;

        if frame_situation.entry_ptr_invalid
				/* only return_to_ring_0 will be invalid */
	then level_frame.seg_info_ptr =
		probe_seg_info_ (probe_info_ptr, null (), (0));
				/* this is dummy */
	else call analyze_frame (sp); /* there is much to learn about this frame */
      end;			/* of handling frame we like */
  end;				/* of loop thru stack */

RENUMBER:
  frame_number, frame_decimal = 0;

  do p = lfp repeat (p -> level_frame.prev) while (p ^= null);
    if p -> level_frame.support
      then frame_decimal = frame_decimal + 1;
      else do;
        frame_number = frame_number + 1;
        frame_decimal = 0;
      end;
    p -> level_frame.printed_number = frame_number;
    p -> level_frame.printed_decimal = frame_decimal;
  end;

  stack_info.good_stack = "1"b;
  return;

is_this_an_error_frame:
  proc () returns (bit (1) aligned);
  return (cond_info.condition_name = "error" &
       cond_info.info_ptr = null () & cond_info.mc_ptr = null ());
  end is_this_an_error_frame;


this_frame_should_be_traced:
  proc () returns (bit (1) aligned);
  return (include_support | ^sp -> stack_frame_flags.support);
  end this_frame_should_be_traced;


analyze_frame:
  proc (a_sp);

  dcl a_sp		ptr parameter;
  dcl stu_$find_containing_block
			entry (ptr, fixed bin (18) unsigned)
			returns (ptr);
  dcl stu_$get_map_index	entry (ptr, fixed bin (18) unsigned, fixed bin,
			ptr);

  dcl bp			ptr;	/* to runtime_block node */
  dcl hp			ptr;	/* to std_symbol_header */

  dcl entryp		ptr;
  dcl seg_infop		ptr;
  dcl continue_tracing	bit (1) aligned;



  entryp = a_sp -> stack_frame.entry_ptr;
				/* entry that created this frame */

  level_frame.seg_info_ptr, seg_infop =
       probe_seg_info_ (probe_info_ptr, entryp, code);
  level_frame.run_unit_manager = a_sp -> stack_frame_flags.run_unit_manager;

  hp = level_frame.seg_info_ptr -> seg_info.symbol_header_ptr;

  if hp ^= null ()
    then call stu_$get_map_index (hp, bin (rel (p), 18),
	    level_frame.stmnt_map_entry_index, (null));

  bp = stu_$find_containing_block (hp, bin (rel (p), 18));

  if bp = null () /* no symbol table can do no more */
    then do;
      level_frame.entry_ptr = entryp;
    end;
    else do;

      /* may be a quick block - first calculate information that will be true for all blocks that share this frame
   then trace back quick calls */

      level_frame.block_ptr = bp;

      saved_lfp = lfp;

      continue_tracing = bp -> runtime_block.quick;
				/* trace only while we're quick */
      do while (continue_tracing);
        level_frame.flags.quick = "1"b; /* obviously */

        /* first location of this block executed */
        level_frame.entry_ptr =
	   ptr (bp,
	   addrel (bp, bp -> runtime_block.first) -> statement_map.location)
	   ;

        /* is the above wrong thing to do for multiple entry blocks?
   probably so, but how can you tell if thats the case ? */

        if seg_infop -> seg_info.language_type = FORTRAN_lang_type
				/* FT quick block is also externally callable - skip the
						   descriptor flag,   point to real entry seq */
	then level_frame.entry_ptr = addrel (level_frame.entry_ptr, 1);

        /* now get ptr to caller, and determine block */

        if bp -> runtime_block.entry_info ^= "0"b /* quick proc */
	then do;
	  p = addrel (a_sp, bp -> runtime_block.entry_info)
	       -> quick_entry.return;

	  /* for FT the quick_entry.return ptr is left pointing into pl1 operators, so that
   the returing quick block will skip the non-quick father and go directly to father's caller */

	  if baseno (p)
	       = baseno (stackbaseptr () -> stack_header.pl1_operators_ptr)
	    then do;
	      p = null ();		/* no place to return to in THIS seg */
	      bp = addrel (bp, bp -> runtime_block.father);
	    end;

	    /* additional code here would ensure that there was only one frame in the level_chain
   for this FT case, thus users would see only one fram,e, which is what they want to see */

	    else do;
	      p = addrel (p, -1);	/* point to the calling instruction */
	      bp = stu_$find_containing_block (hp, bin (rel (p), 18));
	    end;
	end;			/* entry info hacking */
	else do;			/* assume begin block */
	  p = addrel (level_frame.entry_ptr, -1);
				/* assume we fell in */
	  bp = addrel (bp, bp -> runtime_block.father);
				/* "called" by father, obviously */
	end;

        /* now p -> last loc in caller, bp is callers block */
        do test_lfp = lfp /* detect caller loop in symbol table */
	   repeat (test_lfp -> level_frame.prev)
	   while (test_lfp ^= saved_lfp);

	if test_lfp -> level_frame.block_ptr = bp
	  then go to NO_MORE_QUICK;
        end;


        /* make a new level for caller, who may or may not be quick but we already know much about it */

        if p ^= null then do;		/* print level only if we have instruction_ptr */

	  lfp = new_level ();

	  level_frame.instruction_ptr = p;
	  level_frame.block_ptr = bp;
	  level_frame.stack_ptr = a_sp;
	  level_frame.seg_info_ptr = seg_infop;

	  if p ^= null
	    then call stu_$get_map_index (hp, bin (rel (p), 18),
		    level_frame.stmnt_map_entry_index, (null));

	  if bp = null ()		/* can't find father ! */
	    then continue_tracing = "0"b;
	  else if bp -> runtime_block.quick
	    then continue_tracing = "1"b;
				/* how good is the optimizer? */
	  else continue_tracing = "0"b;
				/* fatherblock is owner */
	end;
	else continue_tracing = "0"b;
      end;			/* quick loop */

NO_MORE_QUICK:
				/* now we know we have a level for the OWNER of the frame */
      level_frame.entry_ptr = entryp;

    end;				/* frame with symbol table */

  call component_info_$offset (ptr (entryp, 0), binary (rel (entryp), 18),
       addr (ci), code);
  level_frame.component_text_ptr = null;
  if code = 0
    then
         if rel (ci.text_start) ^= "0"b then do;
	   level_frame.component_name = ci.name;
	   level_frame.component_text_ptr = text_start;
	 end;


  end analyze_frame;
				/*  */

new_level:
  proc () returns (ptr);

  /* return a ptr to a new level_frame  and intialize the new level_frame

   old level_frames from previous use in this process are re-cycled if available,
   this conserves time */

  return (initialize_level (get_ptr_to_new ()));




get_ptr_to_new:
  proc () returns (ptr);

  /* global imports scratch_area, stack_info, lfp */

  if lfp = null () /* first call , have no frames */
    then do;
      if stack_info.level_chain = null ()
        then do;			/* first time ever in whole process */
	allocate level_frame in (scratch_area) set (stack_info.level_chain);
	unspec (stack_info.level_chain -> level_frame) = "0"b;
	stack_info.level_chain -> level_frame.next = null ();
				/* obviously */
        end;
      return (stack_info.level_chain);
    end;				/* null lfp case */
    else do;			/* can use lfp */
      if level_frame.next = null /* have used them all up */
        then do;			/* must make a new one */
	on area go to RENUMBER;	/* give up if stack is too big */
	allocate level_frame in (scratch_area) set (level_frame.next);
	unspec (level_frame.next -> level_frame) = "0"b;
	level_frame.next -> level_frame.next = null ();
				/* obviously there is no next, either */
        end;			/* making a brand new level */
      return (level_frame.next);
    end;
  end get_ptr_to_new;

initialize_level:
  proc (tp) returns (ptr);

  /* initialize the level_frame we have ptr to, and return its address */
  dcl tp			ptr parameter;

  tp -> level_frame.stmnt_map_entry_index = -1;
  tp -> level_frame.instruction_ptr,
       tp -> level_frame.block_ptr, tp -> level_frame.stack_ptr,
       tp -> level_frame.entry_ptr,
       tp -> level_frame.seg_info_ptr, tp -> level_frame.condition_frame_ptr =
       null ();
  string (tp -> level_frame.flags) = "0"b;

  tp -> level_frame.number, stack_info.max_level =
       stack_info.max_level + 1;
  tp -> level_frame.prev = prev_lfp;
  prev_lfp = tp;

  return (tp);
  end initialize_level;

  end new_level;
				/*  */

%include probe_info;

  /* ;;;;;;; */

%include probe_static_info;

  /* ;;;;;;; */
  /* ;;;;;;; */

%include probe_level_frame;

  /* ;;;;;;; */

%include probe_source_info;

  /* ;;;;;;; */

%include probe_seg_info;

  /* ;;;;;;; */

%include probe_lang_types;

  /* ;;;;;;; */

%include component_info;

  /* ;;;;;;; */


%include condition_info;

  /* ;;;;;;; */

%include stack_frame_exit_str;

  /* ;;;;;;; */

%include stack_header;

  /* ;;;;;;; */

%include runtime_symbol;

  /* ;;;;;;; */

%include quick_entry;

  /* ;;;;;;; */

%include stack_frame;

  /* ;;;;;;; */

%include std_symbol_header;

  /* ;;;;;;; */

%include statement_map;

  end probe_trace_a_stack_;




		    probe_variable_mgr_.pl1         11/11/88  1555.4r w 11/11/88  1545.0      113139



/****^  ***********************************************************
        *                                                         *
        * 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-08-24,WAAnderson), approve(88-09-30,MCR7952),
     audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184):
     Added support for 'char', 'long' and 'double' data types.
  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_variable_mgr_:
  proc;

  /* Here are the entry points for probe variables:
    create_variable		to make one
    find_variable		to search for one
    list_variable		to list a single var
    list_var_ptr		to list a var given ptr
    list_all_variables	to list them all


   INITIAL IMPLEMENTATION 20 Feb 80 by Jim Davis

   "Plan to write one and throw it away."

   We have a static pointer to the chain of the variables
   We search linearly, placing new variables at the head, in the hope that they
   are the most likely to be referenced.
   Names may come in with a % in front

*/
  /* Add unaligned pointers 12/04/81 S. Herbst */
  /* Add external variables 04/26/82 S. Herbst */
  /* Replaced create_variable's P_external_sw / P_address_type & P_address_ptr for "dcl defined" 03/12/84 S.Herbst */

  dcl P_probe_info_ptr	ptr aligned parameter;
				/* used by all */
  dcl P_variable_name	char (64) varying parameter;
  dcl P_variable_type	char (64) varying parameter;
  dcl P_unaligned_sw	bit (1) aligned parameter;
  dcl P_address_type	fixed bin;
  dcl P_address_ptr		ptr;
  dcl P_force_creation	bit (1) aligned parameter;
  dcl P_reference_node_ptr	ptr aligned parameter;
				/* fill in during lookup */
  dcl P_var_info_ptr	ptr unal parameter;
  dcl P_code		fixed bin (35) parameter;

  dcl start_of_chain	ptr unal internal static init (null ());

  dcl normal_name		char (64) varying;
  dcl (seg_name, entry_point_name)
			char (64);
  dcl var_ptr		ptr;
  dcl i			fixed bin;

  dcl 1 ref		aligned like reference_node based (refp);
  dcl refp		ptr;

  dcl (
      PROBE_VAR_INTEGER_TYPE	init (1), /* fixed bin short */
      PROBE_VAR_FLOAT_TYPE	init (3), /* float bin  short */
      PROBE_VAR_POINTER_TYPE	init (13),/* ITS ptr */
      PROBE_VAR_CHAR_TYPE	init (21),/* char */
      PROBE_VAR_LONG_TYPE	init (2), /* long */
      PROBE_VAR_DOUBLE_TYPE	init (4)	/* double */
      )			fixed bin static internal options (constant);

  dcl 1 name_to_type	(6) internal static options (constant),
       2 names		(5) char (32)
			init ("fixed", "integer", "int", "comp-6",
			"computational-6",
			"float", "real", "real", "real", "real",
			"pointer", "ptr", "ptr", "ptr", "ptr",
			"double", "dbl", "dbl", "dbl", "dbl",
			"char", "char", "char", "char", "char",
			"long", "long", "long", "long", "long"),
       2 type		init (1, 3, 13, 4, 21, 2);

  dcl type_to_make		fixed bin;

  dcl (
      probe_et_$var_exists,		/* already is one */
      probe_et_$bad_dcl_type,
      probe_et_$no_vars,		/* there aren't any at all */
      probe_et_$var_doesnt_exist	/* specific one missing */
      )			fixed bin (35) external static;

  dcl get_external_variable_	entry (char (*), ptr, fixed bin (19), ptr,
			fixed bin (35));
  dcl hcs_$make_ptr		entry (ptr, char (*), char (*), ptr,
			fixed bin (35));
  dcl ioa_$ioa_switch	entry options (variable);

  dcl (index, length, null, pointer, substr)
			builtin;
%page;
MAIN_RETURN:
  return;
%page;
create_variable:
  entry (P_probe_info_ptr, P_variable_name, P_variable_type, P_unaligned_sw,
       P_address_type, P_address_ptr, P_force_creation, P_var_info_ptr,
       P_code);

  probe_info_ptr = P_probe_info_ptr;
  P_code = 0;

  type_to_make = what_type_is ((P_variable_type));
  if type_to_make < 0 then do;
      P_code = probe_et_$bad_dcl_type;
      goto MAIN_RETURN;
    end;

  normal_name = normalize_name ((P_variable_name));
  probe_variable_ptr = find_var_info (normal_name);

  if probe_variable_ptr ^= null ()
    then
         if P_force_creation
	 then call delete_current ();
	 else do;
	   P_code = probe_et_$var_exists;
	   goto MAIN_RETURN;
	 end;

  if P_address_type = ADDRESS_EXTERNAL_TYPE then do;
      i = index (normal_name, "$");
      if i ^= 0 then do;
	seg_name = substr (normal_name, 1, i - 1);
	if i < length (normal_name)
	  then entry_point_name = substr (normal_name, i + 1);
	  else entry_point_name = seg_name;
	call hcs_$make_ptr (null, seg_name, entry_point_name, var_ptr,
	     P_code);
	if var_ptr = null
	  then goto MAIN_RETURN;
	if i = length (normal_name)
	  then var_ptr = pointer (var_ptr, 0);
				/* foo$ means base of segment foo */
        end;
        else do;
	call get_external_variable_ ((normal_name), var_ptr, 0, null,
	     P_code);
	if P_code ^= 0
	  then goto MAIN_RETURN;
        end;
    end;

  allocate probe_variable;
  probe_variable.name = normal_name;
  probe_variable.declared_type = P_variable_type;
  probe_variable.type = type_to_make;
  probe_variable.unaligned_sw = P_unaligned_sw;

  if P_address_type = ADDRESS_EXTERNAL_TYPE
    then probe_variable.address = var_ptr;
  else if P_address_type = ADDRESS_GIVEN_TYPE
    then probe_variable.address = P_address_ptr;

  else if probe_variable.type = PROBE_VAR_INTEGER_TYPE then do;
      allocate probe_variable_integer in (scratch_area);
      probe_variable_integer = 0b;
    end;
  else if probe_variable.type = PROBE_VAR_FLOAT_TYPE then do;
      allocate probe_variable_float in (scratch_area);
      probe_variable_float = 0.0;
    end;
  else if probe_variable.type = PROBE_VAR_DOUBLE_TYPE then do;
      allocate probe_variable_double in (scratch_area);
      probe_variable_double = 0.0;
    end;
  else if probe_variable.type = PROBE_VAR_LONG_TYPE then do;
      allocate probe_variable_long in (scratch_area);
      probe_variable_long = 0;
    end;
  else if probe_variable.type = PROBE_VAR_CHAR_TYPE then do;
      allocate probe_variable_char in (scratch_area);
      probe_variable_char = "";
    end;
  else if probe_variable.type = PROBE_VAR_POINTER_TYPE then do;
      if P_unaligned_sw
        then allocate probe_variable_pointer_unal in (scratch_area);
        else allocate probe_variable_pointer in (scratch_area);
      probe_variable_pointer = null ();
    end;

  probe_variable.next = start_of_chain;
  start_of_chain = probe_variable_ptr;

  P_var_info_ptr = probe_variable_ptr;
  goto MAIN_RETURN;
%page;
find_variable:
  entry (P_probe_info_ptr, P_reference_node_ptr, P_code);

  probe_info_ptr = P_probe_info_ptr;
  P_code = 0;
  refp = P_reference_node_ptr;

  normal_name = normalize_name ((ref.name));
  probe_variable_ptr = find_var_info (normal_name);
  if probe_variable_ptr = null () then do;
      P_code = probe_et_$var_doesnt_exist;
      goto MAIN_RETURN;
    end;

  ref.symbol_ptr = null ();
  ref.address_ptr = probe_variable.address;
  ref.type = probe_variable.type;
  ref.descriptor = probe_variable.type * 2;

  if probe_variable.type = PROBE_VAR_INTEGER_TYPE
    then ref.precision = 35;
  else if probe_variable.type = PROBE_VAR_CHAR_TYPE
    then ref.precision = 1;
  else if probe_variable.type = PROBE_VAR_LONG_TYPE
    then ref.precision = 71;
  else if probe_variable.type = PROBE_VAR_DOUBLE_TYPE
    then ref.precision = 63;
  else if probe_variable.type = PROBE_VAR_FLOAT_TYPE
    then ref.precision = 27;
  else if probe_variable.type = PROBE_VAR_POINTER_TYPE
    then ref.precision = 0;		/* for completeness, tho useless */
				/* else malfunction */

  ref.flags = "0"b;
  ref.flags.probe_variable = "1"b;

  ref.probe_var_info_ptr = probe_variable_ptr;
  goto MAIN_RETURN;
%page;
list_variable:
  entry (P_probe_info_ptr, P_variable_name, P_code);

  probe_info_ptr = P_probe_info_ptr;
  P_code = 0;

  if start_of_chain = null () then do;
      P_code = probe_et_$no_vars;
      goto MAIN_RETURN;
    end;

  normal_name = normalize_name ((P_variable_name));
  probe_variable_ptr = find_var_info (normal_name);
  if probe_variable_ptr = null () then do;
      P_code = probe_et_$var_doesnt_exist;
      goto MAIN_RETURN;
    end;
  call list_current_var ();
  goto MAIN_RETURN;

list_var_ptr:
  entry (P_probe_info_ptr, P_var_info_ptr, P_code);
				/* used by symbol request */

  probe_info_ptr = P_probe_info_ptr;
  P_code = 0;
  probe_variable_ptr = P_var_info_ptr;
  call ioa_$ioa_switch (probe_info.output_switch,
       "probe variable ^a^[ unaligned^]",
       probe_variable.declared_type, probe_variable.unaligned_sw);
  goto MAIN_RETURN;


list_all_variables:
  entry (P_probe_info_ptr, P_code);

  probe_info_ptr = P_probe_info_ptr;

  if start_of_chain = null () then do;
      P_code = probe_et_$no_vars;
      goto MAIN_RETURN;
    end;

  do probe_variable_ptr = start_of_chain repeat probe_variable.next
       while (probe_variable_ptr ^= null ());
    call list_current_var ();
  end;
  P_code = 0;
  goto MAIN_RETURN;


list_current_var:
  proc;

  if probe_variable.type = PROBE_VAR_INTEGER_TYPE
    then call ioa_$ioa_switch (probe_info.output_switch, "^a^16t^a^32t^d",
	    probe_variable.name, probe_variable.declared_type,
	    probe_variable_integer);
  else if probe_variable.type = PROBE_VAR_FLOAT_TYPE
    then call ioa_$ioa_switch (probe_info.output_switch, "^a^16t^a^32t^f",
	    probe_variable.name, probe_variable.declared_type,
	    probe_variable_float);
  else if probe_variable.type = PROBE_VAR_POINTER_TYPE
    then call ioa_$ioa_switch (probe_info.output_switch,
	    "^a^16t^a^[ unaligned^]^32t^p",
	    probe_variable.name, probe_variable.declared_type,
	    probe_variable.unaligned_sw,
	    probe_variable_pointer);

  /* else malfunction */
  end list_current_var;
%page;
  /* INTERNAL PROCEDURES */

normalize_name:
  proc (weird_name) returns (char (64) varying);
  dcl weird_name		char (*) parameter;

  if substr (weird_name, 1, 1) = "%"
    then return (substr (weird_name, 2));
    else return (weird_name);
  end normalize_name;


find_var_info:
  proc (name_wanted) returns (ptr unal);
  dcl name_wanted		char (64) varying parameter;
  dcl p			ptr unal;

  do p = start_of_chain repeat p -> probe_variable.next while (p ^= null ());
    if p -> probe_variable.name = name_wanted
      then
	 return (p);
  end;
  return (null ());
  end find_var_info;

what_type_is:
  proc (type_desired) returns (fixed bin);
  dcl type_desired		char (*) parameter;
  dcl type_x		fixed bin;
  dcl name_x		fixed bin;

  dcl hbound		builtin;

  do type_x = 1 to hbound (name_to_type, 1);
    do name_x = 1 to hbound (name_to_type.names, 2);
      if name_to_type (type_x).names (name_x) = type_desired
        then
	   return (name_to_type (type_x).type);
    end;
  end;
  return (-1);
  end what_type_is;



delete_current:
  proc ();

  call unthread_current ();
  if probe_variable.type = PROBE_VAR_INTEGER_TYPE
    then free probe_variable_integer;
  else if probe_variable.type = PROBE_VAR_FLOAT_TYPE
    then free probe_variable_float;
  else if probe_variable.type = PROBE_VAR_POINTER_TYPE
    then free probe_variable_pointer;

  free probe_variable;

  end delete_current;

unthread_current:
  proc ();
  dcl p			ptr unal;

  if start_of_chain = probe_variable_ptr
    then start_of_chain = probe_variable.next;
    else
      do p = start_of_chain repeat (p -> probe_variable.next)
	 while (p ^= null ());
      if p -> probe_variable.next = probe_variable_ptr
        then do;
	p -> probe_variable.next = probe_variable.next;
	return;
        end;
    end;

  /* falling thru is impossible if variable is known */
  return;
  end unthread_current;
%page;
%include probe_info;
%page;
%include probe_references;
%page;
%include probe_var_info;


  end probe_variable_mgr_;





		    probe_vars_requests_.pl1        11/11/88  1555.4r w 11/11/88  1545.0       84456



/****^  ***********************************************************
        *                                                         *
        * 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_vars_requests_:
  proc;

  /* Here we have the probe variable requests:

   the 'declare' request:         dcl {NAME} TYPE {-force}
   the 'list_variables' request:  lsv {NAMES}

   James R. Davis Feb 80

*/
  /* Added unaligned pointers 12/04/81 S. Herbst */
  /* Added "external" variables 04/26/82 S. Herbst */
  /* Fixed "dcl" bad-type error message 07/15/82 S. Herbst */
  /* Implemented "dcl NAME TYPE defined EXPRESSION" 03/12/84 S. Herbst */
  /* Fixed bug causing auto var to not be allocated 07/09/84 S. Herbst */
  /* Fixed to translate "-" to "_" in COBOL identifiers when looking up in symbol table 09/20/84 Steve Herbst */

  dcl P_probe_info_ptr	ptr parameter;
				/* input */

  dcl 1 ref_1		aligned like reference_node based (ref_1_ptr);
  dcl ref_1_ptr		ptr;

  dcl variable_name		char (64) varying;
				/* name of var */
  dcl variable_type		char (64) varying;
				/* what type */
  dcl translated_name	char (64) varying;
				/* var name with "-" translated to "_" (COBOL) */
  dcl unaligned_sw		bit (1) aligned;
  dcl external_sw		bit (1) aligned;
  dcl force		bit (1) aligned;
				/* -force ? */
  dcl address_type		fixed bin;
  dcl address_ptr		ptr;
  dcl code		fixed bin (35);
  dcl control_arg		char (64) varying;

  dcl symbol_ptr		ptr;	/* to symbol node of like-named var if already is one */
  dcl response		char (64) varying;

  dcl (
      probe_et_$bad_dcl_type,
      probe_et_$noarg,
      probe_et_$too_many_args,
      probe_et_$var_exists,
      probe_et_$var_doesnt_exist
      )
			fixed bin (35) external static;

  dcl probe_create_reference_ entry (ptr, ptr);
  dcl probe_get_$control_arg	entry (ptr, char (64) varying, fixed bin (35));
  dcl probe_get_$expression	entry (ptr, 1 aligned like reference_node,
			fixed bin (35));
  dcl probe_variable_mgr_$create_variable
			entry (ptr, char (64) varying,
			char (64) varying, bit (1) aligned,
			fixed bin, ptr, bit (1) aligned, ptr unal,
			fixed bin (35));
  dcl probe_variable_mgr_$list_variable
			entry (ptr, char (64) varying, fixed bin (35));
  dcl probe_variable_mgr_$list_all_variables
			entry (ptr, fixed bin (35));

  dcl probe_error_$warning	entry options (variable);
  dcl probe_error_		entry options (variable);

  dcl stu_$find_runtime_symbol
			entry (ptr, char (*), ptr, fixed bin)
			returns (ptr);
  dcl command_query_	entry options (variable);

  dcl (addr, null, translate) builtin;
MAIN_RETURN:
  return;
%page;
declare_request:
  entry (P_probe_info_ptr);

  probe_info_ptr = P_probe_info_ptr;

  if current_token.type >= probe_info.end_token
    then
         goto DCL_USAGE;

  if current_token.type ^= NAME_TYPE
    then goto DCL_USAGE;
  variable_name = current_identifier_name;
  call bump_ct ();

  external_sw, unaligned_sw = "0"b;
  call accept_unal_arg ();

  if current_token.type ^= NAME_TYPE
    then goto DCL_USAGE;
  variable_type = current_identifier_name;
  call bump_ct ();

  call accept_unal_arg ();

  if external_sw
    then address_type = ADDRESS_EXTERNAL_TYPE;
    else address_type = ADDRESS_ALLOC_TYPE;
  address_ptr = null;

  if probe_info.ct -> operator.type < probe_info.end_token
    then
         if probe_info.ct -> token.type = NAME_TYPE then do;
	   if current_identifier_name = "defined"
	        | current_identifier_name = "def" then do;
	       call bump_ct ();
	       if probe_info.ct -> token.type >= probe_info.end_token
	         then do;
		 call probe_error_ (probe_info_ptr, probe_et_$noarg);
		 goto MAIN_RETURN;
	         end;
	       call probe_create_reference_ (probe_info_ptr, ref_1_ptr);
	       call probe_get_$expression (probe_info_ptr, ref_1, code);
	       if code ^= 0 then do;
		 call probe_error_ (probe_info_ptr, code);
		 goto MAIN_RETURN;
	         end;
	       address_type = ADDRESS_GIVEN_TYPE;
	       address_ptr = ref_1.address_ptr;
	     end;
	     else go to TOO_MANY;
	 end;

  force = "0"b;
  call probe_get_$control_arg (probe_info_ptr, control_arg, code);
  if control_arg = "force" | control_arg = "fc"
    then force = "1"b;
  else if control_arg ^= ""		/* something else */
    then goto DCL_USAGE;

  if current_token.type < probe_info.end_token
    then goto TOO_MANY;

  if unaligned_sw & variable_type ^= "pointer" & variable_type ^= "ptr"
    then
         call probe_error_ (probe_info_ptr, 0,
	    "Only pointers can be declared unaligned in probe.  ^a",
	    variable_name);

  if ^probe_info.flags.execute
    then goto MAIN_RETURN;

  if probe_info.language_type = COBOL_lang_type
    then translated_name = translate (variable_name, "_", "-");
    else translated_name = variable_name;

  symbol_ptr = stu_$find_runtime_symbol (current_source.block_ptr,
       (translated_name), (null), (0));

  if symbol_ptr ^= null ()
    then /* tell user already exists */
         call probe_error_$warning (probe_info_ptr, 0,
	    "Warning: a program variable also named ^a is known",
	    variable_name);


  call probe_variable_mgr_$create_variable (probe_info_ptr, variable_name,
       variable_type, unaligned_sw,
       address_type, address_ptr, force, probe_variable_ptr, code);

  if code = probe_et_$var_exists then do;

      query_info.version = query_info_version_4;
      query_info.switches.yes_or_no_sw = "1"b;
      query_info.question_iocbp = probe_info.output_switch;
      query_info.answer_iocbp = probe_info.input_switch;

      call command_query_ (addr (query_info), response, "declare",
	 "A variable named ^a is already declared as ^a. Replace it?",
	 variable_name, probe_variable.declared_type);
      if response = "no"
        then goto MAIN_RETURN;
      call probe_variable_mgr_$create_variable (probe_info_ptr, variable_name,
	 variable_type, unaligned_sw,
	 address_type, address_ptr, "1"b, probe_variable_ptr, code);

    end;
  if code ^= 0
    then
         if code = probe_et_$bad_dcl_type
	 then call probe_error_ (probe_info_ptr, code, variable_type);
	 else call probe_error_ (probe_info_ptr, code, variable_name);

  goto MAIN_RETURN;

DCL_USAGE:
  call probe_error_ (probe_info_ptr, 0,
       "Usage: dcl NAME TYPE {-force}");
  goto MAIN_RETURN;

%page;
list_variables_request:
  entry (P_probe_info_ptr);

  probe_info_ptr = P_probe_info_ptr;
  code = 0;

  if current_token.type < probe_info.end_token
    then
      do while (current_token.type < probe_info.end_token & code = 0);
      if current_token.type ^= NAME_TYPE
        then goto LSV_USAGE;
      variable_name = current_identifier_name;
      if probe_info.flags.execute
        then
	   call probe_variable_mgr_$list_variable (probe_info_ptr,
	        variable_name, code);
      if code = probe_et_$var_doesnt_exist then do;
	call probe_error_$warning (probe_info_ptr, code, variable_name);
	code = 0;			/* list the others, no harm in it */
        end;

      call bump_ct ();
    end;				/* looping thru all NAMEs */
  else if probe_info.flags.execute
    then
         call probe_variable_mgr_$list_all_variables (probe_info_ptr, code);

  if code ^= 0
    then call probe_error_ (probe_info_ptr, code);
  goto MAIN_RETURN;

LSV_USAGE:
  call probe_error_ (probe_info_ptr, 0, "Usage: lsv {NAMES}");
  goto MAIN_RETURN;



bump_ct:
  proc ();
  probe_info.ct = current_token.next;
  end bump_ct;

TOO_MANY:
  call probe_error_ (probe_info_ptr, probe_et_$too_many_args);
  goto MAIN_RETURN;
%page;
accept_unal_arg:
  proc;

  /* For declare request, sees if next arg is "unaligned" or "unal" and sets flag */

NEXT:
  if probe_info.ct -> operator.type < probe_info.end_token
    then
         if probe_info.ct -> token.type = NAME_TYPE
	 then
	      if current_identifier_name = "external"
		 | current_identifier_name = "ext" then do;
		external_sw = "1"b;
		call bump_ct ();
		go to NEXT;
	        end;
	      else if (current_identifier_name = "unaligned"
		 | current_identifier_name = "unal") then do;
		unaligned_sw = "1"b;
		call bump_ct ();
		go to NEXT;
	        end;
  end accept_unal_arg;
%page;
%include probe_info;
%page;
%include probe_lang_types;
%page;
%include probe_references;
%page;
%include probe_source_info;
%page;
%include probe_tokens;
%page;
%include probe_var_info;
%page;
%include query_info;


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