



		    display_argument_list_.pl1      10/24/88  1638.0r w 10/24/88  1400.2      115011



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */


/****^  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-11-19,DGHowe), approve(86-11-19,MCR7583),
     audit(86-11-24,JRGray), install(86-12-09,MR12.0-1238):
     Changed to print out command_name. Modified to refer
     to command_name_arglist instead of arg_list.
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,tree,ifthenstmt,indnoniterend */
display_argument_list_:
     procedure (Iocb, Amup, Framep, Argp, Entryp, Farg, Larg, Lmarg);

/* This program is an adaptation of Steve Webber's list_arg_ routine from db,
   for use by trace_stack_. */
/* rewritten 8/10/81 by Melanie Weaver to use arithmetic_to_ascii_ */
/* Adapted from list_frame_args_ May 1982 by C. Hornig */
/* modified 7/12/83 by Jeffrey D. Ives to not print a warning if a packed arg is passed to an unpacked parm.	*/
/* modified 9/05/84 by Jeffrey D. Ives to use get_entry_arg_descs_$info, use "RET VAL" before a return value,
   and handle the returns (char|bit|area (*)) case. */


dcl  Amup ptr parameter;				/* unused */
dcl  Framep ptr parameter;
dcl  Argp ptr parameter;
dcl  Entryp ptr parameter;
dcl  (Farg, Larg) fixed bin parameter;
dcl  Lmarg fixed bin parameter;
dcl  Iocb ptr parameter;

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

dcl  cleanup condition;

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

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

dcl  arg_id char (7);
dcl  (ttype, xttype) char (40);
dcl  ascii_representation char (132) varying;

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

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

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

dcl  1 edi like entry_desc_info aligned;

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

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

	if ep = null () then ep = stack_frame.entry_ptr;
	if ap = null () then ap = stack_frame.arg_ptr;

	if ap = null () then do;
	     if ep ^= null ()
	     then do j = 1 to hbound (begin_block_entries, 1);
		if addrel (ep, 1) -> based_bit = begin_block_entries (j) then do;
		     call ioa_$ioa_switch (Iocb, "^vxThis is a begin block.  It has no argument list.", Lmarg);
		     return;
		     end;
	     end;

	     call ioa_$ioa_switch (Iocb, "^vxNo argument list.", Lmarg);
	     return;
	     end;

	strp = addr (strbuf);
	no_args = ap -> arg_list.arg_count;		/* get the number of arguments */
	no_desc = ap -> arg_list.desc_count;		/* and the number of descriptors */

	if (ap -> command_name_arglist.mbz ^= ""b)
	     | ((ap -> command_name_arglist.call_type ^= 4) & (ap -> command_name_arglist.call_type ^= 8))
	     | ((no_desc ^= 0) & (no_desc ^= no_args)) then do;

	     call ioa_$ioa_switch (Iocb, "^vxArgument list header invalid.", Lmarg);
	     return;
	     end;

	entry_desc_info_ptr = addr (edi);
	unspec (entry_desc_info) = ""b;
	entry_desc_info.version = entry_desc_info_version_2;
	call get_entry_arg_descs_$info (ep, xnargs, xdesc, entry_desc_info_ptr, ec);

	if (xnargs > 0) & (xnargs ^= no_args)
	then call ioa_$ioa_switch (Iocb, "^vxWarning: ^d arguments expected, ^d supplied.", Lmarg, xnargs, no_args);

	if no_args = 0 then do;			/* check for no arguments */
	     call ioa_$ioa_switch (Iocb, "^vxNo arguments.", Lmarg);
	     return;
	     end;

/* check and see if the command name is available */

	if (ap -> command_name_arglist.has_command_name) then do;
	     argp = ap -> command_name_arglist.name.command_name_ptr;
	     strl = ap -> command_name_arglist.name.command_name_length;
	     if strl > 0 then call ioa_$ioa_switch (Iocb, "^vxCommand name: ^a", Lmarg, char_string);
	     end;

	if no_args > 64 then call ioa_$ioa_switch (Iocb, "^vxOnly first 64 args of ^d will be listed.", Lmarg, no_args);

	min_arg = max (1, Farg);			/* print out all arguments */
	max_arg = min (Larg, no_args, 64);

	call condition_ ("any_other", intproc);
	on cleanup ;
%page;
	do j = min_arg to max_arg;			/* loop through the desired number of args */
	     argp = ap -> command_name_arglist.arg_ptrs (j);
						/* get pointer to the argument */
	     type, xtype = -1;			/* full word octal */
	     packed, xpacked = "0"b;
	     ndims, xndims = 0;
	     strl, xstrl = 0;
	     scale, xscale = 0;
	     if entry_desc_info.flags.function & j = xnargs
	     then arg_id = "RET VAL";
	     else call ioa_$rsnnl ("ARG ^3d", arg_id, k, j);
	     if xnargs >= j & xdesc (j) ^= null () then do;
						/* Do we know what this arg shd be? */
		call decode_descriptor_ (xdesc (j), 0, xtype, xpacked, xndims, xstrl, xscale);
		end;
	     if arg_id = "RET VAL" & xstrl = 16777215 then argp = argp -> based_ptr;
						/* returns (char|bit|area (*)) case */
	     if no_desc ^= 0 then do;			/* if we have descriptors, look at them */
		call decode_descriptor_ (ap, j, type, packed, ndims, strl, scale);
		if xnargs >= j & xdesc (j) ^= null () then do;
						/* Yes. We know what this arg shd be. */
		     if xtype ^= type then do;
			if type >= lbound (data_type_info_$info, 1) & type <= hbound (data_type_info_$info, 1)
			then ttype = type_name (type);
			else call ioa_$rsnnl ("type ^d", ttype, k, type);
			if xtype >= lbound (data_type_info_$info, 1) & xtype <= hbound (data_type_info_$info, 1)
			then xttype = type_name (xtype);
			else call ioa_$rsnnl ("type ^d", xttype, k, xtype);
			call ioa_$ioa_switch (Iocb, "^vxWarning: ^a is ^a, but it should be ^a.", Lmarg, arg_id,
			     ttype, xttype);
			end;
		     if xpacked ^= packed		/* Check that packed attributes match */
		     then do;
			if xpacked then do;
			     if xtype ^= char_dtype
			     then call ioa_$ioa_switch (Iocb,
				     "^vxWarning: ^a is unpacked, but it should be packed.", Lmarg, arg_id);
			     end;
			else call ioa_$ioa_switch (Iocb, "^vxWarning: ^a is packed, but it should be unpacked.",
				Lmarg, arg_id);
			end;
		     if xndims ^= ndims
		     then call ioa_$ioa_switch (Iocb, "^vxWarning: ^a has ^d dimensions, but it should have ^d.",
			     Lmarg, arg_id, ndims, xndims);
		     if xstrl ^= strl
		     then if xtype < pointer_dtype
			then call ioa_$ioa_switch (Iocb,
				"^vxWarning: ^a has a precision of ^d, but it should be ^d.", Lmarg, arg_id, strl,
				xstrl);
			else if xstrl ^= 16777215
			     then			/* No fuss abt char (*) */
				call ioa_$ioa_switch (Iocb,
				     "^vxWarning: ^a has a length of ^d, but it should be ^d.", Lmarg, arg_id,
				     strl, xstrl);
		     if xscale ^= scale
		     then call ioa_$ioa_switch (Iocb, "^vxWarning: ^a has a scale of ^d, but it should be ^d.", Lmarg,
			     arg_id, scale, xscale);
		     end;
		end;
	     else if xnargs >= j then do;		/* Callee might have descriptors for args. */
		     if xdesc (j) = null then go to guess;
						/* .. and then again he might not. */
		     call decode_descriptor_ (xdesc (j), 0, type, packed, ndims, strl, scale);
		     end;
		else do;				/* try to find out what type by heuristics */
guess:
		     if argp -> its.its_mod = ITS_MODIFIER
		     then type = pointer_dtype;	/* assume pointer */
		     else do;
			strl = verify (bcs, LEGAL) - 1;
						/* Scan for last legal char in string. */
			if strl < 0 then strl = 100;	/* If all legal, print first 100. */
			if strl >= 2
			then type = char_dtype;
			else strl = 0;
			end;
		     end;

	     if /* case */ type = -1 then call ioa_$ioa_switch (Iocb, "^vx^a: ^w", Lmarg, arg_id, fword (1));
						/* no descriptor; print full word octal */

	     else if type < lbound (data_type_info_$info, 1) | type > hbound (data_type_info_$info, 1)
	     then call ioa_$ioa_switch (Iocb, "^vx^a: (bad type ^d at ^p) ^w", Lmarg, arg_id, type, argp, fword (1));

	     else if data_type_info_$info (type).arithmetic then do;
		call arithmetic_to_ascii_ (argp, type, packed, strl, scale, ascii_representation);
		call ioa_$ioa_switch (Iocb, "^vx^a: ^a", Lmarg, arg_id, ascii_representation);
		end;

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

	     else if type = offset_dtype		/* Offset */
	     then call ioa_$ioa_switch (Iocb, "^vx^a: ^w", Lmarg, arg_id, fword (1));

	     else if type = label_dtype | type = entry_dtype
						/* Label, Entry */
	     then do;
		call interpret_ptr_ (argp -> label_variable.ptr, argp -> label_variable.stack, strp);
		call ioa_$ioa_switch (Iocb, "^vx^a: ^p, ^p ^a^a|^a ^a", Lmarg, arg_id, label_variable.ptr,
		     label_variable.stack, struc.segment, struc.entryn, struc.offset, struc.comment);
		end;

	     else if type = bit_dtype | type = varying_bit_dtype
						/* Bit string */
	     then do;
		if type = varying_bit_dtype then strl = addrel (argp, -1) -> fword (1);
		if bit_string ^= ""b
		then ascii_representation = """" || character (substr (bit_string, 1, min (strl, 72))) || """b";
		else call ioa_$rsnnl ("(^d)""0""b", ascii_representation, 0, strl);

		call ioa_$ioa_switch (Iocb, "^vx^a: ^a", Lmarg, arg_id, ascii_representation);
		end;

	     else if type = char_dtype | type = varying_char_dtype
						/* Character string */
	     then do;
		if type = varying_char_dtype then strl = min (80, max (addrel (argp, -1) -> fword (1), 0));
		call ioa_$ioa_switch (Iocb, "^vx^a: ""^va""", Lmarg, arg_id, strl, char_string);
		end;

	     else if type = file_dtype		/* File */
	     then do;
		call ioa_$ioa_switch_nnl (Iocb, "^vx^a: ", Lmarg, arg_id);
		call display_file_value_ (Iocb, argp -> based_file, ec);
		call ioa_$ioa_switch (Iocb, "(file at ^p)", argp);
		end;

	     else call ioa_$ioa_switch (Iocb, "^vx^a: (^a at ^p) ^w", Lmarg, arg_id, type_name (type), argp, fword (1));

	     if ndims > 0 then call ioa_$ioa_switch (Iocb, "^-^vx(^d-dim array)", Lmarg, ndims);

skiparg:
	end;
	return;
%page;
intproc:
     procedure (mcp, cname, cop, infop, cont);

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

	if (cname = "program_interrupt") | (cname = "finish") | (cname = "quit") then do;
	     cont = "1"b;
	     return;
	     end;

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

	call ioa_$ioa_switch (Iocb, "^vx^a not accessible. - ^a", Lmarg, arg_id, cname);
	go to skiparg;
     end;
%page;
%include arg_list;
%include entry_desc_info;
%include stack_frame;
%include interpret_ptr_struc;
%include its;
%include data_type_info_;
%include condition_info_header;
%include std_descriptor_types;
%include probe_data_type_names;

     end display_argument_list_;




		    trace.pl1                       01/11/85  1045.4rew 01/11/85  1034.9      252351



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/*

   This is the command interface to the trace facility.

   Initial Version: 25 February 1970 by BLW
   Modified many times.
   Completely rewritten: May 1984 by Jeffrey D. Ives.
*/
/* format: style2,ifthendo,^indnoniterdo,thendo,^inditerdo,indproc,ind2,dclind5,idind32 */
%page;
trace:
  procedure options (variable);

/* DISABLE TRACE_CATCH_ */

    transaction_id = clock ();
    on cleanup status = trace_$transaction_end (transaction_id);
						/* Disregard nonstandard use of status.	*/
    if ^trace_$transaction_begin (transaction_id) /* Temporarily disables trace_catch_.			*/
    then do;
      call com_err_ (code, ME, "There seems to be an incomplete invocation of trace,
watch, or trace_meters still on the stack.  Try the release command.");
      return;
    end;

/* SET UP A SUB_ERROR_ CONDITION HANDLER */

    call condition_ ("sub_error_", SUB_ERROR_HANDLER);

/* SET DEFAULT ACTIONS */

    set_defaults = "0"b;
    add_remove_action = "";
    on_off_action = "";
    parameters = "0"b;
    print_buffer = 0;
    status = "0"b;

/* READ THE ARGUMENTS */

    call cu_$arg_count (arg_count, code);
    if code ^= 0
    then do;
      call com_err_ (code, ME);
      go to TRANSACTION_END;
    end;

    arg_idx = 1;
ARGUMENT_LOOP:
    do while (arg_idx <= arg_count);
      call cu_$arg_ptr (arg_idx, arg_ptr, arg_len, code);
      if code ^= 0
      then do;
        call com_err_ (code, ME);
        go to TRANSACTION_END;
      end;

      if length (arg) = 0
      then do;
        call com_err_ (code, ME, "A null argument was found where an entrypoint was expected.");
        go to TRANSACTION_END;
      end;

      if substr (arg, 1, 1) ^= "-"
      then
ENTRYPOINTS_ARGUMENT:
        do;
        call CHECK_NEXT_ARG (arg, 256, "trace", "entrypoints", " control_args");
        call trace_$specify_entrypoints ((arg), null ());
        arg_idx = arg_idx + 1;
      end ENTRYPOINTS_ARGUMENT;

      else
CONTROL_ARGUMENT:
        do;
        if arg_idx + 1 > arg_count
        then next_arg_ptr = null ();
        else do;
	call cu_$arg_ptr (arg_idx + 1, next_arg_ptr, next_arg_len, code);
	if code ^= 0
	then do;
	  call com_err_ (code, ME);
	  go to TRANSACTION_END;
	end;

	if length (next_arg) > 0
	then if substr (next_arg, 1, 1) = "-"
	     then next_arg_ptr = null ();
        end;

        if arg = "-add" /* -add */
        then do;
	add_remove_action = "add";
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-alm" /* -alm on|off */
        then do;
	call CHECK_NEXT_ARG (next_arg, 8, arg, "on|off", "");
	call trace_$set_alm (trace_$cv_onoff_to_bit ((next_arg)));
	arg_idx = arg_idx + 2;
        end;

        else if arg = "-arguments" | arg = "-ag" | arg = "-argument" | arg = "-args" | arg = "-arg"
	   | arg = "-ags" /* -arguments in|out|on|off, -ag in|out|on|off */
        then do;
	call CHECK_NEXT_ARG (next_arg, 8, arg, "in|out|on|off", "");
	call trace_$set_arguments (trace_$cv_inout_to_bits ((next_arg)));
	arg_idx = arg_idx + 2;
        end;

        else if arg = "-automatic" | arg = "-auto" /* -automatic on|off, -auto on|off */
        then do;
	call CHECK_NEXT_ARG (next_arg, 8, arg, "on|off", "");
	call trace_$set_automatic (trace_$cv_onoff_to_bit ((next_arg)));
	call trace_$set_signals (trace_$cv_onoff_to_bit ((next_arg)));
	arg_idx = arg_idx + 2;
        end;

        else if arg = "-brief" | arg = "-bf" /* -brief, -bf */
        then do;
	call trace_$set_long ("0"b);
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-buffer" | arg = "-buf" | arg = "-buff" /* -buffer on|off, -buf on|off */
        then do;
	call CHECK_NEXT_ARG (next_arg, 8, arg, "on|off", "");
	call trace_$set_buffer (trace_$cv_onoff_to_bit ((next_arg)));
	arg_idx = arg_idx + 2;
        end;

        else if arg = "-calibrate" /* -calibrate on|off */
        then do;
	call CHECK_NEXT_ARG (next_arg, 8, arg, "on|off", "");
	call trace_$set_calibrate (trace_$cv_onoff_to_bit ((next_arg)));
	arg_idx = arg_idx + 2;
        end;

        else if arg = "-call" /* -call COMMAND-LINE */
        then do;
	call CHECK_NEXT_ARG (next_arg, 256, arg, "COMMAND-LINE", " (if CL contains spaces, it must be quoted)");
	call trace_$set_call ((next_arg));
	arg_idx = arg_idx + 2;
        end;

        else if arg = "-disable" | arg = "-disa" | arg = "-dis" /* -disable, -disa */
        then do;
	call trace_$set_enabled ("0"b);
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-enable" | arg = "-ena" | arg = "-en" /* -enable, -ena */
        then do;
	call trace_$set_enabled ("1"b);
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-every" | arg = "-ev" /* -every N, -ev N */
        then do;
	call CHECK_NEXT_ARG (next_arg, 16, arg, "N", " (where N is positive or 0)");
	call trace_$set_every (trace_$cv_n_to_number ((next_arg)));
	arg_idx = arg_idx + 2;
        end;

        else if arg = "-first" | arg = "-ft" /* -first N, -ft N */
        then do;
	call CHECK_NEXT_ARG (next_arg, 16, arg, "N", " (where N is positive or 0)");
	call trace_$set_first (trace_$cv_n_to_number ((next_arg)));
	arg_idx = arg_idx + 2;
        end;

        else if arg = "-high" /* -high N */
        then do;
	call CHECK_NEXT_ARG (next_arg, 16, arg, "N", " (where N is positive or 0)");
	call trace_$set_high (trace_$cv_n_to_number ((next_arg)));
	arg_idx = arg_idx + 2;
        end;

        else if arg = "-last" | arg = "-lt" /* -last N, -lt N */
        then do;
	call CHECK_NEXT_ARG (next_arg, 16, arg, "N", " (where N is positive or 0)");
	call trace_$set_last (trace_$cv_n_to_number ((next_arg)));
	arg_idx = arg_idx + 2;
        end;

        else if arg = "-long" | arg = "-lg" /* -long, -lg */
        then do;
	call trace_$set_long ("1"b);
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-loud" /* -loud */
        then do;
	call trace_$set_loud ("1"b);
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-low" /* -low N */
        then do;
	call CHECK_NEXT_ARG (next_arg, 16, arg, "N", " (where N is positive or 0)");
	call trace_$set_low (trace_$cv_n_to_number ((next_arg)));
	arg_idx = arg_idx + 2;
        end;

        else if arg = "-meter" | arg = "-mt" | arg = "-meters" | arg = "-mts" /* -meter on|off, -mt on|off */
        then do;
	call CHECK_NEXT_ARG (next_arg, 8, arg, "on|off", "");
	call trace_$set_meter (trace_$cv_onoff_to_bit ((next_arg)));
	arg_idx = arg_idx + 2;
        end;

        else if arg = "-new_high" /* -new_high on|off */
        then do;
	call CHECK_NEXT_ARG (next_arg, 8, arg, "on|off", "");
	call trace_$set_new_high (trace_$cv_onoff_to_bit ((next_arg)));
	arg_idx = arg_idx + 2;
        end;

        else if arg = "-no_alm" /* -no_alm */
        then do;
	call trace_$set_alm ("0"b);
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-no_arguments" | arg = "-nag" | arg = "-no_argument" | arg = "-nargs" | arg = "-narg"
	   | arg = "-nags" /* -no_arguments, -nag */
        then do;
	call trace_$set_arguments ("00"b);
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-no_automatic" | arg = "-nauto" /* -no_automatic, -nauto */
        then do;
	call trace_$set_automatic ("0"b);
	call trace_$set_signals ("0"b);
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-no_buffer" | arg = "-nbuf" | arg = "-nbuff" /* -no_buffer, -nbuf */
        then do;
	call trace_$set_buffer ("0"b);
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-no_calibrate" /* -no_calibrate */
        then do;
	call trace_$set_calibrate ("0"b);
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-no_call" /* -no_call */
        then do;
	call trace_$set_call ("");
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-no_every" | arg = "-nev" /* -no_every, -nev */
        then do;
	call trace_$set_every (0);
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-no_first" | arg = "-nft" /* -no_first, -nft */
        then do;
	call trace_$set_first (0);
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-no_high" /* -no_high */
        then do;
	call trace_$set_high (0);
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-no_last" | arg = "-nlt" /* -no_last, -nlt */
        then do;
	call trace_$set_last (0);
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-no_low" /* -no_low */
        then do;
	call trace_$set_low (0);
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-no_meter" | arg = "-nmt" | arg = "-no_meters" | arg = "-nmts" /* -no_meter, -nmt */
        then do;
	call trace_$set_meter ("0"b);
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-no_new_high" /* -no_new_high */
        then do;
	call trace_$set_new_high ("0"b);
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-no_output_file" | arg = "-nof" /* -no_output_file, -nof */
        then do;
	call trace_$set_output_switch (trace_$cv_file_path_to_osw ("", null ()));
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-no_output_switch" | arg = "-nosw" /* -no_output_switch, -nosw */
        then do;
	call trace_$set_output_switch (trace_$cv_stream_name_to_osw (""));
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-no_signals" | arg = "-nsig" | arg = "-no_signal" | arg = "-nsigs" /* -no_signals, -nsig */
        then do;
	call trace_$set_signals ("0"b);
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-no_stop" | arg = "-nsp" /* -no_stop, -nsp */
        then do;
	call trace_$set_stop ("00"b);
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-no_stop_every" | arg = "-nspev" /* -no_stop_every, -nspev */
        then do;
	call trace_$set_every (0);
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-no_stop_low" | arg = "-nsplow" /* -no_stop_low, -nsplow */
        then do;
	call trace_$set_stop_low (0);
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-no_stop_proc" | arg = "-nspp" /* -no_stop_proc, -nspp */
        then do;
	call trace_$set_stop_proc (trace_$cv_entry_name_to_spp ("", null ()));
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-no_trace" /* -no_trace */
        then do;
	call trace_$set_trace ("00"b);
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-off" /* -off */
        then do;
	on_off_action = "off";
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-on" /* -on */
        then do;
	on_off_action = "on";
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-output_file" | arg = "-of" /* -output_file PATH, -of PATH */
        then do;
	call CHECK_NEXT_ARG (next_arg, 256, arg, "PATH", "");
	call trace_$set_output_switch (trace_$cv_file_path_to_osw ((next_arg), null ()));
	arg_idx = arg_idx + 2;
        end;

        else if arg = "-output_switch" | arg = "-osw" /* -output_switch SWITCH, -osw SWITCH */
        then do;
	call CHECK_NEXT_ARG (next_arg, 32, arg, "SWITCH", " (SWITCH must be open for stream output)");
	call trace_$set_output_switch (trace_$cv_stream_name_to_osw ((next_arg)));
	arg_idx = arg_idx + 2;
        end;

        else if arg = "-parameters" | arg = "-pm" | arg = "-parameter" | arg = "-pms" | arg = "-parm"
	   | arg = "-parms" /* -parameters, -pm */
        then do;
	parameters = "1"b;
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-print_buffer" | arg = "-prbuf" | arg = "-prbuff" /* -print_buffer N, -prbuf N */
        then do;
	call CHECK_NEXT_ARG (next_arg, 16, arg, "N", " (where N is positive or 0)");
	print_buffer = trace_$cv_n_to_number ((next_arg));
	arg_idx = arg_idx + 2;
        end;

        else if arg = "-quiet" /* -quiet */
        then do;
	call trace_$set_loud ("0"b);
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-remove" | arg = "-rm" /* -remove, -rm */
        then do;
	add_remove_action = "remove";
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-set_defaults" | arg = "-sdft" | arg = "-set_default" | arg = "-sdf" | arg = "-sdfs"
	   | arg = "-sdfts" /* -set_defaults, -sdft */
        then do;
	set_defaults = "1"b;
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-signals" | arg = "-sig" | arg = "-signal" | arg = "-sigs" /* -signals on|off, -sig on|off */
        then do;
	call CHECK_NEXT_ARG (next_arg, 8, arg, "on|off", "");
	call trace_$set_signals (trace_$cv_onoff_to_bit ((next_arg)));
	arg_idx = arg_idx + 2;
        end;

        else if arg = "-status" | arg = "-st" /* -status, -st */
        then do;
	status = "1"b;
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-stop" | arg = "-sp" /* -stop in|out|on|off, -sp in|out|on|off */
        then do;
	call CHECK_NEXT_ARG (next_arg, 8, arg, "in|out|on|off", "");
	call trace_$set_stop (trace_$cv_inout_to_bits ((next_arg)));
	arg_idx = arg_idx + 2;
        end;

        else if arg = "-stop_every" | arg = "-spev" /* -stop_every N, -spev N */
        then do;
	call CHECK_NEXT_ARG (next_arg, 16, arg, "N", " (where N is positive or 0)");
	call trace_$set_stop_every (trace_$cv_n_to_number ((next_arg)));
	arg_idx = arg_idx + 2;
        end;

        else if arg = "-stop_proc" | arg = "-spp" /* -stop_proc ENTRYNAME, -spp ENTRYNAME */
        then do;
	call CHECK_NEXT_ARG (next_arg, 256, arg, "ENTRYNAME", "");
	call trace_$set_stop_proc (trace_$cv_entry_name_to_spp ((next_arg), null ()));
	arg_idx = arg_idx + 2;
        end;

        else if arg = "-stop_low" | arg = "-splow" /* -stop_low N, -splow N */
        then do;
	call CHECK_NEXT_ARG (next_arg, 16, arg, "N", " (where N is positive or 0)");
	call trace_$set_stop_low (trace_$cv_n_to_number ((next_arg)));
	arg_idx = arg_idx + 2;
        end;

        else if arg = "-trace" /* -trace in|out|on|off */
        then do;
	call CHECK_NEXT_ARG (next_arg, 8, arg, "in|out|on|off", "");
	call trace_$set_trace (trace_$cv_inout_to_bits ((next_arg)));
	arg_idx = arg_idx + 2;
        end;

/************ THE FOLLOWING CONTROL ARGUMENTS BECAME OBSOLETE IN MR11 ********/

        else if arg = "-return_value" | arg = "-rv"
        then do;
	call com_err_ (ZERO, ME, "The ^a argument is now obsolete.
Trace automatically determines whether entrypoints return values.", arg);
	go to TRANSACTION_END;
        end;

        else if arg = "-start" | arg = "-sr"
        then do;
	call OBSOLETE_ARG (arg, "-add");
	go to TRANSACTION_END;
        end;

        else if arg = "-before"
        then do;
	call OBSOLETE_ARG (arg, "-stop_every N -stop in (-spev N -sp in)");
	go to TRANSACTION_END;
        end;

        else if arg = "-after"
        then do;
	call OBSOLETE_ARG (arg, "-stop_every N -stop out (-spev N -sp out)");
	go to TRANSACTION_END;
        end;

        else if arg = "-depth  " | arg = "-dh"
        then do;
	call OBSOLETE_ARG (arg, "-high");
	go to TRANSACTION_END;
        end;

        else if arg = "-in"
        then do;
	call OBSOLETE_ARG (arg, "-arguments in (-ag in)");
	go to TRANSACTION_END;
        end;

        else if arg = "-out"
        then do;
	call OBSOLETE_ARG (arg, "-arguments out (-ag out)");
	go to TRANSACTION_END;
        end;

        else if arg = "-inout"
        then do;
	call OBSOLETE_ARG (arg, "-arguments inout (-ag inout)");
	go to TRANSACTION_END;
        end;

        else if arg = "-template" | arg = "-tp"
        then do;
	call OBSOLETE_ARG (arg, "-parameters (-pm)");
	go to TRANSACTION_END;
        end;

        else if arg = "-govern " | arg = "-gv"
        then do;
	call OBSOLETE_ARG (arg, "-stop_low N -stop in (-splow N -sp in)");
	go to TRANSACTION_END;
        end;

        else if arg = "-execute" | arg = "-ex"
        then do;
	call OBSOLETE_ARG (arg, "-call");
	go to TRANSACTION_END;
        end;

/************ THE FOLLOWING CONTROL ARGUMENTS BECAME OBSOLETE IN MR9 ********/

        else if arg = "-print  " | arg = "-pr"
        then do;
	call OBSOLETE_ARG (arg, "-status (-st)");
	go to TRANSACTION_END;
        end;

        else if arg = "-reset  " | arg = "-rs"
        then do;
	call OBSOLETE_ARG (arg, "the trace_meters command (tmt)");
	go to TRANSACTION_END;
        end;

        else if arg = "-total" | arg = "-tt"
        then do;
	call OBSOLETE_ARG (arg, "the trace_meters command (tmt)");
	go to TRANSACTION_END;
        end;

        else if arg = "-subtotal" | arg = "-stt"
        then do;
	call OBSOLETE_ARG (arg, "the trace_meters command (tmt)");
	go to TRANSACTION_END;
        end;

        else if arg = "-reset_total" | arg = "-rst"
        then do;
	call OBSOLETE_ARG (arg, "the trace_meters command (tmt -rs)");
	go to TRANSACTION_END;
        end;

        else if arg = "-reset_subtotal" | arg = "-rss"
        then do;
	call OBSOLETE_ARG (arg, "the trace_meters command (tmt -rs)");
	go to TRANSACTION_END;
        end;

/*************** END OF OBSOLETE ARGUMENTS *********************************/

        else do;
	call com_err_ (error_table_$badopt, ME, """^a""", arg);
	go to TRANSACTION_END;
        end;
      end CONTROL_ARGUMENT;
    end ARGUMENT_LOOP;
%page;
/* COMMIT ACTION and print a nice message something like this:

   Trace: global parms changed, default parms changed,
   4 entrypoints specified, 2 entrypoints added, 2 entrypoints updated,
   4 entrypoints turned off.
*/

    call SAY_BEGIN ();

    if FIRST_TIME
    then do;
      call SAY (trace_$version ());
      FIRST_TIME = "0"b;
    end;

    if trace_$update_global_parms ()
    then call SAY ("global parms changed");

    if set_defaults
    then do;
      if trace_$update_default_parms ()
      then call SAY ("default parms changed");
    end;

    n_specified = trace_$num_specified_entrypoints ();

    if n_specified > 0
    then
ENTRYPOINT_ACTION:
      do;
      call SAY_N_ENTRYPOINTS (n_specified, "specified");

      if add_remove_action = "" & on_off_action = "" & ^status
      then add_remove_action = "add";

      if add_remove_action = "add"
      then
        begin;
	dcl  n_added		       fixed bin;
	dcl  n_modified		       fixed bin;
	call trace_$add_specified_eps (n_added, n_modified);
	call SAY_N_ENTRYPOINTS (n_added, "added");
	if n_modified > 0
	then call SAY_N_ENTRYPOINTS (n_modified, "modified");
        end;

      if add_remove_action = "remove"
      then
        begin;
	dcl  n_removed		       fixed bin;
	call trace_$remove_specified_eps (n_removed);
	call SAY_N_ENTRYPOINTS (n_removed, "removed");
        end;

      if on_off_action = "on"
      then
        begin;
	dcl  n_turned_on		       fixed bin;
	call trace_$turn_on_specified_eps (n_turned_on);
	call SAY_N_ENTRYPOINTS (n_turned_on, "turned on");
        end;

      if on_off_action = "off"
      then
        begin;
	dcl  n_turned_off		       fixed bin;
	call trace_$turn_off_specified_eps (n_turned_off);
	call SAY_N_ENTRYPOINTS (n_turned_off, "turned off");
        end;
    end ENTRYPOINT_ACTION;

    n_entrypoints = trace_$num_entrypoints ();
    if n_entrypoints = 0
    then call SAY ("trace table empty");
    else call SAY_N_ENTRYPOINTS (n_entrypoints, "in trace table");

    if ^trace_$enabled ()
    then call SAY ("disabled");
    else if trace_$in_trace ()
    then call SAY ("temporarily disabled");

    call SAY_END ();

    if parameters | arg_count = 0
    then do;
      call ioa_ ("Global parms: ^a", trace_$global_parms_string ());
      call ioa_ ("Default parms: ^a", trace_$parms_string (-1, "0"b));
    end;

    if arg_count = 0
    then call ioa_ ("Acts: -set_defaults -add/-remove -on/-off -parameters -status -print_buffer.");

    if add_remove_action = ""
    then if trace_$parms_specified ()
         then call ioa_ ("The trace parameters you specified were ineffectual because
you did not specify any entrypoints to be added or -set_defaults.");

    if status & n_entrypoints ^= 0
    then
STATUS:
      begin;
        dcl  ep_idx			     fixed bin;
        dcl  ep_ptr			     ptr;
        dcl  n_not_in_tt		     fixed bin;
        dcl  old_seg_no		     bit (18) aligned;
        dcl  specified_ep_idx		     fixed bin;

        if n_specified = 0
        then call ioa_ ("If you want status, you must specify some entrypoints.");
        else call ioa_ ("^/  CALLS RECURSION/HIGHEST   NAME ^18x(STATUS) PARMS ^= DEFAULTS");
        old_seg_no = ""b;
        n_not_in_tt = 0;
        do specified_ep_idx = 0 to n_specified - 1;
	ep_idx = trace_$specified_entrypoint_index (specified_ep_idx);
	if ep_idx < 0
	then n_not_in_tt = n_not_in_tt + 1;
	else do;
	  ep_ptr = trace_$entrypoint_ptr (ep_idx);
	  if baseno (ep_ptr) ^= old_seg_no
	  then do;
	    call ioa_ ("^a", trace_$entrypoint_seg_path (ep_idx));
	    old_seg_no = baseno (ep_ptr);
	  end;
	  counts = trace_$entrypoint_counts (ep_idx);
	  call ioa_ ("^7d ^d/^d ^38a (^a) ^a", counts.calls, counts.level, counts.max_level,
	       trace_$entrypoint_name (ep_idx), trace_$entrypoint_status (ep_idx), trace_$parms_string (ep_idx, "1"b));
	end;
        end;
        if n_not_in_tt > 0
        then do;
	if n_not_in_tt = 1
	then call ioa_ ("^d of the specified entrypoints was not in the trace table.", n_not_in_tt);
	else call ioa_ ("^d of the specified entrypoints were not in the trace table.", n_not_in_tt);
        end;
      end STATUS;

    if print_buffer ^= 0
    then
PRINT_BUFFER:
      begin;
        dcl  buffer_count		     fixed bin (34);
        dcl  buffer_first_idx		     fixed bin (34);
        dcl  buffer_idx		     fixed bin (34);
        call ioa_ ("");
        if ^trace_$buffer ()
        then call ioa_ ("There is no buffer to print.");
        else do;
	call trace_$buffer_counts (buffer_first_idx, buffer_count);
	if buffer_count = 0
	then call ioa_ ("The buffer is empty.");
	else do;
	  buffer_idx = max (buffer_count - print_buffer, buffer_first_idx);
	  call ioa_ ("^8a  ^a", "  EVENT#", trace_$buffer_event_header (buffer_idx));
	  do buffer_idx = buffer_idx to buffer_count - 1;
	    call ioa_ ("^8d  ^a", buffer_idx, trace_$buffer_event_string (buffer_idx));
	  end;
	end;
        end;
      end PRINT_BUFFER;

TRANSACTION_END:
    if ^trace_$transaction_end (transaction_id)		/* Re-enable trace_catch_. */
    then call com_err_ (ZERO, ME, "The trace command ended abnormally.");

    return;



SAY:
  proc (action_i);
    if trace_$loud ()
    then do;
      call INIT ();
      call ioa_$nnl ("^a", action_i);
    end;
    return;

SAY_N_ENTRYPOINTS:
  entry (num_i, action_i);
    if trace_$loud ()
    then do;
      call INIT ();
      if num_i = 1
      then call ioa_$nnl ("^d ep ^a", num_i, action_i);
      else call ioa_$nnl ("^d eps ^a", num_i, action_i);
    end;
    return;

SAY_BEGIN:
  entry ();
    n_things_said = 0;
    return;

SAY_END:
  entry ();
    if n_things_said > 0
    then call ioa_ (".");
    return;

INIT:
    proc ();
      if n_things_said = 0
      then call ioa_$nnl ("^a: ", ME);
      else call ioa_$nnl (", ");
      n_things_said = n_things_said + 1;
    end INIT;

    dcl  action_i			 char (*) parm;
    dcl  num_i			 fixed bin parm;
  end SAY;
%page;
compensations:
compensation:
  entry ();

    call ioa_ ("^24x REAL VCPU");

    call PC (COMPENSATION_FROM_ENTRY_TO_ENTRY, "From entry to entry");
    call PC (COMPENSATION_FROM_ENTRY_TO_RETURN, "From entry to return");
    call PC (COMPENSATION_FROM_RETURN_TO_ENTRY, "From return to entry");
    call PC (COMPENSATION_FROM_RETURN_TO_RETURN, "From return to return");

    return;


PC:
  proc (compensation_type_i, compensation_name_i);
    dcl  compensation_type_i		 fixed bin parm;
    dcl  compensation_name_i		 char (24) parm;
    comp = trace_$compensation (compensation_type_i);
    call ioa_ ("^24a ^4d ^4d", compensation_name_i, comp.real_time, comp.vcpu_time);
    dcl  1 comp			 aligned like compensation;
  end PC;






OBSOLETE_ARG:
  proc (obsolete_arg_i, use_instead_i);
    dcl  (obsolete_arg_i, use_instead_i) char (*) parm;
    call com_err_ (ZERO, ME, "The ^a argument is now obsolete.
Use ^a instead.
This version of the trace command has substantially improved syntax.
Please see the new documentation for trace and watch.", obsolete_arg_i, use_instead_i);
  end OBSOLETE_ARG;



CHECK_NEXT_ARG:
  proc (next_arg_i, max_arg_len_i, control_arg_i, syntax_i, comment_i);
    dcl  (next_arg_i, control_arg_i, syntax_i, comment_i)
				 char (*) parm;
    dcl  max_arg_len_i		 fixed bin (21);

    if addr (next_arg_i) = null ()
    then do;
      call com_err_ (error_table_$noarg, ME, "The syntax is: ^a ^a^a.", control_arg_i, syntax_i, comment_i);
      go to TRANSACTION_END;
    end;

    if length (next_arg_i) > max_arg_len_i
    then do;
      call com_err_ (error_table_$bigarg, ME, "The maximum length for ^a is ^d characters.
The syntax is: ^a ^a^a.", syntax_i, max_arg_len_i, control_arg_i, syntax_i, comment_i);
      go to TRANSACTION_END;
    end;
  end CHECK_NEXT_ARG;
%page;
/* SUBROUTINES */

SUB_ERROR_HANDLER:
  proc (mcptr_i, a_name_i, wcptr_i, info_ptr_i, continue_o);
    sub_error_info_ptr = info_ptr_i;
    condition_info_header_ptr = null ();
    if sub_error_info.name ^= trace_$me ()
    then go to CONTINUE;
    if sub_error_info.header.support_signal | sub_error_info.header.quiet_restart
    then go to HANDLED;
    if sub_error_info.header.default_restart
    then go to REPORT;
    if sub_error_info.header.cant_restart
    then go to REPORT_AND_ABORT;
    else go to CONTINUE;

REPORT_AND_ABORT:
    call com_err_ (sub_error_info.header.status_code, ME, "^a", sub_error_info.header.info_string);
    go to TRANSACTION_END;

REPORT:
    call com_err_ (sub_error_info.header.status_code, ME, "^a", sub_error_info.header.info_string);

HANDLED:
    continue_o = "0"b;
    return;

CONTINUE:
    continue_o = "1"b;
    return;

    dcl  mcptr_i			 ptr parm;
    dcl  a_name_i			 char (*) parm;
    dcl  info_ptr_i			 ptr parm;
    dcl  wcptr_i			 ptr parm;
    dcl  continue_o			 bit aligned;

%include condition_info_header;

%include sub_error_info;

  end SUB_ERROR_HANDLER;
%page;
/* START OF DECLARATIONS */
/* format: ^insnl,^delnl */


/* Automatic */

    dcl  add_remove_action		 char (8) init ("");
    dcl  arg_count			 fixed bin init (0);
    dcl  arg_idx			 fixed bin init (0);
    dcl  arg_len			 fixed bin (21) init (0);
    dcl  arg_ptr			 ptr init (null ());
    dcl  code			 fixed bin (35) init (0);
    dcl  n_entrypoints		 fixed bin;
    dcl  n_specified		 fixed bin init (0);
    dcl  n_things_said		 fixed bin init (0);
    dcl  next_arg_idx		 fixed bin init (0);
    dcl  next_arg_len		 fixed bin (21) init (0);
    dcl  next_arg_ptr		 ptr init (null ());
    dcl  on_off_action		 char (4) init ("");
    dcl  parameters			 bit aligned init ("0"b);
    dcl  print_buffer		 fixed bin (34);
    dcl  set_defaults		 bit aligned init ("0"b);
    dcl  status			 bit aligned init ("0"b);
    dcl  transaction_id		 fixed bin (71) init (0);


/* Static */

    dcl  FIRST_TIME			 bit aligned static init ("1"b);
    dcl  ME			 char (32) static options (constant) init ("trace");
    dcl  ZERO			 fixed bin (35) static options (constant) init (0);


/* Conditions */

    dcl  cleanup			 condition;
    dcl  error			 condition;


/* Based */

    dcl  arg			 char (arg_len) based (arg_ptr);
    dcl  next_arg			 char (next_arg_len) based (next_arg_ptr);


/* External Variables */

    dcl  error_table_$badopt		 fixed bin (35) ext;
    dcl  error_table_$bigarg		 fixed bin (35) ext;
    dcl  error_table_$noarg		 fixed bin (35) ext;


/* External Entries */

    dcl  com_err_			 entry options (variable);
    dcl  condition_			 entry (char (*), entry);
    dcl  cu_$arg_count		 entry (fixed bin, fixed bin (35));
    dcl  cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
    dcl  ioa_			 entry () options (variable);
    dcl  ioa_$nnl			 entry () options (variable);


/* format: insnl,delnl */
/* END OF DECLARATIONS */
%page;
/* START OF INCLUDE FILES */


%include trace_interface;


  end trace;




		    trace_.alm                      11/05/86  1345.5r w 11/04/86  1038.2      108297



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1984 *
" *                                                         *
" ***********************************************************

" This is (or will be) the trace gate.
" For efficiency, it implements some of the simple operations.

" Written: May 1984 by Jeffrey D. Ives.


	name	trace_


INITIALIZE_EVERYTHING:
	getlp
	call6	trace_transactions_$initialize_everything

	firstref	<*text>|INITIALIZE_EVERYTHING

	include	gate_macros





	gate_info





macro	TraceGate
	gentry	&1,&3*2,0
	tsx2	TRACE_SETUP
	call6	&2
	&end	

" CATCH EXECUTION

	TraceGate	catch_pl1,trace_catch_$catch_pl1_,0


" IDENTIFICATION

		" () returns (char (32))
	TraceGate	me,trace_version_$me,1

		" () returns (char (32))
	TraceGate	version,trace_version_$version,1

" TRANSACTIONS

			" entry (fixed bin (71)) returns (bit aligned)
	TraceGate	transaction_begin,trace_transactions_$transaction_begin,2

			" entry (fixed bin (71))
	TraceGate	transaction_begin_force,trace_transactions_$transaction_begin_force,1

			" entry (fixed bin (71)) returns (bit aligned)
	TraceGate	transaction_end,trace_transactions_$transaction_end,2

" UPDATES

			" entry () returns (bit aligned)
	TraceGate	update_default_parms,trace_parameters_$update_default_parms,1

			" entry () returns (bit aligned)
	TraceGate	update_global_parms,trace_parameters_$update_global_parms,1

			" entry (fixed bin, fixed bin)
	TraceGate	add_specified_eps,trace_tables_$add_specified_eps,2

			" entry (fixed bin, fixed bin)
	TraceGate	add_specified_locs,trace_tables_$add_specified_locs,2

			" entry (fixed bin)
	TraceGate	remove_specified_eps,trace_tables_$remove_specified_eps,1

			" entry (fixed bin)
	TraceGate	remove_specified_locs,trace_tables_$remove_specified_locs,1

			" entry (fixed bin)
	TraceGate	turn_on_specified_eps,trace_tables_$turn_on_specified_eps,1

			" entry (fixed bin)
	TraceGate	turn_off_specified_eps,trace_tables_$turn_off_specified_eps,1

" CONVERSION

			" (char (8) aligned) returns (bit (2) aligned)
	TraceGate	cv_inout_to_bits,trace_conversions_$cv_inout_to_bits,2

			" (bit (2) aligned) returns (char (8) aligned)
	TraceGate	cv_bits_to_inout,trace_conversions_$cv_bits_to_inout,2

			" (char (16) aligned) returns (fixed bin (34))
	TraceGate	cv_n_to_number,trace_conversions_$cv_n_to_number,2

			" (char (8)) returns (bit aligned)
	TraceGate	cv_onoff_to_bit,trace_conversions_$cv_onoff_to_bit,2

			" (bit aligned) returns (char (8))
	TraceGate	cv_bit_to_onoff,trace_conversions_$cv_bit_to_onoff,2

			" (char (256) var, ptr) returns (1 like stop_proc aligned)
	TraceGate	cv_entry_name_to_spp,trace_print_$cv_entry_name_to_spp,3

			" (char (256) var, ptr) returns (1 like output_switch aligned)
	TraceGate	cv_file_path_to_osw,trace_print_$cv_file_path_to_osw,3

			" (char (32) var) returns (1 like output_switch aligned)
	TraceGate	cv_stream_name_to_osw,trace_print_$cv_stream_name_to_osw,2


" METERS

			" (fixed bin) returns (1 aligned like counts)
	TraceGate	entrypoint_counts,trace_tables_$entrypoint_counts,2

			" (fixed bin) returns (1 aligned like meters)
	TraceGate	entrypoint_global_meters,trace_tables_$entrypoint_global_meters,2

			" (fixed bin) returns (1 aligned like meters)
	TraceGate	entrypoint_local_meters,trace_tables_$entrypoint_local_meters,2

			" entry () returns (1 like meters aligned)
	TraceGate	metered,trace_tables_$metered,1

			" entry () returns (1 like meters aligned)
	TraceGate	removed,trace_tables_$removed,1

			" entry ()
	TraceGate	reset_meters,trace_tables_$reset_meters,0

" ENTRYPOINTS

			" (ptr unal) returns (fixed bin)
	TraceGate	entrypoint_index,trace_tables_$entrypoint_index,2

			" (fixed bin) returns (char (256) var)
	TraceGate	entrypoint_name,trace_tables_$entrypoint_name,2

			" (fixed bin) returns (ptr)
	TraceGate	entrypoint_ptr,trace_tables_$entrypoint_ptr,2

			" (fixed bin) returns (char (256) var)
	TraceGate	entrypoint_seg_path,trace_tables_$entrypoint_seg_path,2

			" (fixed bin) returns (char (32) var)
	TraceGate	entrypoint_status,trace_tables_$entrypoint_status,2

			" (fixed bin) returns (bit aligned)
	TraceGate	function,trace_tables_$function,2

			" () returns (fixed bin)
	TraceGate	num_entrypoints,trace_tables_$num_entrypoints,1

			" () returns (fixed bin)
	TraceGate	num_specified_entrypoints,trace_tables_$num_specified_entrypoints,1

			" (fixed bin) returns (fixed bin)
	TraceGate	specified_entrypoint_index,trace_tables_$specified_entrypoint_index,2

			" (char (256) var, ptr)
	TraceGate	specify_entrypoints,trace_entrypoints_$specify_entrypoints,2

			" (fixed bin) returns (fixed bin)
	TraceGate	translator_id,trace_tables_$translator_id,2

" LOCATIONS


			" (fixed bin) returns (ptr)
	TraceGate	location_ptr,trace_tables_$location_ptr,2

			" (fixed bin) returns (char (256) var)
	TraceGate	location_seg_path,trace_tables_$location_seg_path,2

			" (fixed bin) returns (1 aligned like values)
	TraceGate	location_values,trace_tables_$location_values,2

			" () returns (fixed bin)
	TraceGate	num_locations,trace_tables_$num_locations,1

			" () returns (fixed bin)
	TraceGate	num_specified_locations,trace_tables_$num_specified_locations,1

			" (fixed bin) returns (fixed bin)
	TraceGate	specified_location_index,trace_tables_$specified_location_index,2

			" (char (256) var)
	TraceGate	specify_locations,trace_tables_$specify_locations,1

			" ()
	TraceGate	specify_changed_locations,trace_tables_$specify_changed_locations,0

" EVENT BUFFER


			" (fixed bin (34), fixed bin (34))
	TraceGate	buffer_counts,trace_print_$buffer_counts,2

			" (fixed bin (34), fixed bin, char (2), ptr unal,
			"  1 like counts aligned, 1 like meters aligned)
	TraceGate	buffer_event,trace_print_$buffer_event,6

			" (fixed bin (34)) returns (char (256) var)
	TraceGate	buffer_event_header,trace_print_$buffer_event_header,2

			" (fixed bin (34)) returns (char (256) var)
	TraceGate	buffer_event_string,trace_print_$buffer_event_string,2

			" () returns (ptr unal)
	TraceGate	buffer_ptr,trace_parameters_$buffer_ptr,1

" TRACE PARAMETERS


			" (fixed bin) returns (bit (2) aligned)
	TraceGate	arguments,trace_parameters_$arguments,2

			" (bit (2) aligned)
	TraceGate	set_arguments,trace_parameters_$set_arguments,1

			" (fixed bin) returns (char (256) var)
	TraceGate	call,trace_parameters_$call,2

			" (char (256) var)
	TraceGate	set_call,trace_parameters_$set_call,1

			" (fixed bin) returns (fixed bin (34))
	TraceGate	every,trace_parameters_$every,2

			" (fixed bin (34))
	TraceGate	set_every,trace_parameters_$set_every,1

			" (fixed bin) returns (fixed bin (34))
	TraceGate	first,trace_parameters_$first,2

			" (fixed bin (34))
	TraceGate	set_first,trace_parameters_$set_first,1

			" (fixed bin) returns (fixed bin (34))
	TraceGate	high,trace_parameters_$high,2

			" (fixed bin (34))
	TraceGate	set_high,trace_parameters_$set_high,1

			" (fixed bin) returns (fixed bin (34))
	TraceGate	last,trace_parameters_$last,2

			" (fixed bin (34))
	TraceGate	set_last,trace_parameters_$set_last,1

			" (fixed bin) returns (fixed bin (34))
	TraceGate	low,trace_parameters_$low,2

			" (fixed bin (34))
	TraceGate	set_low,trace_parameters_$set_low,1

			" (fixed bin) returns (bit aligned)
	TraceGate	new_high,trace_parameters_$new_high,2

			" (bit aligned)
	TraceGate	set_new_high,trace_parameters_$set_new_high,1

			" (fixed bin, bit aligned) returns (char (256) var)
	TraceGate	parms_string,trace_parameters_$parms_string,3

			" () returns (bit aligned)
	TraceGate	parms_specified,trace_parameters_$parms_specified,1

			" (fixed bin) returns (bit (2) aligned)
	TraceGate	stop,trace_parameters_$stop,2

			" (bit (2) aligned)
	TraceGate	set_stop,trace_parameters_$set_stop,1

			" (fixed bin) returns (fixed bin (34))
	TraceGate	stop_every,trace_parameters_$stop_every,2

			" (fixed bin (34))
	TraceGate	set_stop_every,trace_parameters_$set_stop_every,1

			" (fixed bin) returns (fixed bin (34))
	TraceGate	stop_low,trace_parameters_$stop_low,2

			" (fixed bin (34))
	TraceGate	set_stop_low,trace_parameters_$set_stop_low,1

			" (fixed bin) returns (bit (2) aligned)
	TraceGate	trace,trace_parameters_$trace,2

			" (bit (2) aligned)
	TraceGate	set_trace,trace_parameters_$set_trace,1

" GLOBAL PARAMETERS


			" () returns (bit aligned)
	TraceGate	alm,trace_parameters_$alm,1

			" (bit aligned)
	TraceGate	set_alm,trace_parameters_$set_alm,1

			" () returns (bit aligned)
	TraceGate	automatic,trace_parameters_$automatic,1

			" (bit aligned)
	TraceGate	set_automatic,trace_parameters_$set_automatic,1

			" () returns (bit aligned)
	TraceGate	buffer,trace_parameters_$buffer,1

			" (bit aligned)
	TraceGate	set_buffer,trace_parameters_$set_buffer,1

			" () returns (bit aligned)
	TraceGate	calibrate,trace_parameters_$calibrate,1

			" (bit aligned)
	TraceGate	set_calibrate,trace_parameters_$set_calibrate,1

			" (fixed bin) returns (1 aligned like compensation)
	TraceGate	compensation,trace_parameters_$compensation,2

			" (fixed bin, 1 aligned like compensation)
	TraceGate	set_compensation,trace_parameters_$set_compensation,2

			" () returns (bit aligned)
	TraceGate	enabled,trace_parameters_$enabled,1

			" (bit aligned)
	TraceGate	set_enabled,trace_parameters_$set_enabled,1

			" () returns (char (256) var);
	TraceGate	global_parms_string,trace_parameters_$global_parms_string,1

			" returns (bit aligned)
	TraceGate	long,trace_parameters_$long,1

			" (bit aligned)
	TraceGate	set_long,trace_parameters_$set_long,1

			" () returns (bit aligned)
	TraceGate	meter,trace_parameters_$meter,1

			" (bit aligned)
	TraceGate	set_meter,trace_parameters_$set_meter,1

			" () returns (1 like output_switch aligned)
	TraceGate	output_switch,trace_parameters_$output_switch,1

			" (1 like output_switch aligned)
	TraceGate	set_output_switch,trace_parameters_$set_output_switch,1

			" () returns (bit aligned)
	TraceGate	signals,trace_parameters_$signals,1

			" (bit aligned)
	TraceGate	set_signals,trace_parameters_$set_signals,1

			" () returns (1 like stop_proc aligned)
	TraceGate	stop_proc,trace_parameters_$stop_proc,1

			" (1 like stop_proc aligned)
	TraceGate	set_stop_proc,trace_parameters_$set_stop_proc,1

			" () returns (entry)
	TraceGate	stop_routine,trace_parameters_$stop_routine,1

			" (entry)
	TraceGate	set_stop_routine,trace_parameters_$set_stop_routine,1

			" () returns (entry)
	TraceGate	trace_routine,trace_parameters_$trace_routine,1

			" (entry)
	TraceGate	set_trace_routine,trace_parameters_$set_trace_routine,1

			" () returns (bit aligned)
	TraceGate	loud,trace_parameters_$loud,1

			" (bit aligned)
	TraceGate	set_loud,trace_parameters_$set_loud,1


" MISCELLANEOUS

			" () returns (bit aligned)
	TraceGate	in_trace,IN_TRACE,1


TRACE_SETUP:
	epaq	*		get_lp without invoking trace_catch_
	lprp4	pr7|stack_header.lot_ptr,*au

	ldx1	-2,2		get number of args expected
	tze	0,2		if zero, none or doesn't matter
	cmpx1	ap|0		compare against number given
	tze	0,2		args match, call procedure
	eaa	TRUE			Take this out when
	sta	pr7|stack_header.in_trace	trace becomes a real gate.
	call6	trace_$SIGNAL_GATE_ERROR

	entry	SIGNAL_GATE_ERROR		Buff up before signalling.
SIGNAL_GATE_ERROR:
	push
	call	signal_$signal_(signal_arglist)
	oct	0		hopefully, it never returns


IN_TRACE:
	lda	pr7|stack_header.in_trace
	sta	pr0|2,*
	short_return		Life can be easy sometimes.



" CONSTANTS

		even
null_ptr:		oct	077777000043,000001000000
ptr_mask:		oct	077777000077,777777077077


" STATIC

		use	static_section
		join	/link/static_section

		even
		segdef	transaction_id
transaction_id:	dec	0,0

		even
		segdef	stt_ptr
stt_ptr:		its	-1,1

		even
		segdef	swt_ptr
swt_ptr:		its	-1,1

		segdef	parameters_ptr
parameters_ptr:	oct	007777000001

		even
		segdef	global_parameters
		bss	global_parameters,182

" SYMBOLS  SYMBOLS  SYMBOLS  SYMBOLS  SYMBOLS  SYMBOLS  SYMBOLS  SYMBOLS

	bool	TRUE,400000



	include	stack_header

	end




		    trace_calibrate_.pl1            01/11/85  1045.4rew 01/11/85  1034.9      113904



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/*
   This program experimentally determines the metering compensation values.

   Written: May 1984 by Jeffrey D. Ives.
*/
/* format: style2,ifthendo,^indnoniterdo,thendo,^inditerdo,indproc,ind2,dclind5,idind32 */


trace_calibrate_:
  proc (compensation_kind_i, entry_comp_o, return_comp_o);

    if trace_$num_entrypoints () ^= 0
    then signal error;

    transaction_id = clock ();
    if ^trace_$transaction_begin (transaction_id)
    then signal error;
    if compensation_kind_i = "repeat"
    then do;
      call trace_tables_$specify_entrypoint (codeptr (trace_repeat_), "trace_repeat_$trace_repeat_", 0, "0"b);
      call trace_tables_$specify_entrypoint (codeptr (trace_repeat_dummy_), "trace_repeat_dummy_$trace_repeat_dummy_", 0, "0"b);
    end;
    else if compensation_kind_i = "recurse"
    then do;
      call trace_tables_$specify_entrypoint (codeptr (trace_recurse_), "trace_recurse_$trace_recurse_", 0, "0"b);
      call
        trace_tables_$specify_entrypoint (codeptr (trace_recurse_dummy_), "trace_recurse_dummy_$trace_recurse_dummy_", 0, "0"b);
    end;
    else signal error;
    stop_routine_saved = trace_$stop_routine ();
    call trace_$set_stop_routine (SNAP_ENTRIES);
    call trace_$set_enabled ("0"b);			/* Run without trace operators.		*/
    call trace_$set_trace ("00"b);
    if ^trace_$update_global_parms ()
    then signal error;
    call trace_$add_specified_eps (n_added, n_modified);
    if n_added ^= 2 | n_modified ^= 0
    then signal error;
    if ^trace_$transaction_end (transaction_id)
    then signal error;

    total = 0;
    trials_vcpu_start = vclock ();

TRIAL_LOOP:
    do total_trials = 0 by 1 while (total_trials < NUMBER_OF_TRIALS);
      run.elapsed = 0;

NO_INTERRUPTION_LOOP:				/* We are striving for perfection.		*/
      do while (run.elapsed.real_time >= run.elapsed.vcpu_time);
        if vclock () - trials_vcpu_start > 2000000
        then go to END_OF_TRIALS;			/* We know when to give up.			*/

        run.start.vcpu_time = vclock ();
        run.start.real_time = clock ();

        if compensation_kind_i = "repeat"
        then do;
	call
	  trace_repeat_ (NUMBER_OF_BASELINE_CALLS, trial.benchmark.baseline.entry.real_time,
	  trial.benchmark.baseline.return.real_time);
	call
	  trace_repeat_ (NUMBER_OF_BASELINE_CALLS + NUMBER_OF_MEASURED_CALLS, trial.benchmark.measure.entry.real_time,
	  trial.benchmark.measure.return.real_time);
        end;
        else if compensation_kind_i = "recurse"
        then do;
	call
	  trace_recurse_ (NUMBER_OF_BASELINE_CALLS, trial.benchmark.baseline.entry.real_time,
	  trial.benchmark.baseline.return.real_time);
	call
	  trace_recurse_ (NUMBER_OF_BASELINE_CALLS + NUMBER_OF_MEASURED_CALLS, trial.benchmark.measure.entry.real_time,
	  trial.benchmark.measure.return.real_time);
        end;
        else signal error;

        transaction_id = clock ();
        if ^trace_$transaction_begin (transaction_id)
        then signal error;
        else if compensation_kind_i = "recurse"
        then do;
	call
	  trace_tables_$specify_entrypoint (codeptr (trace_recurse_dummy_), "trace_recurse_dummy_$trace_recurse_dummy_",
	  0, "0"b);
	call trace_$set_trace ("00"b);
	call trace_$set_stop ("10"b);			/* -stop in */
	call trace_$set_stop_every (NUMBER_OF_BASELINE_CALLS);
	call trace_$add_specified_eps (n_added, n_modified);
	if n_added ^= 0 | n_modified ^= 1
	then signal error;
        end;
        call trace_$set_enabled ("1"b);
        if ^trace_$update_global_parms ()
        then signal error;
        call trace_$reset_meters ();
        if ^trace_$transaction_end (transaction_id)
        then signal error;

        if compensation_kind_i = "repeat"
        then call trace_repeat_ (NUMBER_OF_BASELINE_CALLS, not_used (1), not_used (2));
        else if compensation_kind_i = "recurse"
        then call trace_recurse_ (NUMBER_OF_BASELINE_CALLS, not_used (1), not_used (2));
        else signal error;

        transaction_id = clock ();
        if ^trace_$transaction_begin (transaction_id)
        then signal error;
        do tt_idx = 0 to 1;
	meters = trace_$entrypoint_local_meters (tt_idx);
	entry_ptr = trace_$entrypoint_ptr (tt_idx);
	if entry_ptr = codeptr (trace_repeat_)
	then do;
	  trial.meter.baseline.return.real_time = meters.real_time;
	  trial.meter.baseline.return.vcpu_time = meters.vcpu_time;
	end;
	else if entry_ptr = codeptr (trace_repeat_dummy_)
	then do;
	  trial.meter.baseline.entry.real_time = meters.real_time;
	  trial.meter.baseline.entry.vcpu_time = meters.vcpu_time;
	end;
	else if entry_ptr = codeptr (trace_recurse_)
	then ;
	else if entry_ptr = codeptr (trace_recurse_dummy_)
	then do;
	  trial.meter.baseline.return.real_time = meters.real_time - trial.meter.baseline.entry.real_time;
	  trial.meter.baseline.return.vcpu_time = meters.vcpu_time - trial.meter.baseline.entry.vcpu_time;
	  call
	    trace_tables_$specify_entrypoint (codeptr (trace_recurse_dummy_),
	    "trace_recurse_dummy_$trace_recurse_dummy_", 0, "0"b);
	  call trace_$set_trace ("00"b);
	  call trace_$set_stop ("10"b);		/* -stop in */
	  call trace_$set_stop_every (NUMBER_OF_BASELINE_CALLS + NUMBER_OF_MEASURED_CALLS);
	  call trace_$add_specified_eps (n_added, n_modified);
	  if n_added ^= 0 | n_modified ^= 1
	  then signal error;
	end;
	else signal error;
        end;
        call trace_$reset_meters ();
        if ^trace_$transaction_end (transaction_id)
        then signal error;

        if compensation_kind_i = "repeat"
        then call trace_repeat_ (NUMBER_OF_BASELINE_CALLS + NUMBER_OF_MEASURED_CALLS, not_used (1), not_used (2));
        else if compensation_kind_i = "recurse"
        then call trace_recurse_ (NUMBER_OF_BASELINE_CALLS + NUMBER_OF_MEASURED_CALLS, not_used (1), not_used (2));
        else signal error;

        run.stop.real_time = clock ();
        run.stop.vcpu_time = vclock ();

        run.elapsed = run.stop - run.start;

        transaction_id = clock ();
        if ^trace_$transaction_begin (transaction_id)
        then signal error;
        call trace_$set_enabled ("0"b);			/* Run without trace operators.		*/
        if ^trace_$update_global_parms ()
        then signal error;
        if ^trace_$transaction_end (transaction_id)
        then signal error;
      end NO_INTERRUPTION_LOOP;


      do tt_idx = 0 to 1;
        entry_ptr = trace_$entrypoint_ptr (tt_idx);
        meters = trace_$entrypoint_local_meters (tt_idx);

        if entry_ptr = codeptr (trace_repeat_)
        then do;
	trial.meter.measure.return.real_time = meters.real_time;
	trial.meter.measure.return.vcpu_time = meters.vcpu_time;
        end;
        else if entry_ptr = codeptr (trace_repeat_dummy_)
        then do;
	trial.meter.measure.entry.real_time = meters.real_time;
	trial.meter.measure.entry.vcpu_time = meters.vcpu_time;
        end;
        else if entry_ptr = codeptr (trace_recurse_)
        then ;
        else if entry_ptr = codeptr (trace_recurse_dummy_)
        then do;
	trial.meter.measure.return.real_time = meters.real_time - trial.meter.measure.entry.real_time;
	trial.meter.measure.return.vcpu_time = meters.vcpu_time - trial.meter.measure.entry.vcpu_time;
        end;
        else signal error;
      end;

      total = total + trial;
    end TRIAL_LOOP;

END_OF_TRIALS:
    transaction_id = clock ();
    if ^trace_$transaction_begin (transaction_id)
    then signal error;
    call trace_$specify_entrypoints ("*", null ());
    call trace_$set_stop_routine (stop_routine_saved);
    call trace_$set_enabled ("1"b);
    if ^trace_$update_global_parms ()
    then signal error;
    call trace_$remove_specified_eps (n_removed);
    if n_removed ^= 2
    then signal error;
    if ^trace_$transaction_end (transaction_id)
    then signal error;

    if total_trials = 0
    then do;
      entry_comp_o = 0;
      return_comp_o = 0;
    end;
    else do;
      total_measured_calls = multiply (total_trials, NUMBER_OF_MEASURED_CALLS, 17);

      entry_comp_o =
        divide ((total.meter.measure.entry - total.meter.baseline.entry)
        - (total.benchmark.measure.entry.real_time - total.benchmark.baseline.entry.real_time), total_measured_calls, 53);
      return_comp_o =
        divide ((total.meter.measure.return - total.meter.baseline.return)
        - (total.benchmark.measure.return.real_time - total.benchmark.baseline.return.real_time), total_measured_calls,
        53);
    end;

    return;
%page;
/* SUBROUTINES */


SNAP_ENTRIES:
  proc (event_i);
    dcl  1 event_i			 like event aligned parm;
    dcl  EVENT_VERSION_3		 char (4) aligned static options (constant) init ("TEV3");
    dcl  event_ptr			 ptr;
    dcl  1 event			 aligned based (event_ptr),
						/* Trace_catch_ knows this is 16 words.	*/
	 2 version		 char (4),
	 2 kind			 char (2) unal,
	 2 frame_count		 fixed bin unal,
	 2 frame			 like meters,
	 2 entry_ptr		 ptr unal,
	 2 saved			 like counts,
	 2 entry_idx		 fixed bin,
	 2 arg_list_ptr		 ptr unal,
	 2 callers_sp		 ptr unal,
	 2 return_ptr		 ptr unal;
    dcl  1 snap_meters		 like meters aligned;
    dcl  trace_catch_$start_tracing	 entry ();
    dcl  trace_catch_$stop_tracing	 entry ();

    event_ptr = addr (event_i);
    if event.version ^= EVENT_VERSION_3 | event.kind ^= "ca"
    then signal error;

    call trace_catch_$stop_tracing ();			/* Flush meters form trace_catch_ frames in stack.*/
    snap_meters = trace_$entrypoint_local_meters (event.entry_idx);
    call trace_catch_$start_tracing ();			/* Replant the trace operators pointers.	*/

    if event.saved.calls + 1 = NUMBER_OF_BASELINE_CALLS
    then do;
      trial.meter.baseline.entry.real_time = snap_meters.real_time;
      trial.meter.baseline.entry.vcpu_time = snap_meters.vcpu_time;
    end;
    else if event.saved.calls + 1 = NUMBER_OF_BASELINE_CALLS + NUMBER_OF_MEASURED_CALLS
    then do;
      trial.meter.measure.entry.real_time = snap_meters.real_time;
      trial.meter.measure.entry.vcpu_time = snap_meters.vcpu_time;
    end;
    else signal error;

    return;
  end SNAP_ENTRIES;
%page;
/* START OF DECLARATIONS */
/* format: ^insnl,^delnl */

/* Parameters */

    dcl  compensation_kind_i		 char (8) aligned parm;
    dcl  1 entry_comp_o		 aligned parm like compensation;
    dcl  1 return_comp_o		 aligned parm like compensation;


/* Automatic */

    dcl  entry_ptr			 ptr unal;
    dcl  n_added			 fixed bin;
    dcl  n_modified			 fixed bin;
    dcl  n_removed			 fixed bin;
    dcl  not_used			 (2) fixed bin (53);
    dcl  stop_routine_saved		 entry variable;
    dcl  total_measured_calls		 fixed bin;
    dcl  total_trials		 fixed bin;
    dcl  transaction_id		 fixed bin (71);
    dcl  trials_vcpu_start		 fixed bin (53);
    dcl  tt_idx			 fixed bin;

    dcl  1 run			 aligned,
	 2 start			 like compensation,
	 2 stop			 like compensation,
	 2 elapsed		 like compensation;

    dcl  1 trial			 aligned,
	 2 benchmark,
	   3 baseline,
	     4 entry,
	       5 real_time		 fixed bin (53),
	     4 return,
	       5 real_time		 fixed bin (53),
	   3 measure,
	     4 entry,
	       5 real_time		 fixed bin (53),
	     4 return,
	       5 real_time		 fixed bin (53),
	 2 meter,
	   3 baseline,
	     4 entry		 like compensation,
	     4 return		 like compensation,
	   3 measure,
	     4 entry		 like compensation,
	     4 return		 like compensation;

    dcl  1 total			 aligned like trial;


/* Static */

    dcl  NUMBER_OF_BASELINE_CALLS	 fixed bin (34) static options (constant) init (2);
    dcl  NUMBER_OF_MEASURED_CALLS	 fixed bin (34) static options (constant) init (16);
    dcl  NUMBER_OF_TRIALS		 fixed bin static options (constant) init (8);
    dcl  ZERO			 fixed bin (35) static options (constant) init (0);


/* Conditions */

    dcl  error			 condition;


/* Based */



/* External Variables */



/* External Entries */

    dcl  trace_repeat_		 entry (fixed bin (34), fixed bin (53), fixed bin (53));
    dcl  trace_repeat_dummy_		 entry (fixed bin (53));
    dcl  trace_recurse_		 entry (fixed bin (34), fixed bin (53), fixed bin (53));
    dcl  trace_recurse_dummy_		 entry (fixed bin, fixed bin (53));
    dcl  trace_tables_$specify_entrypoint entry (ptr unal, char (65) var, fixed bin, bit aligned);


/* format: insnl,delnl */
/* END OF DECLARATIONS */
%page;
/* START OF INCLUDE FILES */


%include sub_err_flags;
%page;
%include trace_interface;

  end trace_calibrate_;




		    trace_catch_.alm                11/05/86  1345.5r w 11/04/86  1038.2      499491



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************

" Program to trace procedure calls
"
" Barry L. Wolman, 2 January 1970
" Modified: 18 June 1971 by BLW for Version II pl1
" Modified: 30 May 1972 by BLW to use per/process info procedure instead of usage_values
" Modified: 2 March 1973 by BLW for 6180
" Modified: 16 May 1974 by BLW for change in setting up cleanup handler
" Modified: 2 January 1974 by Richard A. Barnes to fix up many bugs
" Modified: 7 May 1975 by RAB for new pl1_operators_ interface
" Modified: 6 December 1975 by RAB to fix bugs in TRACE_CATCH_CLEANUP and update_stats
" Modified: 20 September 1977 by PCK to use a temporary segment for trace_storage.
" Modified: Autumn 1978 by R.E. Mullen for dynamic tracelist
" Modified: 28 July 1981 by Jeffrey D. Ives, fix returns (*), cleanup trace_catch_$in_trace.
" Modified: 01 Apr 1982 by Jeffrey D. Ives, add trace_catch_$switch for efficiency.
" Rewritten: 23 June 1983 by Jeffrey D. Ives, multitasking, accurate metering, and macros.
" Modified: May 1984 by Jeffrey D. Ives, for new trace_tab, parameters, global_parameters.

	name	trace_catch_


" This is the first reference trap code for trace_catch_.  It snaps these
" links so that the linker will not run and invoke trace_catch_ while
" trace_catch_ itself is running.

	entry	initialize
initialize:
	rccl	sys_info$clock_,*
	epp5	cpu_time_and_paging_op_$cpu_time_and_paging_op_
	epp5	trace_catch_$trace_catcher_
	epp5	trace_catch_$TRACE_CATCH_CLEANUP

	epp5	pl1_operators_$operator_table
	epp5	operator_pointers_$operator_pointers_
	epp5	pl1_operators_$alm_entry
	epp5	pl1_operators_$trace_operator_table
	epp5	trace_operator_pointers_$trace_operator_pointers_
	epp5	pl1_operators_$trace_alm_entry

" Remember these entrypoints because they are very special.

	epp5	trace_transactions_$transaction_begin
	sprp5	pr4|TRANSACTION_BEGIN
	epp5	trace_transactions_$transaction_begin_force
	sprp5	pr4|TRANSACTION_BEGIN_FORCE
	epp5	signal_$signal_
	sprp5	pr4|SIGNAL_
	epp5	signal_$io_signal
	sprp5	pr4|IO_SIGNAL
	short_return

" STACK FRAME DATA   STACK FRAME DATA   STACK FRAME DATA   STACK FRAME DATA

" Do not put anything ahead of ptr_registers_saved unless it is mod16 in length.

	temp8	registers_saved
	temp8	ptr_registers_saved(2)	" This must be on a mod16 boundary!

	tempd	arg_list.header
	tempd	arg_list.first_arg_ptr
	tempd	arg_list.second_arg_ptr
	tempd	arg_list.third_arg_ptr

	tempd	event(8)
	tempd	cleanup_unit(3)
	tempd	trace_frames_saved

	tempd	global_start.real_time	" These three MUST be kept together.
	tempd	global_start.vcpu_time
	temp	global_start.page_faults

	temp	indicators_saved
	temp	watch_values_changed
	temp	stack_frame_end(0)		" For checking stack_frame_size.

	equ	stack_frame_size,112	" Trace_catch_ pushes this size frame.

" MACRO DEFINITIONS   MACRO DEFINITIONS   MACRO DEFINITIONS   MACRO DEFINITIONS


	macro	get_pr4
	epaq	*
	lprp4	pr7|stack_header.lot_ptr,*au
	&end




	macro	read_the_calendar_clock	<pr4|&1 like meters aligned>
	rccl	sys_info$clock_,*
	staq	pr4|&1+meters.real_time
	&end




	macro	read_vcpu_time_and_page_faults <pr4|&1 like meters aligned>

	stcd	pr6|stack_frame.return_ptr
	call6	cpu_time_and_paging_op_$cpu_time_and_paging_op_

	epbp7	pr6|0
	epp4	pr6|stack_frame.lp_ptr,*
	staq	pr4|&1+meters.vcpu_time   " Vcpu time is returned in AQ register.
	stx0	pr4|&1+meters.page_faults " Page faults are returned in X0 and X1.
	sxl1	pr4|&1+meters.page_faults
	&end

"		  A FEW WORDS ON THE METERING METHOD

" The trace facility meters real time, virtual CPU time, and page faults.
" Trace_catch_ reads the real time clock and usage meters as soon as possible
" when it gets control and as late as possible when it relinquishes control.
" This minimizes the effect of the overhead tracing overhead that is metered.
" The remaining inaccuracy is reduced by a set of compensation values.

" There are four kinds of intervals during which an entrypoint can collect
" meters:

"      1. from the time it is entered until control enters another
"      2. from the time it is entered until it returns
"      3. from the time it is returned to until it enters another
"      4. from the time it is returned to until it returns

" When control leaves trace_catch_, the meters are always saved in
" trace_catch_$start.  When control comes back, they are saved in
" trace_catch_$stop.  The difference between start and stop is accumulated in
" the trace_catch_ frame associated with the procedure that relinquished
" control.  Eventually, when that frame is popped or unwound, the accumulated
" meters are added to the tab for that procedure.  At that time, they are also
" added to trace_catch_$metered which accumulates all metered quantities and
" is always equal the sum of the meters in the tabs and trace_catch_$removed,
" which accumulates the meters of entrypoints that are removed from the trace
" table.

" The meters described in the previous paragraph are called frame meters and
" represent the usage of a procedure without including the usage of any traced
" procedures it calls.  Global meters represent the usage from the time a
" procedure is called until it returns.  However, if it calls itself, it
" should not be double metered.  When an entrypoint is called, the values in
" trace_catch_$metered are saved in its trace_catch_ frame in the variable
" global_start.  When it finally returns (or is unwound) the difference
" between the current value of tc_$metered and global_start is added to
" tab.global, which accumulates the entrypoint's global meters.

" The user may wish to see the meters or remove entrypoints from the trace
" table while trace_catch_ frames are still on the stack.  Therefore, at the
" beginning of each trace command, there is a call to
" trace_catch_$stop_tracing.  This routine yanks the trace operator pointers
" and walks the stack of trace_catch_ frames, flushing the accumulated frame
" and global meters into the corresponding tabs.  At the end of each trace
" command, there is a call to trace_catch_$start_tracing which again walks the
" stack and sets the global_starts to tc_$metered.

" This macro starts a metering interval.  It puts the linkage section offset of
" the appropriate portion of the compensation table in pr4|start_comp.  It
" then reads the meters into pr4|start.  It does not store real_time because
" this will be done at the very last.
" It clobbers X4 and the registers clobbered by read_vcpu_time_and_page_faults.

	macro	start_metering_interval	<compensation_type>
	eax4	global_parameters+global_parms.comps+from_&1
	stx4	pr4|start_comp		" Remember which compensations to use.

	read_vcpu_time_and_page_faults	start

NOTHING_TO_START&U:
	&end







" This macro calculates the usages during a metering interval and adds them to
" the meters in whatever stack frame &1 points to and to pr4|metered.
" Pr4|start_comp contains an offset into the linkage section for the
" compensation values.  If pr4|start is zero, there is no interval and there
" is nothing to do.  It assumes that pr4|stop contains the stop readings and
" it uses pr4|delta as working storage.  It clobbers AQ and X4.

	macro	metering_interval_calculations	<sp>,<compensation_type>
	lcaq	pr4|start+meters.real_time
	tze	INTERVAL_CALCULATED&U

	ldx4	pr4|start_comp		" How were they started?
	adaq	pr4|stop+meters.real_time	" Calculate elapsed real time.
	tmi	trace_error_halt_$trace_error_halt_
	sbaq	pr4|to_&2.real_time,x4	" Subtract appropriate compensation.
	tpl	*+2			" A negative number would later
	lls	72			" be detected as an inconsistency.
	staq	pr4|delta+meters.real_time

	ldaq	pr4|stop+meters.vcpu_time	" Calculate elapsed vcpu time.
	sbaq	pr4|start+meters.vcpu_time
	cmpaq	pr4|delta+meters.real_time	" Elapsed vcpu time should always be less
	tmoz	*+5			" than or equal to elapsed real time.
	szn	pr4|global_parameters+global_parms.calibrate " Don't apply correction
	tnz	*+3			" when determining compensations.
	ldaq	pr4|delta+meters.real_time	" If it isn't, use real time instead.
	tra	*+2			" Delta real is already compensated.
	sbaq	pr4|to_&2.vcpu_time,x4	" Subtract appropriate compensation.
	staq	pr4|delta+meters.vcpu_time

	ldaq	&1|event+event.frame.real_time
	adaq	pr4|delta+meters.real_time	" Update frame real time.
	staq	&1|event+event.frame.real_time

	ldaq	&1|event+event.frame.vcpu_time
	adaq	pr4|delta+meters.vcpu_time	" Update frame vcpu time.
	staq	&1|event+event.frame.vcpu_time

	lda	pr4|stop+meters.page_faults
	sba	pr4|start+meters.page_faults
	tmi	trace_error_halt_$trace_error_halt_
	asa	&1|event+event.frame.page_faults " Update frame page faults.

INTERVAL_CALCULATED&U:
	lls	72			" Insure that they are not used again.
	staq	pr4|start+meters.real_time
	staq	pr4|start+meters.vcpu_time
	stz	pr4|start+meters.page_faults
	&end

" This macro starts a global metering interval if the recursion count is 1.
" This is because we don't want to multiple-meter procedures used recursively.

	macro	start_global_metering_interval	<sp>

	lda	&1|event+event.saved.level	" Only start global meters
	tpnz	GLOBAL_INTERVAL_STARTED&U	" at recursion level 1.
	tmi	trace_error_halt_$trace_error_halt_

	lda	pr4|metered+meters.page_faults
	sta	&1|global_start.page_faults

	ldaq	pr4|metered+meters.vcpu_time
	staq	&1|global_start.vcpu_time

	ldaq	pr4|metered+meters.real_time	" Store this one last because it shows
	staq	&1|global_start.real_time " that the others are valid.

GLOBAL_INTERVAL_STARTED&U:
	&end

" This macro takes the meters that have been accumulating in a trace_catch_
" frame and adds them to the tab.  It also adds them to trace_catch_$metered,
" which accumulates all metered time and page faults.  This may be done either
" because the frame is being popped or because we need the latest information
" in the tab in order to produce a metering report.

	macro	update_tab_meters	<sp>
	ldaq	pr4|metered+meters.real_time
	adaq	&1|event+event.frame.real_time	" Update metered real time.
	staq	pr4|metered+meters.real_time

	ldaq	pr2|tab.local+meters.real_time
	adaq	&1|event+event.frame.real_time	" Update tab real time.
	staq	pr2|tab.local+meters.real_time

	ldaq	pr4|metered+meters.vcpu_time
	adaq	&1|event+event.frame.vcpu_time	" Update metered vcpu time.
	staq	pr4|metered+meters.vcpu_time

	ldaq	pr2|tab.local+meters.vcpu_time
	adaq	&1|event+event.frame.vcpu_time	" Update tab real time.
	staq	pr2|tab.local+meters.vcpu_time

	lda	&1|event+event.frame.page_faults
	asa	pr4|metered+meters.page_faults " Update metered page faults.
	asa	pr2|tab.local+meters.page_faults " Update tab page faults.

	ldaq	&1|global_start.real_time
	tze	FRAME_METERS_UPDATED&U	" No global metering in this frame.

	ldaq	pr4|metered+meters.real_time	" Update global real time.
	sbaq	&1|global_start.real_time
	tmi	trace_error_halt_$trace_error_halt_
	adaq	pr2|tab.global+meters.real_time
	staq	pr2|tab.global+meters.real_time

	ldaq	pr4|metered+meters.vcpu_time	" Update global vcpu time.
	sbaq	&1|global_start.vcpu_time
	adaq	pr2|tab.global+meters.vcpu_time
	staq	pr2|tab.global+meters.vcpu_time

	lda	pr4|metered+meters.page_faults " Update global page faults.
	sba	&1|global_start.page_faults
	tmi	trace_error_halt_$trace_error_halt_
	asa	pr2|tab.global+meters.page_faults

FRAME_METERS_UPDATED&U:
	lls	72			" Insure that they are not used again.
	staq	&1|event+event.frame.real_time
	staq	&1|event+event.frame.vcpu_time
	stz	&1|event+event.frame.page_faults
	staq	&1|global_start.real_time
	staq	&1|global_start.vcpu_time
	stz	&1|global_start.page_faults
	&end

" FILL EVENT FOR PRINT OR STOP MACRO

	macro	fill_event_for_trace_or_signal
	lda	EVENT_VERSION_3
	sta	event+event.version
	lxl0	trace_frames_saved+trace_frames.count
	sxl0	event+event.frame_count

	epp0	ptr_registers_saved+2*0,*	" This is where PR0 was saved.
	sprp0	event+event.arg_list_ptr
	epp0	pr6|0
	epp0	pr0|stack_frame.prev_sp,*	" Pointer to caller's stack frame.
	lda	pr0|stack_frame.flag_word
	ana	stack_frame.support_bit,dl
	tnz	*-3			" Skip support frames.
	sprp0	event+event.callers_sp
	epp0	pr0|stack_frame.return_ptr,*	" Pointer to caller's return point.
	sprp0	event+event.return_ptr
	&end	" fill_event_for_trace_or_signal



" CALL STOP ROUTINE MACRO

	macro	call_stop_routine <sp>,<ca/re>

" call global_parameters.stop_routine (event, watch_values_changed);
" dcl  global_parameters.stop_routine entry (1 like event aligned, bit aligned);

	ldx0	=2a&2,du
	stx0	&1|event+event.kind

	ldaq	two_arg_list_header
	staq	arg_list.header
	ldaq	pr4|global_parameters+global_parms.stop_routine+2 " Environment ptr.
	staq	arg_list.third_arg_ptr
	eraq	null_ptr
	anaq	ptr_mask
	tze	*+3
	ldaq	two_arg_list_header_w_env
	staq	arg_list.header
	epp0	&1|event
	spri0	arg_list.first_arg_ptr
	epp0	&1|watch_values_changed
	spri0	arg_list.second_arg_ptr

	call	pr4|global_parameters+global_parms.stop_routine,*(arg_list.header)
	&end

" CALL PRINT ROUTINE MACRO

	macro	call_trace_routine_or_buffer <sp>,<ca/re/un/si>

" call global_parameters.print_routine (event);
" dcl  global_parameters.print_routine entry (1 like event aligned);

	ldx0	=2a&2,du
	stx0	&1|event+event.kind

	lda	pr4|global_parameters+global_parms.buffer_ptr
	cmpa	packed_null
	tze	CALL_TRACE_PRINT&U
	lprp1	pr4|global_parameters+global_parms.buffer_ptr
	ldaq	pr1|buffer.h.version
	cmpaq	BUFFER_VERSION_3
	tnz	trace_error_halt_$trace_error_halt_
	lda	pr1|buffer.h.count
	aos	pr1|buffer.h.count
	ana	=o017777,dl		" mod 8192
	als	4			" 16 words per event.
	epp1	pr1|buffer.e,al		" pr1 -> buffer entry
	mlr	(pr),(pr)
	desc9a	&1|event,(event_size-2)*4
	desc9a	pr1|0,(event_size-2)*4
	ldaq	pr4|stop+meters.real_time
	staq	pr1|event_size-2		" Put clock reading in last two words.
	ife	&2,si
	mlr	(),(pr)			" Initialize so we can punt fast.
	desc9a	UNUSUAL_SIGNAL_ARG_LIST,24	" "Unusual signal_ arg list"
	desc9a	pr1|event.saved,24		" 24 is from event.saved to the clock.
	epp0	&1|ptr_registers_saved+2*0,*	" PR0 -> argument list header.
	lxl0	pr0|0			" If arg_list.header.call_type
	cmpx0	4,du			" ^= Interseg_call_type
	tnz	SKIP_TRACE_PRINT&U	" then punt.
	ldx0	pr0|1			" If arg_list.header.desc_count
	cmpx0	2,du			" < 1
	tmi	SKIP_TRACE_PRINT&U	" then punt.
	ldx0	pr0|0			" If arg_list.header.arg_count
	cmpx0	2,du			" < 1
	tmi	SKIP_TRACE_PRINT&U	" then punt.
	lda	pr0|2,x0*			" A = descriptor
	als	1			" Bit bucket = arg_descriptor.flag
	lrl	25
	arl	5			" A = arg_descriptor.type
	cmpa	21,dl			" If arg_descriptor.type ^= char_dtype
	tnz	SKIP_TRACE_PRINT&U	" then punt.
	qrl	12			" Q = arg_descriptor.size
	epp0	pr0|2,*			" PR0 -> signal name.
	mlr	(pr,rl),(pr),fill(040)
	desc9a	pr0|0,ql
	desc9a	pr1|event.saved,24		" 24 is from event.saved to the clock.
	ifend
	tra	SKIP_TRACE_PRINT&U

CALL_TRACE_PRINT&U:
	ldaq	one_arg_list_header		" call trace_print_$trace (event);
	staq	arg_list.header
	ldaq	pr4|global_parameters+global_parms.trace_routine+2 " Environment ptr.
	staq	arg_list.second_arg_ptr
	eraq	null_ptr
	anaq	ptr_mask
	tze	*+3
	ldaq	one_arg_list_header_w_env
	staq	arg_list.header
	epp0	&1|event
	spri0	arg_list.first_arg_ptr

	call	pr4|global_parameters+global_parms.trace_routine,*(arg_list.header)
SKIP_TRACE_PRINT&U:
	&end

" CHECK OR UPDATE WATCH TABLE MACRO

" This macro either checks or updates the watch table, depending on its second
" argument.  It clobbers PR0, PR1, AQ, and X0.

	macro	check_or_update_watch_table	<sp>,<check/update>
	ife	&2,check
	stz	&1|watch_values_changed
	ifend
	ife	&2,update
	szn	&1|watch_values_changed
	tze	WATCH_TABLE_DONE&U
	ifend

	epp1	pr4|wt_ptr,*		" Pr1 points to the table header.
	ldaq	pr1|table.version
	cmpaq	TT_VERSION_3
	tnz	trace_error_halt_$trace_error_halt_

	lxl0	pr1|table.count
WATCH_TABLE_LOOP&U:
	eax0	-1,x0
	tmi	WATCH_TABLE_DONE&U
	eaa	0,x0
	ars	18
	cmpa	pr1|table.idx+idx.low	" if idx - idx.low < 0
	tmi	*+3			" then actual_idx = idx;
	sba	pr1|table.idx+idx.low	" else actual_idx = idx - idx.low
	ada	pr1|table.idx+idx.high	" + idx.high;
	als	1
	lprp0	pr1|table.e+te.key,al
	ldq	pr0|0
	cmpq	pr1|table.e+te.data,al
	tze	WATCH_TABLE_LOOP&U
	ife	&2,check
	eaa	TRUE
	sta	&1|watch_values_changed
	ifend
	ife	&2,update
	stq	pr1|table.e+te.data,al
	tra	WATCH_TABLE_LOOP&U
	ifend
WATCH_TABLE_DONE&U:
	&end

" TRACE IF NECESSARY MACRO

	macro	trace_and_stop_if_necessary	<sp>,<ca/re/un>

	szn	pr4|global_parameters+global_parms.meter
	tnz	DONT_CALL_ANYTHING&U

	lda	pr2|tab.parms_ptr
	cmpa	packed_null		" If this entrypoint has been removed,
	tze	DONT_CALL_ANYTHING&U	" then don't trace it.

	szn	pr2|tab.on		" If this entrypoint is -off,
	tze	DONT_CALL_ANYTHING&U	" then don't trace it.

	szn	pr4|global_parameters+global_parms.alm
	tnz	*+4
	lda	pr2|tab.translator_id
	cmpa	1,dl			" If tab.translator_id = ALM
	tze	DONT_CALL_ANYTHING&U	" then don't trace.

	inhibit	off		" <-> <-> <-> <-> <-> <-> <-> <-> <->
	lprp3	pr2|tab.parms_ptr		" pr3 = tab.parms_ptr;
	ldaq	pr3|parms.version
	cmpaq	PARAMETERS_VERSION_3
	tnz	trace_error_halt_$trace_error_halt_

	lda	pr3|parms.trace		" Check inout.
&^=&2,ca&[	als	1
&]	tpl	CHECK_WATCH_TABLE&U

	ldaq	&1|event+event.saved.calls
	adl	1,dl			" Get current count.
	staq	arg_list.header		" Save in strange temporary.

	szn	pr3|parms.every		" Is this parameter active?
	tze	CHECK_FIRST&U

	lrs	34			" If mod (call_count, tab.every) ^= 0
	dvf	pr3|parms.every		" then don't trace.
	lls	36
	ldq	arg_list.header+1		" Actually counts.calls+1.
	qls	1
	dvf	pr3|parms.every		" Q = mod (saved calls, tab.every);
	qrs	0			" Set indicators from register Q.
	tnz	CHECK_WATCH_TABLE&U

CHECK_FIRST&U:
	lcaq	arg_list.header		" Actually counts.calls.
	adl	pr3|parms.first		" If tab.first - saved calls > 0
	tpnz	CHECK_WATCH_TABLE&U	" then don't trace.

	szn	pr3|parms.last
	tze	*+4			" -last 0 means it is diasbled.
	lcaq	arg_list.header		" Actually counts.calls.
	adl	pr3|parms.last		" If parms.last - saved calls < 0
	tmi	CHECK_WATCH_TABLE&U	" then don't trace.

	lda	&1|event+event.saved.level
	ada	1,dl			" Get current level.
	cmpa	pr3|parms.low		" If level - parms.low < 0
	tmi	CHECK_WATCH_TABLE&U	" then don't trace.

	szn	pr3|parms.high
	tze	*+3			" -high 0 means it is diasbled.
	cmpa	pr3|parms.high		" If level - parms.high > 0
	tpnz	CHECK_WATCH_TABLE&U	" then don't trace.

	szn	pr3|parms.new_high		" If -new_high is off
	tze	*+3			" then skip this check.
	cmpa	&1|event+event.saved.max_level
	tmoz	CHECK_WATCH_TABLE&U	" then don't trace.

	call_trace_routine_or_buffer &1,&2
	
CHECK_WATCH_TABLE&U:
	ine	&2,un

	check_or_update_watch_table	&1,check

	szn	&1|watch_values_changed
	tnz	STOP_IT&U

	lda	pr3|parms.stop
&^=&2,ca&[	als	1
&]	tpl	DONT_CALL_ANYTHING&U

	ldaq	&1|event+event.saved.calls
	adl	1,dl			" Get real counts.calls.
	staq	arg_list.header		" Use this as a temporary.

	szn	pr3|parms.stop_every	" Is this parameter active?
	tze	CHECK_STOP_LOW&U

	lrs	34			" If mod (call_count, tab.every) ^= 0
	dvf	pr3|parms.stop_every	" then don't stop.
	lls	36
	ldq	arg_list.header+1		" Actually counts.calls+1.
	qls	1
	dvf	pr3|parms.stop_every	" Q = mod (saved calls, tab.every);
	qrs	0			" Set indicators from register Q.
	tnz	DONT_CALL_ANYTHING&U

CHECK_STOP_LOW&U:
	lda	&1|event+event.saved.level
	ada	1,dl			" Get current level.
	cmpa	pr3|parms.stop_low		" If level - parms.stop_low < 0
	tmi	DONT_CALL_ANYTHING&U	" then don't stop.

STOP_IT&U:

	call_stop_routine &1,&2

	check_or_update_watch_table	&1,update

	ifend
	inhibit	on		" <+> <+> <+> <+> <+> <+> <+> <+> <+>
DONT_CALL_ANYTHING&U:
	&end

	macro	is_tracing_permitted	<THE_ANSWER_IS_NO_LABEL>
" Is tracing this entry point permitted?

	lda	pr2|tab.translator_id	" If tab.translator_id < 0,
	tmi	&1		" then this program can't be traced.
	szn	pr4|global_parameters+global_parms.alm
	tnz	*+3
	cmpa	1,dl			" If tab.translator_id = ALM
	tze	&1		" then don't trace.

	szn	pr2|tab.on		" If this entrypoint is -off,
	tze	&1		" then don't trace it.
	&end





	macro	pop_tab	<sp>
	lda	&1|event+event.saved.level	" Revert tab.cts.level,
	tmi	trace_error_halt_$trace_error_halt_
	sta	pr2|tab.cts+counts.level
	&end;

"	  A FEW WORDS ABOUT THE STRUCTURE OF THE TRACE TABLES

" The trace facility maintains four tables in the same format:

"      tt:  The trace table itself, which has a maximum of 10,000 entries.
"      stt: The table of entrypoints specified by the trace command.
"      wt:  The table locations being watched, with a maximum of 1024 entries.
"      swt: The table of locations specified by the watch_locations command.

" Each table has an 8 word header that contains a version, the maximum number
" of entries (max_count), and the current number of entries (count).  The
" table entries are two words each and are sorted into ascending order based
" on the numeric value of the first word, which is known as the key.  The
" second word is known as the data.

" In order to facilitate updating, the entries in a table are divided into two
" halves.  One half is at the low end of the table and the other half is at
" the high end.  When an entry is to be added to a table, entries are shifted
" from one half to the other until the new entry can be added by appending it
" to the high end of the low half.

" The index of a table entry must be translated into the index of an element
" in the table array.  Both the array indexes and the table indexes are zero
" relative.  The first element of the table array is 0 and the index of the
" last element is max_count - 1.  If an entry is in the low half, the array
" index is the same as the entry index.

" There is a double word in the table header that describes the halvs.  The
" first word is called idx.low and the second word is called idx.high.
" Idx.high is the array index of the first element in the high half.  If it is
" equal to max_count, there are no entries in the high half.  Idx.low is the
" number of entries in the low half.  An entry is in the high half if its
" entry index is >= idx.low.  If an entry is in the high half, its array index
" is its entry index - idx.low + idx.high.

" There are three macros for manipulating these tables.

"      seek_table		which finds an entry, given its key.
"      index_table		which finds an entry, given its entry index.
"      normalize_table	which moves entries until idx.low = entry index.

" SEEK TABLE MACRO
" This macro searches the trace or locations table for an entry or location.
" It is called with:
" 	PR1 -> table header,
" 	Q containing the key being searched for.
" If the entry is found, it returns to the FOUND label with:
" 	PR2 -> the matching entry
" 	X2 containing the entry index
"	A, X1, and table.working_storage clobbered.
" If the entry is not found, it returns to the NOT_FOUND label with:
" 	X2 containing the entry index it would have if it were added.
"	PR2, A, X1, and table.working_storage clobbered.
" If the table is empty, it goes to the NOT_FOUND label with:
" 	X2 = 0.
"	PR2, A, X1, and table.working_storage clobbered.

	macro	seek_table	" Syntax: seek_table FOUND,NOT_FOUND
	lda	pr1|table.idx+idx.high
	als	1
	epp2	pr1|table.e,al	" Pr2 points to high half.
	lda	pr1|table.max_count
	sba	pr1|table.idx+idx.high " If table.max_count - idx.high = 0,
	tze	SEEK_LOW&U	" then the high half is empty.
	tmi	trace_error_halt_$trace_error_halt_
	cmpq	pr2|te.key	" If Q - table.e (idx.high) < 0
	tmi	SEEK_LOW&U
	tpnz	BINARY_LOOP&U
	lxl2	pr1|table.idx+idx.low " Good luck.  We found it.
	tra	&1

SEEK_LOW&U:
	epp2	pr1|table.e	" Pr2 points to low half.
	lda	pr1|table.idx+idx.low	" A = number of entries in low half.
	tpnz	BINARY_LOOP&U	" If A > 0, then do a binary search.
	tmi	trace_error_halt_$trace_error_halt_
	eax2	0		" else it's not in the table.
	tra	&2

" The binary search uses pr2 to point to the group of remaining candidates.
" It uses the A register to contain the number of remaining candidates.
" During the search uses X2 to represent the offset to the middle of the candidates.

BINARY_LOOP&U:		" X2 contains offset that divides portion in half,
	eax2	-1,al		" with the upper division being the larger one.
	tmi	BINARY_NOT_FOUND&U " Quit, if the portion is zero length.

	anx2	=o777776,du	" Truncate offset in x2 to a double word boundary.
	ars	1		" Calculate size of the portion for the next pass.

	cmpq	pr2|te.key,x2	" If value we are looking for is LESS than value we
	tmi	BINARY_LOOP&U	" are looking at, then look again in LOWER division.

	epp2	pr2|te_size,x2	" If value we are looking for is MORE than value we
	tpnz	BINARY_LOOP&U	" are looking at, then look again in UPPER division.

	epp2	pr2|-te_size	" Success!  The binary search always
	eax1	&1	" succeeds with PR2 -> to the next entry.
	tra	FIGURE_INDEX&U

BINARY_NOT_FOUND&U:		" The binary search always fails with
	eax1	&2	" PR2 -> entry where it should have been.

FIGURE_INDEX&U:
	eaa	pr1|table.e	" Calculate the winning index.
	arl	19
	sta	pr1|table.working_storage
	eaa	pr2|0
	arl	19
	sba	pr1|table.working_storage
	eax2	0,al
	cmpa	pr1|table.idx+idx.low	" If index - idx.low <= 0,
	tmoz	0,x1	" then it is in the low half and we are done.
	sba	pr1|table.idx+idx.high
	tmi	trace_error_halt_$trace_error_halt_
	ada	pr1|table.idx+idx.low
	eax2	0,al		" index = index - idx.high + idx.low;
	tra	0,x1
	&end

" INDEX TABLE MACRO
" This macro assumes that:
"	PR1 -> table,
"	X2 = table index.
" It finishes with:
"	PR2 -> the table entry specified by the index in X2,
"	A clobbered.

	macro	index_table
	eaa	0,x2
	ars	18
	tmi	trace_error_halt_$table_index_oob
	cmpa	pr1|table.idx+idx.low	" If table_index - idx.low > 0,
	tpl	INDEX_HIGH&U	" then get it from the high half.
	als	1
	epp2	pr1|table.e,al
	tra	INDEX_DONE&U
INDEX_HIGH&U:
	sba	pr1|table.idx+idx.low
	ada	pr1|table.idx+idx.high	" Q = array_index - idx.low + idx.high;
	cmpa	pr1|table.max_count
	tpl	trace_error_halt_$table_index_oob
	als	1
	epp2	pr1|table.e,al
INDEX_DONE&U:
	&end

" NORMALIZE TABLE MACRO
" This macro assumes that:
"	PR1 -> table
"	X2 contains an entry index.
" It moves table entries until idx.low = X2, using the mlr or mrl instruction.
" When it returns:
"	idx.low = X2.
"	PR2, PR3, AQ, and table.working_storage clobbered.

	macro	normalize_table
	ldaq	pr1|table.idx
	staq	pr1|table.working_storage
	eaa	0,x2
	ars	18
	sba	pr1|table.idx+idx.low	"A = table_index - idx.low;
	tze	TABLE_NORMALIZED&U " The table is already normalized.
	asa	pr1|table.working_storage+idx.low  " Working_storage is an image of
	asa	pr1|table.working_storage+idx.high " what table.idx will be.
	ldq	pr1|table.max_count
	sbq	pr1|table.count	" If table.max_count - table.count = 0,
	tze	TABLE_NORMALIZED&U " then table is full, so just change idx.
	tmi	trace_error_halt_$trace_error_halt_
	ars	0		" Set the indicator registers from A.
	tpnz	MOVE_HIGH_TO_LOW&U " If A > 0, move data down.

MOVE_LOW_TO_HIGH&U:		" If A < 0, move data up.
	ldaq	pr1|table.working_storage
	lls	1
	epp2	pr1|table.e,al	" Pr2 -> table.e (idx.low).
	epp3	pr1|table.e,ql	" Pr3 -> table.e (idx.high).
	lda	pr1|table.idx+idx.low
	sba	pr1|table.working_storage+idx.low
	als	3		" There are eight bytes per entry.
	mrl	(pr,rl),(pr,rl)
	desc9a	pr2|0,al
	desc9a	pr3|0,al
	tra	TABLE_NORMALIZED&U

MOVE_HIGH_TO_LOW&U:
	ldaq	pr1|table.idx
	lls	1
	epp2	pr1|table.e,al	" Pr2 -> table.e (idx.low).
	epp3	pr1|table.e,ql	" Pr3 -> table.e (idx.high).
	lda	pr1|table.working_storage+idx.low
	sba	pr1|table.idx+idx.low
	als	3		" There are eight bytes per entry.
	mlr	(pr,rl),(pr,rl)
	desc9a	pr3|0,al
	desc9a	pr2|0,al

TABLE_NORMALIZED&U:
	ldaq	pr1|table.working_storage
	staq	pr1|table.idx
	&end

" TABLE SEEK
" dcl trace_catch_$table_seek entry (ptr, bit (36) aligned) returns (fixed bin);
" table_index = trace_catch_$table_seek (table_ptr, key);

	segdef	table_seek
table_seek:
	get_pr4
	epp1	pr0|2,*
	epp1	pr1|0,*		" Pr1 points to the table header.
	ldaq	pr1|table.version
	cmpaq	TT_VERSION_3
	tnz	trace_error_halt_$trace_error_halt_

	ldq	pr0|4,*		" Q reg contains the key we seek.

	seek_table	TABLE_SEEK_FOUND,TABLE_SEEK_NOT_FOUND

TABLE_SEEK_FOUND:
	eaa	0,x2
	ars	18
	sta	pr0|6,*
	short_return		" return (table_index);

TABLE_SEEK_NOT_FOUND:
	lca	1,dl
	sta	pr0|6,*
	short_return		" return (-1)

" TABLE GET
" dcl trace_catch_$table_get entry (ptr, fixed bin) returns (1 like table_entry aligned);
" table_entry = trace_catch_$table_get (table_ptr, table_index);

	
	segdef	table_get
table_get:
	get_pr4
	epp1	pr0|2,*
	epp1	pr1|0,*		" Pr1 points to the table header.
	ldaq	pr1|table.version
	cmpaq	TT_VERSION_3
	tnz	trace_error_halt_$trace_error_halt_

	lxl2	pr0|4,*		" X2 contains the index.

	index_table

	ldaq	pr2|te
	epp3	pr0|6,*
	sta	pr3|te.key
	stq	pr3|te.data
	short_return		" return (AQ);

" TABLE PUT DATA
" dcl trace_catch_$table_put_data entry (ptr, fixed bin, bit (36) aligned);
" call trace_catch_$table_put_data (table_ptr, table_index, data);

	
	segdef	table_put_data
table_put_data:
	get_pr4
	epp1	pr0|2,*
	epp1	pr1|0,*		" Pr1 points to the table header.
	ldaq	pr1|table.version
	cmpaq	TT_VERSION_3
	tnz	trace_error_halt_$trace_error_halt_

	lxl2	pr0|4,*		" X2 contains the index.

	index_table

	ldq	pr0|6,*
	stq	pr2|te.data
	short_return

" TABLE ADD
" dcl trace_catch_$table_add entry (ptr, 1 like table_entry aligned) returns (fixed bin);
" table_index = trace_catch_$table_add (table_ptr, table_entry);

	segdef	table_add
table_add:
	get_pr4
	epp1	pr0|2,*
	epp1	pr1|0,*		" Pr1 points to the table header.
	ldaq	pr1|table.version
	cmpaq	TT_VERSION_3
	tnz	trace_error_halt_$trace_error_halt_

	ldq	pr0|4,*		" Q reg contains the key we seek.

	seek_table	ADD_ENTRY_FOUND_IN_TABLE,TRY_LOW_HALF_APPEND

ADD_ENTRY_FOUND_IN_TABLE:
	lca	1,dl
	sta	pr0|6,*
	short_return		" return (-1);

TRY_LOW_HALF_APPEND:
	eaa	0,x2
	ars	18
	cmpa	pr1|table.idx+idx.low " If index_we_want ^= idx.low
	tnz	NORMALIZE_FOR_ADD
	cmpa	pr1|table.idx+idx.high " If idx.low - idx.high >= 0,
	tpl	trace_error_halt_$table_full " then the table is already full.
	als	1
	epp2	pr1|table.e,al	" PR2 -> where new entry will go.
	epp3	pr0|4,*
	lda	pr3|te.key	" Arg is not necessarily double word aligned.
	ldq	pr3|te.data
	staq	pr2|te		" table.e (idx.low) = table_entry;
	lda	pr1|table.idx+idx.low
	sta	pr0|6,*		" return (idx.low);
	inhibit	on		" <+> <+> <+> <+> <+> <+> <+> <+> <+>
	aos	pr1|table.idx+idx.low " idx.low = idx.low + 1;
	aos	pr1|table.count	" table.count = table.count + 1;
	inhibit	off		" <-> <-> <-> <-> <-> <-> <-> <-> <->
	short_return

NORMALIZE_FOR_ADD:
	normalize_table

	tra	TRY_LOW_HALF_APPEND	" This will work now.

" TABLE REMOVE
" dcl trace_catch_$table_remove entry (ptr, fixed bin) returns (1 like te aligned);
" te = trace_catch_$table_remove (table_ptr, table_index);

	segdef	table_remove
table_remove:
	get_pr4
	epp1	pr0|2,*
	epp1	pr1|0,*		" Pr1 points to the table header.
	ldaq	pr1|table.version
	cmpaq	TT_VERSION_3
	tnz	trace_error_halt_$trace_error_halt_

	lxl2	pr0|4,*		" X2 contains the index.

	index_table

	ldaq	pr2|te		" Store the return value.
	epp3	pr0|6,*
	sta	pr3|te.key	" Return arg is not necessarily
	stq	pr3|te.data	" double word aligned.

	normalize_table

	inhibit	on		" <+> <+> <+> <+> <+> <+> <+> <+> <+>
	aos	pr1|table.idx+idx.high " idx.high = idx.high + 1;
	lca	1,dl
	asa	pr1|table.count	" table.count = table.count - 1;
	inhibit	off		" <-> <-> <-> <-> <-> <-> <-> <-> <->
	short_return

" The entry operators do a tsp2 to trace$catch_pl1_, so
"
"	PR2 -> place to resume the entry operator.
"
" The entry operator uses the first two words after the end of the stack for
" temporary storage.  These two words must be restored before resuming the
" operator.  The following pl1 declaration shows what is stored there.
"
"	dcl  1 saved aligned based (stack_header.stack_end_ptr),
"	       2 entry_ptr ptr unal,	/* packed ptr to entry being traced */
"	       2 pr1 ptr unal,	/* not needed, but must be restored */


" Trace_catcher_ is a stub entry point for the benefit of debuggers.

	entry	trace_catcher_
trace_catcher_:
	short_return


	segdef	catch_pl1_
catch_pl1_:

	inhibit	on		<+> <+> <+> <+> <+> <+> <+> <+> <+> <+>

	get_pr4

" Read the calendar clock as soon as possible.

	read_the_calendar_clock	stop

" If tracing is inhibited, just resume the entry operator.

	szn	pr7|stack_header.in_trace
	tnz	pr2|0

" Getlp.  This cutrate getlp uses PR4 and PR5 as temporaries since the
" remainder of the entry operator will change them anyway.

	epp5	pr7|stack_header.stack_end_ptr,* " PR5 -> stack frame construction site.
	epp4	trace_catch_$trace_catcher_	" Let debuggers see a real entry point.
	spri4	pr5|stack_frame.entry_ptr

" Push.

	spri6	pr5|stack_frame.prev_sp
	epp4	null_ptr,*
	spri4	pr5|stack_frame.arg_ptr
	get_pr4
	spri4	pr5|stack_frame.lp_ptr
	epp6	pr5|0
	epp5	pr6|stack_frame_size
	spri5	pr7|stack_header.stack_end_ptr
	spri5	pr6|stack_frame.next_sp

" Save the cpu registers, and the two words where end of stack used to be, in a safe place.

	ldaq	pr6|0

	spri	ptr_registers_saved
	sreg	registers_saved
	sti	indicators_saved

" Read the meters.  I wish it could have been done sooner.

	read_vcpu_time_and_page_faults	stop

" To whom it may concern: trace_catch_ is an alm program.

	eax7	1
	stx7	pr6|stack_frame.translator_id

" Establish a cleanup handler to undo changes to static data.

	epp0	=7acleanup		" Initialize the on unit data block.
	spri0	cleanup_unit+on_unit.name
	epp0	PRELIMINARY_CLEANUP_HANDLER	" It just resets stack_header.in_trace.
	spri0	cleanup_unit+on_unit.body
	ldq	7,dl
	stq	cleanup_unit+on_unit.size
	stz	cleanup_unit+on_unit.next

	equ	cleanup_unit_offset,cleanup_unit
	eaa	cleanup_unit_offset		" Put it at the head of the list.
	sta	pr6|stack_frame.on_unit_rel_ptrs

	lda	stack_frame.condition_bit+stack_frame.support_bit,dl
	orsa	pr6|stack_frame.flag_word	" List is valid & this is a support frame.

" Prevent recursion in case of calls or errors.

	eaa	TRUE
	sta	pr7|stack_header.in_trace

" Calculate the meters and store them in the previously top trace_catch_ frame,
" if there is one.

	ldaq	pr7|stack_header.trace_frames
	staq	trace_frames_saved
	tze	SEEK_TAB_FOR_CALL
	lprp5	trace_frames_saved+trace_frames.top_ptr
	sba	1,dl			" Make sure things are copacetic.
	cmpa	pr5|trace_frames_saved+trace_frames.count
	tnz	trace_error_halt_$trace_error_halt_

	metering_interval_calculations	pr5,entry

SEEK_TAB_FOR_CALL:

" Copy the packed pointer to the entry being traced from where the end of stack used to be.

	lda	registers_saved+4	" This is where the sreg instruction puts A.
	sta	event+event.entry_ptr

" Get the tab for this entrypoint, if it is in the trace table.

	epp1	pr4|tt_ptr,*
	ldaq	pr1|table.version
	cmpaq	TT_VERSION_3
	tnz	trace_error_halt_$trace_error_halt_

	ldq	event+event.entry_ptr		" Q reg contains the value we are looking for.

	seek_table	EP_IS_IN_TT_AT_CALL,ADD_ENTRYPOINT

EP_IS_IN_TT_AT_CALL:
	eaa	0,x2
	ars	18
	sta	event+event.entry_idx
	lprp2	pr2|te.data
	tra	HAVE_TAB

ADD_ENTRYPOINT:
	lca	1,dl
	sta	event+event.entry_idx
	epp2	null_ptr,*		" Catch bugs early.


" If the entry point is signal_$signal_ or signal_$io_signal, then trace as signal.

	ldq	event+event.entry_ptr
	cmpq	pr4|SIGNAL_
	tze	THIS_IS_A_SIGNAL

	cmpq	pr4|IO_SIGNAL
	tze	THIS_IS_A_SIGNAL

" If -auto on, then add this entry point to the trace table.

	szn	pr4|global_parameters+global_parms.automatic
	tze	POP_TRACE_FRAME_AND_RESUME

" If the entry point is trace_transactions_$transaction_begin, then skip it.

	cmpq	pr4|TRANSACTION_BEGIN
	tze	POP_TRACE_FRAME_AND_RESUME

	cmpq	pr4|TRANSACTION_BEGIN_FORCE
	tze	POP_TRACE_FRAME_AND_RESUME

" call trace_entrypoints_$add_entrypoint (event+event.entry_ptr, pr2);

	ldaq	two_arg_list_header
	staq	arg_list.header
	epp0	event+event.entry_ptr
	spri0	arg_list.first_arg_ptr
	epp0	event+event.entry_idx
	spri0	arg_list.second_arg_ptr

	call	trace_entrypoints_$add_entrypoint(arg_list.header)

	lxl2	event+event.entry_idx
	tmi	POP_TRACE_FRAME_AND_RESUME

	epp1	pr4|tt_ptr,*
	ldaq	pr1|table.version
	cmpaq	TT_VERSION_3
	tnz	trace_error_halt_$trace_error_halt_

	index_table

	lprp2	pr2|te.data
	tra	HAVE_TAB

THIS_IS_A_SIGNAL:

	szn	pr4|global_parameters+global_parms.meter
	tnz	POP_TRACE_FRAME_AND_RESUME

	szn	pr4|global_parameters+global_parms.signals
	tze	POP_TRACE_FRAME_AND_RESUME		" Never trace signal_ as a procedure.


TRACE_THIS_SIGNAL:
	fill_event_for_trace_or_signal

	call_trace_routine_or_buffer pr6,si

	tra	POP_TRACE_FRAME_AND_RESUME		" Never trace signal_ as a procedure.

HAVE_TAB:
	ldaq	pr2|tab.version
	cmpaq	TAB_VERSION_3
	tnz	trace_error_halt_$trace_error_halt_

" Save the old counts before we start modifying them.

	ldaq	pr2|tab.cts
	staq	event+event.saved
	ldaq	pr2|tab.cts+2
	staq	event+event.saved+2

" Count this entry whether we trace it or not.

	ldaq	pr2|tab.cts+counts.calls
	adl	1,dl
	staq	pr2|tab.cts+counts.calls

" See if this entrypoint is traceable.

	is_tracing_permitted	POP_TRACE_FRAME_AND_RESUME

" Calculate the recursion level and maximum recursion level.

	lda	pr2|tab.cts+counts.level
	ada	1,dl
	sta	pr2|tab.cts+counts.level
	cmpa	pr2|tab.cts+counts.max_level
	tmoz	*+2			" if tab.cts.level - tab.cts.max_level > 0
	sta	pr2|tab.cts+counts.max_level	" then tab.cts.max_level = tab.cts.level;

" Initialize some values used by the cleanup handler.

	lls	72			" Initialize the meters.
	staq	event+event.frame.real_time
	staq	event+event.frame.vcpu_time
	stz	event+event.frame.page_faults
	staq	global_start.real_time
	staq	global_start.vcpu_time
	stz	global_start.page_faults

" Turn on the full cleanup handler now.

	epp0	TRACE_CATCH_CLEANUP
	spri0	cleanup_unit+on_unit.body

" Push this frame onto the stack of trace_catch_ frames.

	aos	pr7|stack_header.trace_frames+trace_frames.count
	sprp6	pr7|stack_header.trace_frames+trace_frames.top_ptr

" If we are not just metering, call the procedure that prints the tracing message.

	fill_event_for_trace_or_signal

	trace_and_stop_if_necessary	pr6,ca

" Start the global meters for this procedure if this is the first level of recursion.

	start_global_metering_interval	pr6

" Start the metering interval.

	start_metering_interval	entry

" Establish the return point, like the call operator would.

	epp2	PROCEDURE_RETURN_POINT
	spri2	pr6|stack_frame.return_ptr
	sti	pr6|stack_frame.return_ptr+1

" Restore registers.  Ptr_registers_saved pr4 and pr6 contain trace_catch_'s lp and sp.

	lpri	ptr_registers_saved
	lreg	registers_saved
	ldi	indicators_saved
	tra	RESUME_ENTRY_OPERATOR

" Control comes here when the entry point cannot be traced.

POP_TRACE_FRAME_AND_RESUME:
	start_metering_interval	entry

" Restore registers.  Ptr_registers_saved pr4 and pr6 contain trace_catch_'s lp and sp.

	lpri	ptr_registers_saved
	lreg	registers_saved
	ldi	indicators_saved

" Pop our stack frame.

	spri6	pr7|stack_header.stack_end_ptr
	epp6	pr6|stack_frame.prev_sp,*

RESUME_ENTRY_OPERATOR:

" Restore two words at stack end that were saved with the registers for the entry operator.

	staq	pr7|stack_header.stack_end_ptr,*

" Permit tracing again.

	stz	pr7|stack_header.in_trace

" We have postponed reading the clock until now for accurate metering.

	read_the_calendar_clock	start

" Resume the entry operator.

	tra	pr2|0

" Control comes to this label when the procedure being traced does a return.

PROCEDURE_RETURN_POINT:

" First priority is reading the clock for accurate metering.

	epp4	pr6|stack_frame.lp_ptr,*
	read_the_calendar_clock	stop

" Save the cpu registers.

	spri	ptr_registers_saved
	sreg	registers_saved

" Read the meters.

	read_vcpu_time_and_page_faults	stop

" Prevent recursion in case of calls or errors.  The A register is never zero at this point.

	eaa	TRUE
	sta	pr7|stack_header.in_trace

" Make sure we are where we think we are.

	sprp6	arg_list.header
	lda	pr7|stack_header.trace_frames+trace_frames.top_ptr
	cmpa	arg_list.header
	tnz	trace_error_halt_$trace_error_halt_

" Calculate the elapsed meters and store them in this frame.

	metering_interval_calculations	pr6,return

" Get the tab_ptr, if this entrypoint is still in the trace table.

	epp1	pr4|tt_ptr,*
	ldaq	pr1|table.version
	cmpaq	TT_VERSION_3
	tnz	trace_error_halt_$trace_error_halt_

	ldq	event+event.entry_ptr		" Q reg contains the value we are looking for.

	seek_table	EP_IS_IN_TT_AT_RETURN,POP_TRACE_FRAME_AND_RETURN

EP_IS_IN_TT_AT_RETURN:
	eaa	0,x2
	ars	18
	sta	event+event.entry_idx
	lprp2	pr2|te.data
	ldaq	pr2|tab.version
	cmpaq	TAB_VERSION_3
	tnz	trace_error_halt_$trace_error_halt_

" If tracing is disabled, the operator pointers have been yanked.  Pretend we arn't here.

	szn	pr4|global_parameters+global_parms.enabled
	tze	POP_TAB_AND_RETURN

" See if this entrypoint can still be traced.  The user could have turned it off while stopped.

	is_tracing_permitted	POP_TAB_AND_RETURN

" If we are not just metering, call the procedure that prints the tracing message.

	trace_and_stop_if_necessary	pr6,re

" Update the meters in the tab since this frame is about to be popped.

	update_tab_meters	pr6

POP_TAB_AND_RETURN:
	pop_tab		pr6

" Pop this trace_catch_ frame from the top of the stack of such frames.

POP_TRACE_FRAME_AND_RETURN:
	ldaq	trace_frames_saved
	staq	pr7|stack_header.trace_frames

" Start a metering interval, regardless of whether there is anything to meter.

	start_metering_interval	return

" If the end of the frame is not where it should be, because it has been
" extended to hold the value of a returns (*) function, merge it with the
" previous frame.

	eax0	pr6|stack_frame_size
	cmpx0	pr6|stack_frame.next_sp+1
	tnz	MERGE_FRAMES


" Restore registers.  Ptr_registers_saved pr4 and pr6 contain trace_catch_'s lp and sp.

	lpri	ptr_registers_saved
	lreg	registers_saved

" Pop our stack frame.

	spri6	pr7|stack_header.stack_end_ptr
	epp6	pr6|stack_frame.prev_sp,*
	tra	RETURN

MERGE_FRAMES:

" Restore registers.  Ptr_registers_saved pr4 and pr6 contain trace_catch_'s lp and sp.

	lpri	ptr_registers_saved
	lreg	registers_saved

	ldaq	pr7|stack_header.stack_end_ptr " Remember where this frame ends.
	epp6	pr6|stack_frame.prev_sp,*	" Drop back to frame we are returning to.
	staq	pr6|stack_frame.next_sp	" Extend it to protect data in next frame.

RETURN:
	epbp7	pr6|0
	epp0	pr6|stack_frame.operator_ptr,*
	ldi	pr6|stack_frame.return_ptr+1

" Permit tracing again.

	stz	pr7|stack_header.in_trace

" The read the clock as the last step for maximum accuracy.

	read_the_calendar_clock	start

	rtcd	pr6|stack_frame.return_ptr

	inhibit	off		<-> <-> <-> <-> <-> <-> <-> <-> <-> <->

" This preliminary cleanup handler just permits tracing again.

PRELIMINARY_CLEANUP_HANDLER:

	stz	pr7|stack_header.in_trace

	short_return





" This code is invoked during stack unwinding.  It calculates the meters for
" the last interval, adds them to the tab and trace_catch_$metered, pops the
" tab recursion level, pops the frame off the stack of trace_catch_ frames,
" and resets stack_header.in_trace to permit tracing again.

	entry	TRACE_CATCH_CLEANUP

TRACE_CATCH_CLEANUP:

	inhibit	on		<+> <+> <+> <+> <+> <+> <+> <+> <+> <+>

	get_pr4

" Read the calendar clock as soon as possible.

	read_the_calendar_clock	stop

" Do what getlp does.

	epp5	pr7|stack_header.stack_end_ptr,* " PR5 -> stack frame construction site.
	epp3	trace_catch_$TRACE_CATCH_CLEANUP " Let debuggers see a real entry point.
	spri3	pr5|stack_frame.entry_ptr

" Push.

	spri6	pr5|stack_frame.prev_sp
	spri0	pr5|stack_frame.arg_ptr
	spri4	pr5|stack_frame.lp_ptr
	epp6	pr5|0
	epp5	pr6|stack_frame_size
	spri5	pr7|stack_header.stack_end_ptr
	spri5	pr6|stack_frame.next_sp

" Read the meters.

	read_vcpu_time_and_page_faults	stop

" Prevent tracing of calls or errors during cleanup.

	eaa	TRUE
	sta	pr7|stack_header.in_trace

" Put environment pointer from argument into pr5.

	epp0	pr6|stack_frame.arg_ptr,*
	lda	pr0|0
	eaq	-1
	cmk	8,dl		" If there in no environment pointer,
	tnz	trace_error_halt_$trace_error_halt_ " we can't go further.
	epp5	pr0|2,au*

" Calculate the elapsed meters and store them in the frame being unwound.

	metering_interval_calculations	pr5,entry

" Get the tab_ptr, if this entrypoint is still in the trace table.

	epp1	pr4|tt_ptr,*
	ldaq	pr1|table.version
	cmpaq	TT_VERSION_3
	tnz	trace_error_halt_$trace_error_halt_

	ldq	pr5|event+event.entry_ptr	" Q reg contains the value we are looking for.

	seek_table	EP_IS_IN_TT_AT_UNWIND,POP_TRACE_FRAME_AT_UNWIND

EP_IS_IN_TT_AT_UNWIND:
	eaa	0,x2
	ars	18
	sta	pr5|event+event.entry_idx
	lprp2	pr2|te.data
	ldaq	pr2|tab.version
	cmpaq	TAB_VERSION_3
	tnz	trace_error_halt_$trace_error_halt_

" If tracing is disabled, the operator pointers have been yanked.  Pretend we arn't here.

	szn	pr4|global_parameters+global_parms.enabled
	tze	POP_TAB_AT_UNWIND

" See if this entrypoint can still be traced.  The user could have turned it off while stopped.

	is_tracing_permitted	POP_TAB_AT_UNWIND

" Call the procedure that prints the tracing message, if appropriate.

	trace_and_stop_if_necessary	pr5,un

" Move the meters to the tab.

	update_tab_meters	pr5

POP_TAB_AT_UNWIND:			" Restore the recursion level in the tab.
	pop_tab		pr5

POP_TRACE_FRAME_AT_UNWIND:
	epp2	null_ptr,*		" For safety.

" Pop this frame off the stack of trace_catch_ frames.

	ldaq	pr5|trace_frames_saved
	staq	pr7|stack_header.trace_frames

" Permit tracing again.  We don't expect any errors from the few operations below.

	stz	pr7|stack_header.in_trace

" Start a metering interval, regardless of whether there is anything to meter.

	start_metering_interval	return

" Pop our stack frame.

	spri6	pr7|stack_header.stack_end_ptr
	epp6	pr6|stack_frame.prev_sp,*

" Return.

	epbp7	pr6|0
	epp0	pr6|stack_frame.operator_ptr,*
	ldi	pr6|stack_frame.return_ptr+1

" The read the clock as the last step for maximum accuracy.

	read_the_calendar_clock	start

	rtcd	pr6|stack_frame.return_ptr

	inhibit	off		<-> <-> <-> <-> <-> <-> <-> <-> <-> <->

" This entrypoint disables the trace facility by yanking the trace operator
" pointers from the stack header.  It then flushes the frame and global meters
" from all the trace_catch_ frames on the stack.  It is
" only called if trace is enabled at the beginning of the transaction.

" dcl  trace_catch_$stop_tracing entry ();
" call trace_catch_$stop_tracing ();

	segdef	stop_tracing
stop_tracing:
	get_pr4

" See if trace is disabled or effectively disabled.

	szn	pr4|global_parameters+global_parms.enabled
	tze	STOP_SHORT_RETURN
	szn	pr4|global_parameters+global_parms.automatic
	tnz	YANK_OP_PTRS
	szn	pr4|global_parameters+global_parms.signals
	tnz	YANK_OP_PTRS
	epp1	pr4|tt_ptr,*
	ldaq	pr1|table.version
	cmpaq	TT_VERSION_3
	tnz	trace_error_halt_$trace_error_halt_
	szn	pr1|table.count
	tnz	YANK_OP_PTRS
STOP_SHORT_RETURN:
	short_return

" Yank the pl1, ALM, and other language operator pointers from the stack header.

YANK_OP_PTRS:
	epp5	pl1_operators_$operator_table
	spri5	pr7|stack_header.pl1_operators_ptr
	epp5	operator_pointers_$operator_pointers_
	spri5	pr7|stack_header.trans_op_tv_ptr
	epp5	pl1_operators_$alm_entry
	spri5	pr7|stack_header.entry_op_ptr

	call6	trace_catch_$STOP_TRACING

" Its nice to be able to act like a regular ALM program.

	entry	STOP_TRACING
STOP_TRACING:
	push

" Go down the stack of trace_catch_ frames and update the global meters.

	lda	pr7|stack_header.trace_frames+trace_frames.count
	lprp5	pr7|stack_header.trace_frames+trace_frames.top_ptr

FLUSH_METERS_FROM_THIS_FRAME:
	tze	ALL_FRAMES_FLUSHED
	sba	1,dl
	cmpa	pr5|trace_frames_saved+trace_frames.count
	tnz	trace_error_halt_$trace_error_halt_

" Get the tab_ptr, if this entrypoint is still in the trace table.

	epp1	pr4|tt_ptr,*
	ldaq	pr1|table.version
	cmpaq	TT_VERSION_3
	tnz	trace_error_halt_$trace_error_halt_

	ldq	pr5|event+event.entry_ptr	" Q reg contains the value we are looking for.

	seek_table	EP_IS_IN_TT_AT_STOP,FLUSH_NEXT_FRAME

EP_IS_IN_TT_AT_STOP:
	lprp2	pr2|te.data
	ldaq	pr2|tab.version
	cmpaq	TAB_VERSION_3
	tnz	trace_error_halt_$trace_error_halt_

" Add the meters to the tab and to trace_catch_$metered.

	update_tab_meters	pr5

FLUSH_NEXT_FRAME:
	lda	pr5|trace_frames_saved+trace_frames.count
	lprp5	pr5|trace_frames_saved+trace_frames.top_ptr
	tra	FLUSH_METERS_FROM_THIS_FRAME

ALL_FRAMES_FLUSHED:
	return

" This entrypoint is called at the end of a trace command transaction to plant
" the operator pointers and restart global metering.  It is only called if
" trace is enabled at the end of the transaction.  It plants the operators and
" reads the meters into trace_catch_$start.

" dcl  trace_catch_$start_tracing entry ();
" call trace_catch_$start_tracing ();

	entry	start_tracing
start_tracing:
	push

" See if trace is disabled or effectively disabled.

	szn	pr4|global_parameters+global_parms.enabled
	tze	START_RETURN
	szn	pr4|global_parameters+global_parms.automatic
	tnz	RESTART_METERS
	szn	pr4|global_parameters+global_parms.signals
	tnz	RESTART_METERS
	epp1	pr4|tt_ptr,*
	ldaq	pr1|table.version
	cmpaq	TT_VERSION_3
	tnz	trace_error_halt_$trace_error_halt_
	szn	pr1|table.count
	tze	START_RETURN

" Go down the stack of trace_catch_ frames and restart the global meters.

RESTART_METERS:
	lda	pr7|stack_header.trace_frames+trace_frames.count
	lprp5	pr7|stack_header.trace_frames+trace_frames.top_ptr

START_METERS_IN_THIS_FRAME:
	tze	ALL_FRAMES_STARTED
	sba	1,dl
	cmpa	pr5|trace_frames_saved+trace_frames.count
	tnz	trace_error_halt_$trace_error_halt_

" Get the tab_ptr, if this entrypoint is still in the trace table.

	epp1	pr4|tt_ptr,*
	ldaq	pr1|table.version
	cmpaq	TT_VERSION_3
	tnz	trace_error_halt_$trace_error_halt_

	ldq	pr5|event+event.entry_ptr	" Q reg contains the value we are looking for.

	seek_table	EP_IS_IN_TT_AT_START,START_NEXT_FRAME

EP_IS_IN_TT_AT_START:
	lprp2	pr2|te.data
	ldaq	pr2|tab.version
	cmpaq	TAB_VERSION_3
	tnz	trace_error_halt_$trace_error_halt_

" Reset the global meters for this procedure if this is the first level of recursion.

	start_global_metering_interval	pr5

START_NEXT_FRAME:
	lda	pr5|trace_frames_saved+trace_frames.count
	lprp5	pr5|trace_frames_saved+trace_frames.top_ptr
	tra	START_METERS_IN_THIS_FRAME

" Plant the pl1 and other language operator pointers in the stack header.

ALL_FRAMES_STARTED:
	epp5	pl1_operators_$trace_operator_table
	spri5	pr7|stack_header.pl1_operators_ptr
	epp5	trace_operator_pointers_$trace_operator_pointers_
	spri5	pr7|stack_header.trans_op_tv_ptr

" Plant the ALM operator only if alm is on.

	szn	pr4|global_parameters+global_parms.alm
	tze	*+3
	epp5	pl1_operators_$trace_alm_entry
	spri5	pr7|stack_header.entry_op_ptr

START_RETURN:
	return

" CONSTANTS   CONSTANTS   CONSTANTS   CONSTANTS   CONSTANTS   CONSTANTS   CONSTANTS


			even
BUFFER_VERSION_3:		aci	/TraceBF3/,8

			even
EVENT_VERSION_3:		aci	/TEV3/,4

			even
TT_VERSION_3:		aci	/TraceTT3/,8

			even
TAB_VERSION_3:		aci	/TraceTB3/,8

			even
PARAMETERS_VERSION_3:	aci	/TraceTP3/,8

			even
GLOBAL_PARAMETERS_VERSION_3:	aci	/TraceGP3/,8

			even
UNUSUAL_SIGNAL_ARG_LIST:	aci	/Unusual signal_ arg list/,24

			even
zero_arg_list_header:	oct	000000000004,000000000000
one_arg_list_header:	oct	000002000004,000000000000
two_arg_list_header:	oct	000004000004,000000000000
three_arg_list_header:	oct	000006000004,000000000000
four_arg_list_header:	oct	000010000004,000000000000
five_arg_list_header:	oct	000012000004,000000000000

one_arg_list_header_w_env:	oct	000002000010,000000000000
two_arg_list_header_w_env:	oct	000004000010,000000000000
three_arg_list_header_w_env:	oct	000006000010,000000000000
four_arg_list_header_w_env:	oct	000010000010,000000000000
five_arg_list_header_w_env:	oct	000012000010,000000000000

null_ptr:			oct	077777000043,000001000000
ptr_mask:			oct	077777000077,777777077077

double_precision_one:	dec	0,1

vcpu_time_fuzz:		dec	0,16

packed_null:		oct	007777000001

" INTERNAL STATIC   INTERNAL STATIC   INTERNAL STATIC   INTERNAL STATIC   INTERNAL STATIC

		use	static_section
		join	/link/static_section

TRANSACTION_BEGIN:		oct	007777000001
TRANSACTION_BEGIN_FORCE:	oct	007777000001
SIGNAL_:			oct	007777000001
IO_SIGNAL:		oct	007777000001

		even
start:		dec	0,0,0,0,0
start_comp:	dec	0		" UPPER HALF WORD
		even
stop:		dec	0,0,0,0,0
		even
delta:		dec	0,0,0,0,0

		even
		segdef	metered
metered:		dec	0,1,0,1,1

		even
		segdef	removed
removed:		dec	0,1,0,1,1

		even
		segdef	trace_storage_ptr
trace_storage_ptr:	its	-1,1

		even
		segdef	tt_ptr
tt_ptr:		its	-1,1

		even
		segdef	wt_ptr
wt_ptr:		its	-1,1

		segdef	parameters_ptr
parameters_ptr:	oct	007777000001

		even
		segdef	global_parameters
		bss	global_parameters,182

" SYMBOLS  SYMBOLS  SYMBOLS  SYMBOLS  SYMBOLS  SYMBOLS  SYMBOLS  SYMBOLS

	bool	TRUE,400000

"
"	Structure table
"
	equ	table.version,0		" DOUBLE
	equ	table.max_count,2
	equ	table.count,3

	equ	table.idx,4		" LEVEL 2
	equ	      idx.low,0
	equ	      idx.high,1

	equ	table.working_storage,6	" DOUBLE
	equ	table.e,8			" DOUBLE

"
"	Structure te
"
	equ	te_size,2

	equ	te,0			" DOUBLE
	equ	te.key,0
	equ	te.data,1

"
"	Structure tab
"
	equ	tab.version,0		" DOUBLE
	equ	tab.reference_count,2
	equ	tab.parms_ptr,3

	equ	tab.cts,4			" like counts

	equ	tab.local,8		" like meters

	equ	tab.on,13

	equ	tab.global,14		" like meters

	equ	tab.translator_id,19
	equ	tab.function,20

"
"	Structure event is a 16 word block that describes a trace event.
"
	equ	event_size,16

	equ	event.version,0
	equ	event.kind,1		" UPPER
	equ	event.frame_count,1		" LOWER

	equ	event.frame,2		" LEVEL 2
	equ	event.frame.real_time,2		" DOUBLE
	equ	event.frame.vcpu_time,4		" DOUBLE
	equ	event.frame.page_faults,6

	equ	event.entry_ptr,7
	equ	event.saved,8		" LEVEL 2
	equ	event.saved.calls,8		" DOUBLE
	equ	event.saved.level,10
	equ	event.saved.max_level,11

	equ	event.entry_idx,12
	equ	event.arg_list_ptr,13
	equ	event.callers_sp,14
	equ	event.return_ptr,15

"
"	Structure counts is passed to the trace and stop routines.
"
	equ	counts.calls,0		" DOUBLE
	equ	counts.level,2
	equ	counts.max_level,3

"
"	Structure buffer of trace events.
"
	equ	buffer.h,0		" LEVEL 2
	equ	buffer.h.version,0		" DOUBLE
	equ	buffer.h.not_used,2
	equ	buffer.h.count,3
	equ	buffer.e,4		" (0 : 8191) like event

"
"	Structure meters
"
	equ	meters.real_time,0		" DOUBLE
	equ	meters.vcpu_time,2		" DOUBLE
	equ	meters.page_faults,4

"
"	Structure parms
"
	equ	parms.version,0		" DOUBLE
	equ	parms.reference_count,2
	equ	parms.every,3
	equ	parms.first,4
	equ	parms.last,5
	equ	parms.low,6
	equ	parms.high,7

	equ	parms.new_high,8
	equ	parms.arguments,9
	equ	parms.not_used1,10
	equ	parms.stop_every,11
	equ	parms.stop_low,12
	equ	parms.stop,13
	equ	parms.trace,14
	equ	parms.call_ptr,15

"
"	Structure global_parms (182 words)
"
	equ	global_parms.version,0	" DOUBLE
	equ	global_parms.alm,2
	equ	global_parms.automatic,3
	equ	global_parms.meter,4
	equ	global_parms.signals,5
	equ	global_parms.enabled,6
	equ	global_parms.long,7

	equ	global_parms.osw,8		" LEVEL 2
	equ	global_parms.osw.iocb_ptr,8
	equ	global_parms.osw.stream_name,10
	equ	global_parms.osw.file_path,19

	equ	global_parms.spp,84		" LEVEL 2
	equ	global_parms.spp.entry_value,84
	equ	global_parms.spp.entry_name,88

	equ	global_parms.trace_routine,154
	equ	global_parms.stop_routine,158

	equ	global_parms.loud,162
	equ	global_parms.calibrate,163
	equ	global_parms.buffer_ptr,164
	equ	global_parms.not_used,165

	equ	global_parms.comps,166	" LEVEL 2

	equ	from_entry,0
	equ	from_return,8

	equ	to_entry.real_time,0
	equ	to_entry.vcpu_time,2
	equ	to_return.real_time,4
	equ	to_return.vcpu_time,6

	include	stack_header

	include	stack_frame

	include	on_unit

	end




		    trace_conversions_.pl1          10/23/84  1334.6rew 10/23/84  1219.1       32193



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/*
   This program contains data conversion logic for the trace facility.

   Written: May 1984 by Jeffrey D. Ives.
*/
/* format: style2,ifthendo,^indnoniterdo,thendo,^inditerdo,indproc,ind2,dclind5,idind32 */


trace_conversions_:
  procedure ();
    signal error;


cv_inout_to_bits:
  entry (char8_i) returns (bit (2) aligned);
    char8 = char8_i;
    if char8 = "on" | char8 = "inout" | char8 = "both"
    then return ("11"b);
    else if char8 = "off" | char8 = "none" | char8 = "neither"
    then return ("00"b);
    else if char8 = "in"
    then return ("10"b);
    else if char8 = "out"
    then return ("01"b);
    else call
	 sub_err_ (error_table_$bad_arg, trace_$me (), ACTION_CANT_RESTART, null (), rv,
	 "I don't understand ""^a"".  I was expecting in, out, on, or off.", char8);


cv_bits_to_inout:
  entry (bit2_i) returns (char (8) aligned);
    bit2 = bit2_i;
    if bit2 = "00"b
    then return ("off");
    else if bit2 = "01"b
    then return ("out");
    else if bit2 = "10"b
    then return ("in");
    else if bit2 = "11"b
    then return ("on");
    else signal error;


cv_n_to_number:
  entry (char16_i) returns (fixed bin (34));
    char16 = char16_i;
    on conversion, size
      call
        sub_err_ (error_table_$bad_arg, trace_$me (), ACTION_CANT_RESTART, null (), rv,
        "I can not interpret ""^a"" as a number between 0 and ^d.", char16, MAX_34_BIT_NUMBER);
(size):
    number = convert (number, char16);
    if number < 0 | number > MAX_34_BIT_NUMBER
    then call
	 sub_err_ (error_table_$bad_arg, trace_$me (), ACTION_CANT_RESTART, null (), rv,
	 "I can not interpret ""^a"" as a number between 0 and ^d.", char16, MAX_34_BIT_NUMBER);
    return (number);


cv_onoff_to_bit:
  entry (char8_i) returns (bit aligned);
    char8 = char8_i;
    if char8 = "on"
    then return ("1"b);
    else if char8 = "off"
    then return ("0"b);
    else call
	 sub_err_ (error_table_$bad_arg, trace_$me (), ACTION_CANT_RESTART, null (), rv,
	 "I don't understand ""^a"".  I was expecting on, or off.", char8);


cv_bit_to_onoff:
  entry (bit1_i) returns (char (8) aligned);
    if bit1_i
    then return ("on");
    else return ("off");
%page;
/* START OF DEC_LARATIONS */
/* format: ^insnl,^delnl */

/* Parameters */

    dcl  bit1_i			 bit aligned parm;
    dcl  bit2_i			 bit (2) aligned parm;
    dcl  char8_i			 char (8) aligned parm;
    dcl  char16_i			 char (16) parm;


/* Automatic */

    dcl  bit2			 bit (2) aligned;
    dcl  char8			 char (8) aligned;
    dcl  char16			 char (16);
    dcl  code			 fixed bin (35);
    dcl  number			 fixed bin (35);
    dcl  rv			 fixed bin (35);


/* Static */

    dcl  MAX_34_BIT_NUMBER		 fixed bin (35) static options (constant) init (17179869183);
    dcl  ZERO			 fixed bin (35) static options (constant) init (0);


/* Conditions */

    dcl  conversion			 condition;
    dcl  error			 condition;
    dcl  size			 condition;


/* Based */


/* External Variables */

    dcl  error_table_$bad_arg		 fixed bin (35) ext;


/* External Entries */

    dcl  sub_err_			 entry () options (variable);


/* format: insnl,delnl */
/* END OF DECLARATIONS */
%page;
/* START OF INCLUDE FILES */



%include sub_err_flags;
%page;
%include trace_interface;

  end trace_conversions_;




		    trace_entrypoints_.pl1          05/01/86  0830.8rew 05/01/86  0805.9      172170



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */


/****^  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.
                                                   END HISTORY COMMENTS */


/*
   This program converts entrypoint names into pointers and vice versa.

   Written: May 1984 by Jeffrey D. Ives.
*/
/* format: style2,ifthendo,^indnoniterdo,thendo,^inditerdo,indproc,ind2,dclind5,idind32 */


trace_entrypoints_:
  procedure ();

       dcl (addr, addrel, baseno, before, bin, codeptr, index, maxlength,
	 null, pointer, rel, reverse, rtrim, search, substr, unspec)
				builtin;
    signal error;


get_path_name:
  entry (entry_ptr_i) returns (char (256) var);
    call hcs_$fs_get_path_name (pointer (entry_ptr_i, 0), pathname.dir, (0), pathname.ent, code);
    if code ^= 0
    then do;
      call sub_err_ (code, trace_$me (), ACTION_DEFAULT_RESTART, null (), rv, "I could not get the path name of ^p.",
	 pointer (entry_ptr_i, 0));
      pathname.dir = "?";
      pathname.ent = "?";
    end;
    return (rtrim (pathname.dir) || ">" || rtrim (pathname.ent));
%page;
add_entrypoint:					/* Called from trace_catch_. */
  entry (entry_ptr_i) returns (fixed bin);
    entry_ptr = entry_ptr_i;
    on any_other go to ADD_ENTRYPOINT_PUNT;
    segment = SEGMENT (entry_ptr);
    object = OBJECT (segment);
    entry_ptr_offset = bin (rel (entry_ptr), 18);
    if entry_ptr_offset < 2 | entry_ptr -> word (1) = ALM_TSP2_PR7_UP_38_STAR
    then do;					/* if alm then search definitions */
      definition = DEFINITION (object, object.defp);
      do while (^(definition.section = "text" & definition.offset = entry_ptr_offset));
        if definition.section = "eof"
        then go to ADD_ENTRYPOINT_PUNT;
        definition = DEFINITION (object, definition.next_def);
      end;
      entry_name = ENTRY_NAME (object, definition);
    end;
    else do;					/* assume standard entry sequence -> definition */
      defptr = addrel (object.defp, addrel (entry_ptr, -2) -> entry_sequence.def_relp);
      entry_name = ENTRY_NAME (object, DEFINITION (object, defptr));
    end;

    return (
         trace_tables_$add_entrypoint (entry_ptr, entry_name, TRANSLATOR_ID (entry_ptr, entry_name), FUNCTION (entry_ptr))
         );

ADD_ENTRYPOINT_PUNT:
    revert any_other;
    call hcs_$fs_get_path_name (pointer (entry_ptr, 0), pathname.dir, (0), pathname.ent, code);
    if code = 0
    then entry_name = rtrim (pathname.ent) || "$" || OCTAL (rel (entry_ptr));
    else entry_name = OCTAL (baseno (entry_ptr)) || "$" || OCTAL (rel (entry_ptr));
    return (trace_tables_$add_entrypoint (entry_ptr, entry_name, -1, "0"b));
%page;
specify_entrypoints:
  entry (char256var_i, referencing_ptr_i);

    if char256var_i = "*"
    then do;
      call trace_tables_$specify_all_entrypoints ();
      return;
    end;

    desired = DESIRED (char256var_i);

    entry_ptr = codeptr (cv_entry_ (desired.path, referencing_ptr_i, code));
    if code ^= 0
    then
      begin;					/* try looking for seg name in trace table */
        dcl  tt_count		     fixed bin;
        dcl  tt_idx			     fixed bin;
        tt_count = trace_$num_entrypoints ();
        do tt_idx = 0 by 1 while (code = error_table_$seg_not_found & tt_idx < tt_count);
	if before (trace_$entrypoint_name (tt_idx), "$") = desired.segment_symbol
	then do;
	  entry_ptr = pointer (trace_$entrypoint_ptr (tt_idx), 0);
	  code = 0;
	end;
        end;
        if code ^= 0
        then call sub_err_ (code, trace_$me (), ACTION_CANT_RESTART, null (), rv, """^a""", char256var_i);
      end;

    segment = SEGMENT (entry_ptr);
    object = OBJECT (segment);

    if desired.offset_symbol ^= "*"
    then
      begin;					/* try get_definition_ first */
        dcl  get_definition_		     entry (ptr, char (*), char (*), ptr, fixed bin (35));
        call get_definition_ (object.defp, (desired.segment_symbol), (desired.offset_symbol), defptr, code);
        if code = 0
        then do;
	definition = DEFINITION (object, defptr);
	entry_ptr = addrel (object.textp, definition.offset);
	entry_name = ENTRY_NAME (object, definition);
	call trace_tables_$specify_entrypoint (entry_ptr, entry_name, TRANSLATOR_ID (entry_ptr, entry_name),
	     FUNCTION (entry_ptr));
	return;
        end;
      end;

    definition = DEFINITION (object, object.defp);	/* get primary or bind file name */
    do while (definition.flags.a_ignore & definition.section ^= "eof");
      definition = DEFINITION (object, definition.next_def);
    end;

    if definition.section ^= "segn"
    then call sub_err_ (error_table_$no_ext_sym, trace_$me (), ACTION_CANT_RESTART, null (), rv, """^a""", char256var_i);

    n_specified = 0;
    if ^object.format.bound | substr (definition.symbol, 1, definition.symbol_lng) = desired.segment_symbol
    then do;
      definition = DEFINITION (object, definition.block_ptr);
      do while (definition.section ^= "eof");
        if definition.section = "text" & definition.offset ^= 0
        then do;
	if desired.offset_symbol = "*" | substr (definition.symbol, 1, definition.symbol_lng) = desired.offset_symbol
	then do;
	  entry_ptr = addrel (object.textp, definition.offset);
	  entry_name = ENTRY_NAME (object, definition);
	  call trace_tables_$specify_entrypoint (entry_ptr, entry_name, TRANSLATOR_ID (entry_ptr, entry_name),
	       FUNCTION (entry_ptr));
	  n_specified = n_specified + 1;
	end;
        end;
        definition = DEFINITION (object, definition.next_def);
      end;
    end;
    else do;					/* look for the component to trace */
      definition = DEFINITION (object, definition.next_def);
      do while (
	 ^(definition.section = "segn" & substr (definition.symbol, 1, definition.symbol_lng) = desired.segment_symbol))
	 ;
        if definition.section = "eof"
        then call sub_err_ (ZERO, trace_$me (), ACTION_CANT_RESTART, null (), rv,
	        "The segment symbol ""^a"" was not found in the segment ""^a"".", desired.segment_symbol, desired.path);
        definition = DEFINITION (object, definition.next_def);
      end;

      definition = DEFINITION (object, definition.block_ptr);
      do while (^(definition.section = "segn" | definition.section = "eof"));
        if definition.section = "text" & definition.offset ^= 0
        then do;
	if desired.offset_symbol = "*" | substr (definition.symbol, 1, definition.symbol_lng) = desired.offset_symbol
	then do;
	  entry_ptr = addrel (object.textp, definition.offset);
	  entry_name = ENTRY_NAME (object, definition);
	  call trace_tables_$specify_entrypoint (entry_ptr, entry_name, TRANSLATOR_ID (entry_ptr, entry_name),
	       FUNCTION (entry_ptr));
	  n_specified = n_specified + 1;
	end;
        end;
        definition = DEFINITION (object, definition.next_def);
      end;
    end;

    if n_specified = 0
    then call sub_err_ (error_table_$no_ext_sym, trace_$me (), ACTION_CANT_RESTART, null (), rv, """^a""", char256var_i);
    return;
%page;
/* SUBROUTINES */


DESIRED:
  proc (char256var_i) returns (1 like desired aligned);
    dcl  char256var_i		 char (256) var parm;
    dcl  jj			 fixed bin;
    dcl  kk			 fixed bin;
    dcl  1 des			 like desired aligned;

    des.path = char256var_i;
    des.pathl = length (rtrim (des.path));
    des.segment_symbol = "";
    des.offset_symbol = "";

    if des.pathl = 0
    then call sub_err_ (error_table_$smallarg, trace_$me (), ACTION_CANT_RESTART, null (), rv, """""");

    jj = search (reverse (substr (des.path, 1, des.pathl)), "<>");
    if jj = 1
    then call sub_err_ (error_table_$badpath, trace_$me (), ACTION_CANT_RESTART, null (), rv, """^a""", des.path);
    if jj = 0					/* point jj to first char in seg name */
    then jj = 1;
    else jj = des.pathl - jj + 2;

    kk = search (substr (des.path, jj, des.pathl - jj + 1), "$|");

    if kk = 1 | kk = des.pathl - jj + 1			/* shouldn't be first or last */
    then call sub_err_ (error_table_$bad_arg, trace_$me (), ACTION_CANT_RESTART, null (), rv, """^a""", des.path);
    if kk = 0
    then do;
      if des.pathl - jj + 1 > maxlength (des.segment_symbol) | des.pathl - jj + 1 > maxlength (des.offset_symbol)
      then call sub_err_ (error_table_$bigarg, trace_$me (), ACTION_CANT_RESTART, null (), rv, """^a""", des.path);

      des.segment_symbol = substr (des.path, jj, des.pathl - jj + 1);
      des.offset_symbol = substr (des.path, jj, des.pathl - jj + 1);
      des.pathl = des.pathl + 2;
      substr (des.path, des.pathl - 1, 2) = "$0";		/* for cv_entry_ */
    end;
    else do;
      if kk - 1 > maxlength (des.segment_symbol) | des.pathl - jj + 1 - kk > maxlength (des.offset_symbol)
      then call sub_err_ (error_table_$bigarg, trace_$me (), ACTION_CANT_RESTART, null (), rv, """^a""", des.path);
      des.segment_symbol = substr (des.path, jj, kk - 1);
      des.offset_symbol = substr (des.path, jj + kk, des.pathl - jj + 1 - kk);
      des.pathl = jj + kk;
      substr (des.path, des.pathl) = "0";
    end;

    if jj > 1					/* if there are "<>" characters */
    then substr (des.path, des.pathl - 1, 1) = "|";
    return (des);
  end DESIRED;


SEGMENT:
  proc (entry_ptr_i) returns (1 like segment aligned);
    dcl  entry_ptr_i		 ptr unal;
    dcl  1 seg			 like segment aligned;
    dcl  hcs_$status_mins		 entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
    seg.base_ptr = pointer (entry_ptr, 0);
    call hcs_$status_mins (seg.base_ptr, seg.entry_type, seg.bit_count, code);
    if code ^= 0
    then call sub_err_ (code, trace_$me (), ACTION_CANT_RESTART, null (), rv, "I could not get the status of ""^p"".",
	    seg.base_ptr);
    if seg.entry_type ^= 1				/* 1 means segment. */
    then call sub_err_ (ZERO, trace_$me (), ACTION_CANT_RESTART, null (), rv, """^p"" does not point to a segment.",
	    seg.base_ptr);
    return (seg);
  end SEGMENT;


OBJECT:
  proc (segment_i) returns (1 like object_info aligned);
    dcl  1 segment_i		 like segment aligned parm;
    dcl  1 oi			 like object_info aligned;
    dcl  object_info_$brief		 entry (ptr, fixed bin (24), ptr, fixed bin (35));
    unspec (oi) = ""b;
    oi.version_number = object_info_version_2;
    call object_info_$brief (segment_i.base_ptr, segment_i.bit_count, addr (oi), code);
    if code ^= 0
    then call sub_err_ (code, trace_$me (), ACTION_CANT_RESTART, null (), rv, """^a""",
	    get_path_name ((segment.base_ptr)));
    return (oi);
  end OBJECT;


DEFINITION:
  proc (object_i, defptr_i) returns (1 like definition aligned);
    dcl  defptr_i			 ptr parm;
    dcl  1 object_i			 like object_info aligned;
    dcl  1 def			 like definition aligned;
    dcl  decode_definition_$full	 entry (ptr, ptr, ptr) returns (bit aligned);
    if decode_definition_$full ((defptr_i), addr (def), addr (object_i))
    then do;
      unspec (def) = ""b;
      def.next_def = null ();
      def.last_def = null ();
      def.block_ptr = null ();
      def.section = "eof";
      def.descr_ptr = null ();
    end;
    else if def.section = "text"
    then
      begin;					/* strip off component name if necessary */
        dcl  kk			     fixed bin;
        kk = index (substr (def.symbol, 1, def.symbol_lng), "$");
        if kk > 0
        then do;
	def.symbol_lng = def.symbol_lng - kk;
	def.symbol = substr (def.symbol, kk + 1, def.symbol_lng);
        end;
      end;
    return (def);
  end DEFINITION;


ENTRY_NAME:
  proc (object_i, offset_definition_i) returns (char (65) var);
    dcl  1 object_i			 like object_info aligned parm;
    dcl  1 offset_definition_i	 like definition aligned parm;
    dcl  1 segment_definition		 like definition aligned;
    segment_definition = DEFINITION (object_i, offset_definition_i.block_ptr);
    if segment_definition.section = "eof"
    then call sub_err_ (ZERO, trace_$me (), ACTION_CANT_RESTART, null (), rv,
	    "There seems to be something wrong with the definition of ^a.",
	    substr (offset_definition_i.symbol, 1, offset_definition_i.symbol_lng));
    return (substr (segment_definition.symbol, 1, segment_definition.symbol_lng) || "$"
         || substr (offset_definition_i.symbol, 1, offset_definition_i.symbol_lng));
  end ENTRY_NAME;


OCTAL:
  proc (half_word_i) returns (char (32) var);
    dcl  half_word_i		 bit (18) aligned parm;
    dcl  char32var			 char (32) var;
    dcl  dummy			 fixed bin;
    call ioa_$rsnnl ("^o", char32var, dummy, half_word_i);
    return (char32var);
  end OCTAL;


FUNCTION:
  proc (entry_ptr_i) returns (bit aligned);
    dcl  entry_ptr_i		 ptr unal parm;
    dcl  desc_ptrs			 (1) ptr;
    dcl  1 edi			 like entry_desc_info aligned;
    dcl  get_entry_arg_descs_$info	 entry (ptr, fixed bin, (*) ptr, ptr, fixed bin (35));
    entry_desc_info_ptr = addr (edi);
    unspec (entry_desc_info) = ""b;
    entry_desc_info.version = entry_desc_info_version_2;
    call get_entry_arg_descs_$info ((entry_ptr_i), (0), desc_ptrs, entry_desc_info_ptr, (0));
    return (entry_desc_info.flags.function);
%include entry_desc_info;
  end FUNCTION;


TRANSLATOR_ID:
  proc (entry_ptr_i, entry_name_i) returns (fixed bin);
    dcl  entry_ptr_i		 ptr unal parm;
    dcl  entry_name_i		 char (65) var parm;
    dcl  translator_id		 fixed bin;
    dcl  entry_name			 char (65);
    dcl  entry_ptr			 ptr;
    dcl  link_trap_caller_		 entry ();
    dcl  unwind_stack_		 entry ();
    dcl  unwinder_			 entry ();

    entry_name = entry_name_i;
    entry_ptr = entry_ptr_i;

    if entry_ptr -> word (1) = ALM_TSP2_PR7_UP_38_STAR
    then translator_id = 1;
    else translator_id = 0;

    if (entry_ptr -> word (2) ^= PL1_FORTRAN_EPP2_PR7_UP_28_STAR & entry_ptr -> word (2) ^= COBOL_EPP2_PR7_UP_40_STAR
         & entry_ptr -> word (1) ^= ALM_TSP2_PR7_UP_38_STAR)
         | (entry_ptr -> word (1) = ALM_TSP2_PR7_UP_38_STAR
         & (entry_name = "ssu_$standalone_invocation" | substr (entry_name, 1, 4) = "cu_$"
         | substr (entry_name, 1, 9) = "formline_" | substr (entry_name, 1, 5) = "lisp_"
         | substr (entry_name, 1, 15) = "nonlocal_goto_$" | substr (entry_name, 1, 11) = "condition_$"))
         | entry_ptr = codeptr (link_trap_caller_) | entry_ptr = codeptr (unwind_stack_)
         | entry_ptr = codeptr (unwinder_) | entry_name = "ssu_invocation_$create_standalone"
         | substr (entry_name, 1, 11) = "pascal_io_$" | substr (entry_name, 1, 24) = "pascal_area_management_$"
         | substr (entry_name, 1, 12) = "pascal_time$" | substr (entry_name, 1, 15) = "pascal_errors_$"
         | substr (entry_name, 1, 5) = "probe" | substr (entry_name, 1, 10) = "cobol_rts_"
         | substr (entry_name, 1, 11) = "fortran_io_" | substr (entry_name, 1, 14) = "cobol_control_"
    then translator_id = -1;

    return (translator_id);
  end TRANSLATOR_ID;
%page;
/* START OF DECLARATIONS */
/* format: ^insnl,^delnl */

/* Parameters */

    dcl  char256var_i		 char (256) var parm;
    dcl  entry_ptr_i		 ptr unal parm;
    dcl  referencing_ptr_i		 ptr parm;


/* Automatic */

    dcl  code			 fixed bin (35);
    dcl  defptr			 ptr;
    dcl  entry_name			 char (65) var;
    dcl  entry_ptr			 ptr unal;
    dcl  entry_ptr_offset		 fixed bin (18);
    dcl  n_specified		 fixed bin;
    dcl  rv			 fixed bin (35);

    dcl  1 desired			 aligned,
	 2 path			 char (300) unal,
	 2 pathl			 fixed bin,
	 2 segment_symbol		 char (32) var unal,
	 2 offset_symbol		 char (32) var unal;

    dcl  1 pathname			 aligned,
	 2 dir			 char (168) unal,
	 2 ent			 char (32) unal;

    dcl  1 segment			 aligned,
	 2 base_ptr		 ptr,
	 2 entry_type		 fixed bin (2),
	 2 bit_count		 fixed bin (24);

    dcl  1 definition		 aligned,		/* structure filled in by full entry */
	 2 next_def		 ptr,		/* ptr to next definition in list */
	 2 last_def		 ptr,		/* ptr to previous definition in list */
	 2 block_ptr		 ptr,		/* ptr to either defblock or segname block */
	 2 section		 char (4),	/* "text", "link", "symb" or "segn" */
	 2 offset			 fixed bin (18),	/* offset within class (if ^= "segn") */
	 2 entrypoint		 fixed bin (18),	/* value of entrypoint in text if ^= 0 */
	 2 symbol			 char (256),	/* the symbolic name of the definition */
	 2 symbol_lng		 fixed bin,	/* the actual length of symbol */
	 2 flags,					/* same flags as in std def */
	   3 a_new_format		 bit unaligned,	/* def is in new format */
	   3 a_ignore		 bit unaligned,	/* linker should ignore this def */
	   3 a_entrypoint		 bit unaligned,	/* def is for entrypoint */
	   3 a_retain		 bit unaligned,
	   3 a_arg_count		 bit unaligned,	/* there is an arg count for entry */
	   3 a_descr_sw		 bit unaligned,	/* there are valid descriptors for entry */
	   3 unused		 bit (12) unaligned,
	 2 n_args			 fixed bin,	/* # of args entry expects */
	 2 descr_ptr		 ptr;		/* ptr to array of rel ptrs to descriptors for entry */

    dcl  1 entry_sequence		 aligned based,
	 2 descr_relp_offset	 bit (18) unal,
	 2 reserved		 bit (18) unal,
	 2 def_relp		 bit (18) unal,
	 2 flags			 bit (18) unal;

    dcl  1 object			 like object_info aligned;


/* Static */

    dcl  ALM_TSP2_PR7_UP_38_STAR	 bit (36) aligned static options (constant) init ("700046272120"b3);
						/* ALM entry point */
    dcl  COBOL_EPP2_PR7_UP_40_STAR	 bit (36) aligned static options (constant) init ("700050352120"b3);
						/* COBOL entry point */
    dcl  PL1_FORTRAN_EPP2_PR7_UP_28_STAR bit (36) aligned static options (constant) init ("700034352120"b3);
						/* PL/I or FORTRAN entry point */
    dcl  ZERO			 fixed bin (35) static options (constant) init (0);
    dcl  length			 builtin;


/* Conditions */

    dcl  any_other			 condition;
    dcl  error			 condition;


/* Based */

    dcl  word			 (3) bit (36) aligned based;


/* External Variables */

    dcl  error_table_$bad_arg		 fixed bin (35) ext;
    dcl  error_table_$badpath		 fixed bin (35) ext;
    dcl  error_table_$bigarg		 fixed bin (35) ext;
    dcl  error_table_$no_ext_sym	 fixed bin (35) ext;
    dcl  error_table_$seg_not_found	 fixed bin (35) ext;
    dcl  error_table_$smallarg	 fixed bin (35) ext;


/* External Entries */

    dcl  cv_entry_			 entry (char (*), ptr, fixed bin (35)) returns (entry);
    dcl  hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
    dcl  ioa_$rsnnl			 entry () options (variable);
    dcl  trace_tables_$add_entrypoint	 entry (ptr unal, char (65) var, fixed bin, bit aligned) returns (fixed bin);
    dcl  trace_tables_$specify_all_entrypoints entry ();
    dcl  trace_tables_$specify_entrypoint entry (ptr unal, char (65) var, fixed bin, bit aligned);
    dcl  sub_err_			 entry () options (variable);


/* format: insnl,delnl */
/* END OF DECLARATIONS */
%page;
/* START OF INCLUDE FILES */


%include object_info;



%include sub_err_flags;
%page;
%include trace_interface;


  end trace_entrypoints_;




		    trace_meters.pl1                01/11/85  1045.4rew 01/11/85  1034.9      123165



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

/*
Fall//79, Robert E. Mullen, Initial coding.
06/29/81, Jeffrey D. Ives, added SUB TOTALs.
03/29/82, Jeffrey D. Ives, added -bf and -of and made trace table 0 relative.
07/22/83, Jeffrey D. Ives, for new tab with bigger vcpu and real time fields.  Added VCPU/CALL.
May 1984, Jeffrey D. Ives, get rid of tab altogether and go to new interface.
*/

/* format: style2,^inddcls,^indnoniterdo,^inditerdo,dclind5,idind35 */
trace_meters:
tmt:
     procedure options (variable);

/* DISABLE TRACE_CATCH_ */

	transaction_id = clock ();
	on cleanup call TRACE_METERS_CLEANUP ();
	if ^trace_$transaction_begin (transaction_id)	/* Temporarily disables trace_catch_.			*/
	then do;
	     call com_err_ (code, ME, "There seems to be an incomplete invocation of trace,
watch, or trace_meters still on the stack.  Try the release command.");
	     return;
	end;
%page;
/* read the arguments */

	call cu_$arg_count (arg_count, code);
	if code ^= 0
	then do;
	     call com_err_ (code, ME);
	     go to RETURN;
	end;

ARG_READING_LOOP:
	do arg_idx = 1 to arg_count;
	     call cu_$arg_ptr (arg_idx, arg_ptr, arg_length, code);
	     if code ^= 0
	     then do;
		call com_err_ (code, ME);
		go to RETURN;
	     end;

	     if arg = "-brief" | arg = "-bf"
	     then long_format = "0"b;
	     else if arg = "-long" | arg = "-lg"
	     then long_format = "1"b;
	     else if arg = "-reset" | arg = "-rs"
	     then do;
		reset = "1"b;
		report = "0"b;
	     end;
	     else if arg = "-report_reset" | arg = "-rr"
	     then do;
		reset = "1"b;
		report = "1"b;
	     end;
	     else if arg = "-output_file" | arg = "-of"
	     then do;
		control_arg = arg;

		arg_idx = arg_idx + 1;
		call cu_$arg_ptr (arg_idx, arg_ptr, arg_length, code);
		if code ^= 0
		then do;
BAD_FILE_PATH_ARG:
		     call com_err_ (code, ME, " A pathname must follow ^a.", control_arg);
		     go to RETURN;
		end;

		if arg = ""
		then go to BAD_FILE_PATH_ARG;

		if substr (arg, 1, 1) = "-"
		then go to BAD_FILE_PATH_ARG;

		call expand_pathname_$add_suffix (arg, "tmt", output_file.dir_path, output_file.entry_name, code);
		if code ^= 0
		then do;
		     call com_err_ (code, ME, " The argument in error is ""^a"".", arg);
		     go to RETURN;
		end;
	     end;
	     else if arg = "-percent" | arg = "-pct" | arg = "-%"
	     then do;
		minimum.kind = "local";
		go to GET_PERCENTAGE;
	     end;
	     else if arg = "-global_percent" | arg = "-gpct" | arg = "-g%"
	     then do;
		minimum.kind = "global";
GET_PERCENTAGE:
		control_arg = arg;

		arg_idx = arg_idx + 1;
		call cu_$arg_ptr (arg_idx, arg_ptr, arg_length, code);
		if code ^= 0
		then do;
BAD_PERCENTAGE_ARG:
		     call com_err_ (code, ME, " A number between 0 and 100 must follow ^a.", control_arg);
		     go to RETURN;
		end;

		if arg = ""
		then go to BAD_PERCENTAGE_ARG;

		if substr (arg, 1, 1) = "-"
		then go to BAD_PERCENTAGE_ARG;

		numeric_arg = cv_dec_check_ (arg, code);
		if code ^= 0
		then do;
		     call com_err_ (ZERO, ME, " Decimal conversion error at ""^a"" in ""^a"".", substr (arg, code, 1),
			arg);
		     code = 0;
		     go to BAD_PERCENTAGE_ARG;
		end;

		if numeric_arg < 0 | numeric_arg > 100
		then go to BAD_PERCENTAGE_ARG;

		minimum.percent = numeric_arg;
	     end;
	     else do;
		call com_err_ (error_table_$badopt, ME, """^a""", arg);
		go to RETURN;
	     end;
	end ARG_READING_LOOP;
%page;
/* Open the output file if necessary. */

	if output_file.entry_name = ""
	then output_file.iocb_ptr = iox_$user_output;
	else
OPEN_OUTPUT_FILE:
	     do;
	     call iox_$attach_name (unique_chars_ (""b), output_file.iocb_ptr,
		"vfile_ " || rtrim (output_file.dir_path) || ">" || rtrim (output_file.entry_name),
		codeptr (trace_meters), code);
	     if code ^= 0
	     then do;
		call com_err_ (code, ME, " Coult not attach the file ""^a>^a"".", output_file.dir_path,
		     output_file.entry_name);
		go to RETURN;
	     end;

	     call iox_$open (output_file.iocb_ptr, Stream_output, "0"b, code);
	     if code ^= 0
	     then do;
		call com_err_ (code, ME, " Could not open the file ""^a>^a"".", output_file.dir_path,
		     output_file.entry_name);
		go to RETURN;
	     end;
	end OPEN_OUTPUT_FILE;


/* Do some consistency checks. */

	metered = trace_$metered () - trace_$removed ();

	if metered.real_time < 0 | metered.vcpu_time > metered.real_time | metered.page_faults < 0
	then call com_err_ (ZERO, ME,
		" The meters are inconsistent.  Metered real time is ^d, vcpu time is ^d, and page faults are ^d.",
		metered.real_time, metered.vcpu_time, metered.page_faults);


/* Calculate the percentage coefficients. */

	if metered.vcpu_time = 0
	then percentage_coefficient.vcpu_time = 0;
	else percentage_coefficient.vcpu_time = 1e2 / float (metered.vcpu_time, 27);

	if metered.page_faults = 0
	then percentage_coefficient.page_faults = 0;
	else percentage_coefficient.page_faults = 1e2 / float (metered.page_faults, 27);
%page;
/* Print the requested information. */

	totals = 0;
	tt_count = trace_$num_entrypoints ();

TOTAL_LOOP:
	do tt_idx = 0 by 0 to tt_count - 1;

	     segment_being_subtotaled.seg_num = baseno (trace_$entrypoint_ptr (tt_idx));
	     segment_being_subtotaled.dir_path = "?";
	     segment_being_subtotaled.entry_name = "?";

	     subtotals = 0;

SUB_TOTAL_LOOP:
	     do tt_idx = tt_idx to tt_count - 1
		while (baseno (trace_$entrypoint_ptr (tt_idx)) = segment_being_subtotaled.seg_num);

		counts = trace_$entrypoint_counts (tt_idx);
		local_meters = trace_$entrypoint_local_meters (tt_idx);
		global_meters = trace_$entrypoint_global_meters (tt_idx);

		if ^report
		then go to END_SUB_TOTAL_LOOP;

		if counts.calls = 0
		then go to END_SUB_TOTAL_LOOP;

		if minimum.kind = "local"
		then if float (local_meters.vcpu_time, 27) * percentage_coefficient.vcpu_time < minimum.percent
			& float (local_meters.page_faults, 27) * percentage_coefficient.page_faults
			< minimum.percent
		     then go to END_SUB_TOTAL_LOOP;

		if minimum.kind = "global"
		then if float (global_meters.vcpu_time, 27) * percentage_coefficient.vcpu_time < minimum.percent
			& float (global_meters.page_faults, 27) * percentage_coefficient.page_faults
			< minimum.percent
		     then go to END_SUB_TOTAL_LOOP;

/* Print column headers if necessary */

		if subtotals.line_count = 0
		then do;
		     if long_format
		     then do;
			call PRINT_METERS_HEADER ("G");
			call PRINT_METERS_HEADER ("L");
			call expand_pathname_ ((trace_$entrypoint_seg_path (tt_idx)),
			     segment_being_subtotaled.dir_path, segment_being_subtotaled.entry_name, code);
			if code ^= 0
			then segment_being_subtotaled.dir_path, segment_being_subtotaled.entry_name = "?";
			call ioa_$ioa_switch (output_file.iocb_ptr, " ^a>^a", segment_being_subtotaled.dir_path,
			     segment_being_subtotaled.entry_name);
		     end;

		     if ^long_format & totals.line_count = 0
		     then do;
			call PRINT_METERS_HEADER ("L");
			call ioa_$ioa_switch (output_file.iocb_ptr, " ENTRY POINT NAME");
		     end;
		end;


/* Print the stats for this entrypoint. */

		if long_format
		then call PRINT_METERS (global_meters);

		call PRINT_METERS (local_meters);

		call PRINT_STATS (local_meters.vcpu_time, counts.calls);

		call ioa_$ioa_switch (output_file.iocb_ptr, " ^a", trace_$entrypoint_name (tt_idx));

		subtotals.line_count = subtotals.line_count + 1;
		subtotals.calls = subtotals.calls + counts.calls;
		subtotals.meters = subtotals.meters + local_meters;

END_SUB_TOTAL_LOOP:
	     end SUB_TOTAL_LOOP;

	     if report & long_format & subtotals.line_count >= 1
	     then do;
		if subtotals.line_count >= 2
		then call PRINT_TOTAL_LINE (subtotals, "SUBTOTAL", segment_being_subtotaled.entry_name);

		call ioa_$ioa_switch (output_file.iocb_ptr, "");
	     end;

	     totals = totals + subtotals;
	end TOTAL_LOOP;


	if report
	then do;
	     if long_format
	     then call PRINT_METERS_HEADER (" ");
	     else call ioa_$ioa_switch (output_file.iocb_ptr, "");

	     call PRINT_METERS_HEADER ("L");

	     call ioa_$ioa_switch (output_file.iocb_ptr, "");

	     call date_time_ (clock (), date_time_string);

	     call PRINT_TOTAL_LINE (totals, "TOTAL", date_time_string);
	end;


	if reset
	then call trace_$reset_meters ();


RETURN:
	call TRACE_METERS_CLEANUP;

	return;
%page;
/* SUBROUTINES */


TRACE_METERS_CLEANUP:
     proc;
	if output_file.iocb_ptr ^= null () & output_file.iocb_ptr ^= iox_$user_output
	then do;
	     call iox_$close (output_file.iocb_ptr, (0));
	     call iox_$detach_iocb (output_file.iocb_ptr, (0));
	     output_file.iocb_ptr = null ();
	end;

	if ^trace_$transaction_end (transaction_id)	/* Re-enable trace_catch_. */
	then call com_err_ (ZERO, ME, "The trace_meters command ended abnormally.");
     end TRACE_METERS_CLEANUP;








PRINT_TOTAL_LINE:
     proc (totals_i, comment_1_i, comment_2_i);
	if long_format
	then call PRINT_METERS_HEADER (" ");

	call PRINT_METERS (totals_i.meters);

	call PRINT_STATS (totals_i.meters.vcpu_time, totals_i.calls);

	call ioa_$ioa_switch (output_file.iocb_ptr, " ^a ^a", comment_1_i, comment_2_i);

dcl  1 totals_i			aligned parm like totals;
dcl  comment_1_i			char (*) parm;
dcl  comment_2_i			char (*) parm;
     end PRINT_TOTAL_LINE;






PRINT_METERS_HEADER:
     proc (leading_letter_i);
	if leading_letter_i = " "
	then call ioa_$ioa_switch_nnl (output_file.iocb_ptr, "^24x");
	else call ioa_$ioa_switch_nnl (output_file.iocb_ptr, "    ^aREAL    ^aVCPU   ^aPF^[ LVCPU/CALL LVCPU%  CALLS^]",
		leading_letter_i, leading_letter_i, leading_letter_i, leading_letter_i = "L");

dcl  leading_letter_i		char parm;
     end PRINT_METERS_HEADER;







PRINT_METERS:
     proc (meters_i);
	if meters_i.real_time = 0 & meters_i.vcpu_time = 0 & meters_i.page_faults = 0
	then call PRINT_METERS_HEADER (" ");
	else call ioa_$ioa_switch_nnl (output_file.iocb_ptr, "^9.3f ^8.3f ^5d", float (meters_i.real_time, 27) * 1e-6,
		float (meters_i.vcpu_time, 27) * 1e-6, meters_i.page_faults);

dcl  1 meters_i			aligned parm like local_meters;
     end PRINT_METERS;




PRINT_STATS:
     proc (vcpu_time_i, calls_i);
	if vcpu_time_i = 0 | calls_i = 0
	then call ioa_$ioa_switch_nnl (output_file.iocb_ptr, " ^10x ^5x ^7d", calls_i);
	else call ioa_$ioa_switch_nnl (output_file.iocb_ptr, " ^10.6f ^5.1f ^7d",
		(float (vcpu_time_i, 27) / float (calls_i, 27)) * 1e-6,
		float (vcpu_time_i, 27) * percentage_coefficient.vcpu_time, calls_i);

dcl  vcpu_time_i			fixed bin (53) parm;
dcl  calls_i			fixed bin (53) parm;
     end PRINT_STATS;
%page;
/* START OF DECLARATIONS */
/* format: ^insnl,^delnl */


/* Parameters */


/* Automatic */

dcl  arg_count			fixed bin;
dcl  arg_idx			fixed bin;
dcl  arg_length			fixed bin (21);
dcl  arg_ptr			ptr init (null ());
dcl  code				fixed bin (35) init (0);
dcl  control_arg			char (32);
dcl  date_time_string		char (24);
dcl  in_trace_saved			bit (36) aligned;
dcl  long_format			bit aligned init ("1"b);
dcl  numeric_arg			fixed bin (35);
dcl  report			bit aligned init ("1"b);
dcl  reset			bit aligned init ("0"b);
dcl  transaction_id			fixed bin (71);
dcl  tt_count			fixed bin;
dcl  tt_idx			fixed bin;

dcl  1 local_meters			like meters aligned;
dcl  1 global_meters		like meters aligned;
dcl  1 metered			like meters aligned;

dcl  1 minimum			aligned,
       2 kind			char (8) init (""),
       2 percent			float bin (27) init (0);

dcl  1 output_file			aligned,
       2 iocb_ptr			ptr init (null ()),
       2 dir_path			char (168) unal init (""),
       2 entry_name			char (32) unal init ("");

dcl  1 percentage_coefficient		aligned,
       2 vcpu_time			float bin (27),
       2 page_faults		float bin (27);

dcl  1 totals			aligned,
       2 line_count			fixed bin,
       2 calls			fixed bin (53),
       2 meters			like meters;

dcl  1 subtotals			aligned like totals;

dcl  1 segment_being_subtotaled	aligned,
       2 seg_num			bit (18),
       2 dir_path			char (168) unal,
       2 entry_name			char (32) unal;


/* Static */

dcl  ME				char (32) static options (constant) init ("trace_meters");
dcl  ZERO				fixed bin (35) static options (constant) init (0);


/* Conditions */

dcl  cleanup			condition;


/* Based */

dcl  arg				char (arg_length) based (arg_ptr);


/* External Variables */

dcl  error_table_$badopt		fixed bin (35) ext;
dcl  iox_$user_output		ptr ext;


/* External Entries */

dcl  com_err_			entry () options (variable);
dcl  cu_$arg_count			entry (fixed bin, fixed bin (35));
dcl  cu_$arg_ptr			entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cv_dec_check_			entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  date_time_			entry (fixed bin (71), char (*));
dcl  expand_pathname_		entry (char (*), char (*), char (*), fixed bin (35));
dcl  expand_pathname_$add_suffix	entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  ioa_$ioa_switch		entry () options (variable);
dcl  ioa_$ioa_switch_nnl		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_$detach_iocb		entry (ptr, fixed bin (35));
dcl  iox_$open			entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  unique_chars_			entry (bit (*)) returns (char (15));


/* format: insnl,delnl */
/* END OF DECLARATIONS */
%page;
/* START OF INCLUDE FILES */


%page;
%include iox_modes;
%page;
%include trace_interface;

     end trace_meters;




		    trace_parameters_.pl1           10/23/84  1334.7rew 10/23/84  1219.1      269550



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/*
   This program stores and fetches trace parameters and global parameters.

   Written: May 1984 by Jeffrey D. Ives.
*/
/* format: style2,ifthendo,^indnoniterdo,thendo,^inditerdo,indproc,ind2,dclind5,idind32 */


trace_parameters_:
  procedure ();
    signal error;


/* INITIALIZE */

initialize:
  entry ();


    trace_catch_$global_parameters = INITIAL_GLOBAL_PARAMETERS;
    trace_catch_$global_parameters.osw = trace_$cv_stream_name_to_osw (INITIAL_GLOBAL_PARAMETERS.osw.stream_name);
    trace_catch_$global_parameters.spp =
         trace_$cv_entry_name_to_spp (INITIAL_GLOBAL_PARAMETERS.spp.entry_name, codeptr (trace_parameters_));
    trace_catch_$global_parameters.trace_routine = trace_print_$trace;
    trace_catch_$global_parameters.stop_routine = trace_print_$stop;

    trace_$global_parameters.version = "";

    allocate parameters in (trace_storage);
    parameters = INITIAL_PARAMETERS;
    call ASSIGN_PTR (trace_catch_$parameters_ptr, parameters_ptr);
    call ASSIGN_PTR (trace_$parameters_ptr, parameters_ptr);

    trace_catch_$global_parameters.calibrate = "1"b;

    call trace_calibrate_ ("recurse", trace_catch_$global_parameters.comps (COMPENSATION_FROM_ENTRY_TO_ENTRY),
         trace_catch_$global_parameters.comps (COMPENSATION_FROM_RETURN_TO_RETURN));

    call trace_calibrate_ ("repeat", trace_catch_$global_parameters.comps (COMPENSATION_FROM_ENTRY_TO_RETURN),
         trace_catch_$global_parameters.comps (COMPENSATION_FROM_RETURN_TO_ENTRY));

    trace_catch_$global_parameters.calibrate = "0"b;


    return;
%page;
/* TRANSACTIONS */

transaction_begin:
  entry (transaction_id_i);
    if trace_catch_$global_parameters.version ^= GLOBAL_PARAMETERS_VERSION_3
    then signal error;
    if trace_$global_parameters.version ^= ""
    then signal error;
    if trace_catch_$parameters_ptr -> parameters.version ^= PARAMETERS_VERSION_3
    then signal error;
    if trace_$parameters_ptr ^= trace_catch_$parameters_ptr
    then signal error;
    return;


transaction_begin_force:
transaction_end:
  entry (transaction_id_i);
    trace_$global_parameters.version = "";		/* This will show that they are not modified yet.	*/
    call ASSIGN_PTR (trace_$parameters_ptr, trace_catch_$parameters_ptr);
    return;


/* UPDATES */

update_default_parms:
  entry () returns (bit aligned);
    if OBJECTS_ARE_EQUAL (trace_catch_$parameters_ptr, trace_$parameters_ptr)
    then return ("0"b);
    call ASSIGN_PTR (trace_catch_$parameters_ptr, trace_$parameters_ptr);
    return ("1"b);


update_global_parms:
  entry () returns (bit aligned);
    if trace_$global_parameters.version = ""
    then return ("0"b);
    if trace_$global_parameters.version ^= GLOBAL_PARAMETERS_VERSION_3
    then signal error;
    if unspec (trace_$global_parameters) = unspec (trace_catch_$global_parameters)
    then return ("0"b);
    if trace_$global_parameters.osw.iocb_ptr ^= trace_catch_$global_parameters.osw.iocb_ptr
    then call trace_print_$copy_osw (trace_$global_parameters.osw, trace_catch_$global_parameters.osw);
    if trace_$global_parameters.buffer_ptr ^= trace_catch_$global_parameters.buffer_ptr
    then call trace_print_$copy_buffer_ptr (trace_$global_parameters.buffer_ptr,
	    trace_catch_$global_parameters.buffer_ptr);
    trace_catch_$global_parameters = trace_$global_parameters;
    return ("1"b);


free_parameters:
  entry (parms_ptr_io);
    call FREE_OBJECT (parms_ptr_io);
    return;


parms_specified:
  entry () returns (bit aligned);
    if OBJECTS_ARE_EQUAL (trace_catch_$parameters_ptr, trace_$parameters_ptr)
    then return ("0"b);
    else return ("1"b);


update_parameters:
  entry (parms_ptr_io) returns (bit aligned);
    if parms_ptr_io = trace_$parameters_ptr		/* Optimization. */
    then return ("0"b);
    if OBJECTS_ARE_EQUAL (parms_ptr_io, trace_$parameters_ptr)
    then return ("0"b);
    call ASSIGN_PTR (parms_ptr_io, trace_$parameters_ptr);
    return ("1"b);
%page;
/* TRACE PARAMETERS */


arguments:
  entry (tt_idx_i) returns (bit (2) aligned);
    tt_idx = tt_idx_i;
    if tt_idx < 0
    then parameters_ptr = trace_catch_$parameters_ptr;
    else parameters_ptr = trace_tables_$parameters_ptr (tt_idx);
    return (parameters.arguments);


set_arguments:
  entry (inout_i);
    parameters_ptr = MODIFIED_PARAMETERS_PTR ();
    parameters.arguments = inout_i;
    return;


call:
  entry (tt_idx_i) returns (char (256) var);
    tt_idx = tt_idx_i;
    if tt_idx < 0
    then parameters_ptr = trace_catch_$parameters_ptr;
    else parameters_ptr = trace_tables_$parameters_ptr (tt_idx);
    allocated_string_ptr = parameters.call_ptr;
    if allocated_string_ptr = null ()
    then return ("");
    else return (allocated_string.value);


set_call:
  entry (char256var_i);
    parameters_ptr = MODIFIED_PARAMETERS_PTR ();
    allocated_string_value_length = length (char256var_i);
    if allocated_string_value_length > 256
    then signal error;
    allocate allocated_string in (trace_storage);
    allocated_string.version = ALLOCATED_STRING_VERSION_3;
    allocated_string.reference_count = 0;
    allocated_string.value = char256var_i;
    call ASSIGN_PTR (parameters.call_ptr, allocated_string_ptr);
    return;


every:
  entry (tt_idx_i) returns (fixed bin (34));
    tt_idx = tt_idx_i;
    if tt_idx < 0
    then parameters_ptr = trace_catch_$parameters_ptr;
    else parameters_ptr = trace_tables_$parameters_ptr (tt_idx);
    return (parameters.every);


set_every:
  entry (number_i);
    parameters_ptr = MODIFIED_PARAMETERS_PTR ();
    parameters.every = number_i;
    return;


first:
  entry (tt_idx_i) returns (fixed bin (34));
    tt_idx = tt_idx_i;
    if tt_idx < 0
    then parameters_ptr = trace_catch_$parameters_ptr;
    else parameters_ptr = trace_tables_$parameters_ptr (tt_idx);
    return (parameters.first);


set_first:
  entry (number_i);
    parameters_ptr = MODIFIED_PARAMETERS_PTR ();
    parameters.first = number_i;
    return;


high:
  entry (tt_idx_i) returns (fixed bin (34));
    tt_idx = tt_idx_i;
    if tt_idx < 0
    then parameters_ptr = trace_catch_$parameters_ptr;
    else parameters_ptr = trace_tables_$parameters_ptr (tt_idx);
    return (parameters.high);


set_high:
  entry (number_i);
    parameters_ptr = MODIFIED_PARAMETERS_PTR ();
    parameters.high = number_i;
    return;


last:
  entry (tt_idx_i) returns (fixed bin (34));
    tt_idx = tt_idx_i;
    if tt_idx < 0
    then parameters_ptr = trace_catch_$parameters_ptr;
    else parameters_ptr = trace_tables_$parameters_ptr (tt_idx);
    return (parameters.last);


set_last:
  entry (number_i);
    parameters_ptr = MODIFIED_PARAMETERS_PTR ();
    parameters.last = number_i;
    return;


low:
  entry (tt_idx_i) returns (fixed bin (34));
    tt_idx = tt_idx_i;
    if tt_idx < 0
    then parameters_ptr = trace_catch_$parameters_ptr;
    else parameters_ptr = trace_tables_$parameters_ptr (tt_idx);
    return (parameters.low);


set_low:
  entry (number_i);
    parameters_ptr = MODIFIED_PARAMETERS_PTR ();
    parameters.low = number_i;
    return;


new_high:
  entry (tt_idx_i) returns (bit aligned);
    tt_idx = tt_idx_i;
    if tt_idx < 0
    then parameters_ptr = trace_catch_$parameters_ptr;
    else parameters_ptr = trace_tables_$parameters_ptr (tt_idx);
    return (parameters.new_high);


set_new_high:
  entry (onoff_i);
    parameters_ptr = MODIFIED_PARAMETERS_PTR ();
    parameters.new_high = onoff_i;
    return;


parms_string:
  entry (tt_idx_i, just_differences_i) returns (char (256) var);
    tt_idx = tt_idx_i;
    if tt_idx < 0
    then parameters_ptr = trace_catch_$parameters_ptr;
    else parameters_ptr = trace_tables_$parameters_ptr (tt_idx);
    return (MAKE_PARAMETERS_STRING (parameters_ptr, trace_catch_$parameters_ptr, just_differences_i));


stop:
  entry (tt_idx_i) returns (bit (2) aligned);
    tt_idx = tt_idx_i;
    if tt_idx < 0
    then parameters_ptr = trace_catch_$parameters_ptr;
    else parameters_ptr = trace_tables_$parameters_ptr (tt_idx);
    return (parameters.stop);


set_stop:
  entry (inout_i);
    parameters_ptr = MODIFIED_PARAMETERS_PTR ();
    parameters.stop = inout_i;
    return;


stop_every:
  entry (tt_idx_i) returns (fixed bin (34));
    tt_idx = tt_idx_i;
    if tt_idx < 0
    then parameters_ptr = trace_catch_$parameters_ptr;
    else parameters_ptr = trace_tables_$parameters_ptr (tt_idx);
    return (parameters.stop_every);


set_stop_every:
  entry (number_i);
    parameters_ptr = MODIFIED_PARAMETERS_PTR ();
    parameters.stop_every = number_i;
    return;


stop_low:
  entry (tt_idx_i) returns (fixed bin (34));
    tt_idx = tt_idx_i;
    if tt_idx < 0
    then parameters_ptr = trace_catch_$parameters_ptr;
    else parameters_ptr = trace_tables_$parameters_ptr (tt_idx);
    return (parameters.stop_low);


set_stop_low:
  entry (number_i);
    parameters_ptr = MODIFIED_PARAMETERS_PTR ();
    parameters.stop_low = number_i;
    return;


trace:
  entry (tt_idx_i) returns (bit (2) aligned);
    tt_idx = tt_idx_i;
    if tt_idx < 0
    then parameters_ptr = trace_catch_$parameters_ptr;
    else parameters_ptr = trace_tables_$parameters_ptr (tt_idx);
    return (parameters.trace);


set_trace:
  entry (inout_i);
    parameters_ptr = MODIFIED_PARAMETERS_PTR ();
    parameters.trace = inout_i;
    return;
%page;
/* GLOBAL PARAMETERS */

alm:
  entry () returns (bit aligned);
    return (trace_catch_$global_parameters.alm);


set_alm:
  entry (onoff_i);
    if trace_$global_parameters.version = ""
    then trace_$global_parameters = trace_catch_$global_parameters;
    trace_$global_parameters.alm = onoff_i;
    return;


automatic:
  entry () returns (bit aligned);
    return (trace_catch_$global_parameters.automatic);


set_automatic:
  entry (onoff_i);
    if trace_$global_parameters.version = ""
    then trace_$global_parameters = trace_catch_$global_parameters;
    trace_$global_parameters.automatic = onoff_i;
    return;


buffer:
  entry () returns (bit aligned);
    return (trace_catch_$global_parameters.buffer_ptr ^= null ());


buffer_ptr:
  entry () returns (ptr unal);
    return (trace_catch_$global_parameters.buffer_ptr);


set_buffer:
  entry (onoff_i);
    if trace_$global_parameters.version = ""
    then trace_$global_parameters = trace_catch_$global_parameters;
    if onoff_i = "1"b
    then call trace_print_$allocate_buffer (trace_$global_parameters.buffer_ptr);
    else trace_$global_parameters.buffer_ptr = null ();
    return;


calibrate:
  entry () returns (bit aligned);
    return (trace_catch_$global_parameters.calibrate);


set_calibrate:
  entry (onoff_i);
    if trace_$global_parameters.version = ""
    then trace_$global_parameters = trace_catch_$global_parameters;
    trace_$global_parameters.calibrate = onoff_i;
    return;


compensation:
  entry (compensation_idx_i) returns (1 aligned like compensation);
    compensation_idx = compensation_idx_i;
    if compensation_idx < lbound (trace_catch_$global_parameters.comps, 1)
         | compensation_idx > hbound (trace_catch_$global_parameters.comps, 1)
    then signal error;
    return (trace_catch_$global_parameters.comps (compensation_idx));


set_compensation:
  entry (compensation_idx_i, compensation_i);
    compensation_idx = compensation_idx_i;
    if trace_$global_parameters.version = ""
    then trace_$global_parameters = trace_catch_$global_parameters;
    if compensation_idx < lbound (trace_$global_parameters.comps, 1)
         | compensation_idx > hbound (trace_$global_parameters.comps, 1)
    then signal error;
    trace_$global_parameters.comps (compensation_idx) = compensation_i;
    return;


enabled:
  entry () returns (bit aligned);
    return (trace_catch_$global_parameters.enabled);


set_enabled:
  entry (onoff_i);
    if trace_$global_parameters.version = ""
    then trace_$global_parameters = trace_catch_$global_parameters;
    trace_$global_parameters.enabled = onoff_i;
    return;


global_parms_changed:
  entry () returns (bit aligned);
    if trace_$global_parameters.version = GLOBAL_PARAMETERS_VERSION_3
    then return ("1"b);
    else return ("0"b);


global_parms_string:
  entry () returns (char (256) var);
    return (MAKE_GLOBAL_PARAMETERS_STRING (trace_catch_$global_parameters));


long:
  entry () returns (bit aligned);
    return (trace_catch_$global_parameters.long);


set_long:
  entry (onoff_i);
    if trace_$global_parameters.version = ""
    then trace_$global_parameters = trace_catch_$global_parameters;
    trace_$global_parameters.long = onoff_i;
    return;


loud:
  entry () returns (bit aligned);
    return (trace_catch_$global_parameters.loud);


set_loud:
  entry (onoff_i);
    if trace_$global_parameters.version = ""
    then trace_$global_parameters = trace_catch_$global_parameters;
    trace_$global_parameters.loud = onoff_i;
    return;


meter:
  entry () returns (bit aligned);
    return (trace_catch_$global_parameters.meter);


set_meter:
  entry (onoff_i);
    if trace_$global_parameters.version = ""
    then trace_$global_parameters = trace_catch_$global_parameters;
    trace_$global_parameters.meter = onoff_i;
    return;


output_switch:
  entry () returns (1 like output_switch);
    return (trace_catch_$global_parameters.osw);


set_output_switch:
  entry (output_switch_i);
    if trace_$global_parameters.version = ""
    then trace_$global_parameters = trace_catch_$global_parameters;
    trace_$global_parameters.osw = output_switch_i;
    if trace_$global_parameters.osw.iocb_ptr = null ()
    then trace_$global_parameters.osw = trace_$cv_stream_name_to_osw (INITIAL_GLOBAL_PARAMETERS.osw.stream_name);
    return;


signals:
  entry () returns (bit aligned);
    return (trace_catch_$global_parameters.signals);


set_signals:
  entry (onoff_i);
    if trace_$global_parameters.version = ""
    then trace_$global_parameters = trace_catch_$global_parameters;
    trace_$global_parameters.signals = onoff_i;
    return;


stop_proc:
  entry () returns (1 like stop_proc aligned);
    return (trace_catch_$global_parameters.spp);


set_stop_proc:
  entry (stop_proc_i);
    if trace_$global_parameters.version = ""
    then trace_$global_parameters = trace_catch_$global_parameters;
    trace_$global_parameters.spp = stop_proc_i;
    if codeptr (trace_$global_parameters.spp.entry_value) = null ()
    then trace_$global_parameters.spp =
	    trace_$cv_entry_name_to_spp (INITIAL_GLOBAL_PARAMETERS.spp.entry_name, codeptr (trace_parameters_));
    return;


trace_routine:
  entry () returns (entry);
    return (trace_catch_$global_parameters.trace_routine);


set_trace_routine:
  entry (entrypoint_i);
    if trace_$global_parameters.version = ""
    then trace_$global_parameters = trace_catch_$global_parameters;
    trace_$global_parameters.trace_routine = entrypoint_i;
    return;


stop_routine:
  entry () returns (entry);
    return (trace_catch_$global_parameters.stop_routine);


set_stop_routine:
  entry (entrypoint_i);
    if trace_$global_parameters.version = ""
    then trace_$global_parameters = trace_catch_$global_parameters;
    trace_$global_parameters.stop_routine = entrypoint_i;
    return;
%page;
/* SUBROUTINES */


ASSIGN_PTR:
  proc (destination_ptr_io, source_ptr_i);
    dcl  (destination_ptr_io, source_ptr_i)
				 ptr unal parm;
    dcl  goner_ptr			 ptr unal;

    if destination_ptr_io = source_ptr_i
    then return;
    goner_ptr = destination_ptr_io;
    if source_ptr_i ^= null ()
    then source_ptr_i -> allocated_string.reference_count = source_ptr_i -> allocated_string.reference_count + 1;
    destination_ptr_io = source_ptr_i;
    call FREE_OBJECT (goner_ptr);
  end ASSIGN_PTR;


MODIFIED_PARAMETERS_PTR:
  proc () returns (ptr unal);
    dcl  p			 ptr unal;
    if trace_$parameters_ptr = trace_catch_$parameters_ptr
    then do;
      allocate parameters in (trace_storage) set (p);
      p -> parameters = trace_catch_$parameters_ptr -> parameters;
      p -> parameters.reference_count = 0;
      p -> parameters.call_ptr = null ();
      call ASSIGN_PTR (p -> parameters.call_ptr, trace_catch_$parameters_ptr -> parameters.call_ptr);
      call ASSIGN_PTR (trace_$parameters_ptr, p);
    end;
    return (trace_$parameters_ptr);
  end MODIFIED_PARAMETERS_PTR;


FREE_OBJECT:
  proc (object_ptr_io);
    dcl  object_ptr_io		 ptr unal parm;
    dcl  object_ptr			 ptr unal;

    object_ptr = object_ptr_io;
    if object_ptr = null ()
    then return;
    object_ptr_io = null ();
    object_ptr -> allocated_string.reference_count = object_ptr -> allocated_string.reference_count - 1;
    if object_ptr -> allocated_string.reference_count > 0
    then return;
    if object_ptr -> allocated_string.reference_count < 0
    then signal error;
    if object_ptr -> allocated_string.version = ALLOCATED_STRING_VERSION_3
    then ;
    else if object_ptr -> allocated_string.version = PARAMETERS_VERSION_3
    then call FREE_OBJECT (object_ptr -> parameters.call_ptr);
    else signal error;
    free object_ptr -> allocated_string;
    return;
  end FREE_OBJECT;


OBJECTS_ARE_EQUAL:
  proc (A_ptr_io, B_ptr_io) returns (bit aligned);
    dcl  (A_ptr_io, B_ptr_io)		 ptr unal parm;

    if A_ptr_io = B_ptr_io
    then return ("1"b);
    if A_ptr_io = null () | B_ptr_io = null ()
    then return ("0"b);
    if A_ptr_io -> allocated_string.version ^= B_ptr_io -> allocated_string.version
    then signal error;
    if A_ptr_io -> allocated_string.version = ALLOCATED_STRING_VERSION_3
    then do;
      if A_ptr_io -> allocated_string.value_length ^= B_ptr_io -> allocated_string.value_length
      then return ("0"b);
      if A_ptr_io -> allocated_string.value ^= B_ptr_io -> allocated_string.value
      then return ("0"b);
    end;
    else if A_ptr_io -> allocated_string.version = PARAMETERS_VERSION_3
    then do;
      if ^OBJECTS_ARE_EQUAL (A_ptr_io -> parameters.call_ptr, B_ptr_io -> parameters.call_ptr)
      then return ("0"b);
      if unspec (A_ptr_io -> parameters) ^= unspec (B_ptr_io -> parameters)
      then return ("0"b);
    end;
    else signal error;				/* Combine them. */
    if A_ptr_io -> allocated_string.reference_count <= B_ptr_io -> allocated_string.reference_count
    then call ASSIGN_PTR (A_ptr_io, B_ptr_io);
    else call ASSIGN_PTR (B_ptr_io, A_ptr_io);
    return ("1"b);
  end OBJECTS_ARE_EQUAL;
%page;
MAKE_PARAMETERS_STRING:
  proc (A_parms_ptr_i, B_parms_ptr_i, just_differences_i) returns (char (256) var);
    if A_parms_ptr_i = null ()
    then return ("no parms");
    if A_parms_i.version ^= PARAMETERS_VERSION_3 | B_parms_i.version ^= PARAMETERS_VERSION_3
    then signal error;
    just_differences = just_differences_i;
    many_parm_string = "";

    call APPEND_INOUT_PARAMETER (A_parms_i.trace, B_parms_i.trace, "trace");
    call APPEND_N_PARAMETER (A_parms_i.every, B_parms_i.every, "every");
    call APPEND_N_PARAMETER (A_parms_i.first, B_parms_i.first, "first");
    call APPEND_N_PARAMETER (A_parms_i.last, B_parms_i.last, "last");
    call APPEND_N_PARAMETER (A_parms_i.low, B_parms_i.low, "low");
    call APPEND_N_PARAMETER (A_parms_i.high, B_parms_i.high, "high");
    call APPEND_ONOFF_PARAMETER (A_parms_i.new_high, B_parms_i.new_high, "new_high");

    call APPEND_INOUT_PARAMETER (A_parms_i.stop, B_parms_i.stop, "stop");
    call APPEND_N_PARAMETER (A_parms_i.stop_every, B_parms_i.stop_every, "stop_every");
    call APPEND_N_PARAMETER (A_parms_i.stop_low, B_parms_i.stop_low, "stop_low");

    call APPEND_INOUT_PARAMETER (A_parms_i.arguments, B_parms_i.arguments, "arguments");
    if A_parms_i.call_ptr = null ()
    then A_as_ptr = addr (NULL_ALLOCATED_STRING);
    else A_as_ptr = A_parms_i.call_ptr;
    if B_parms_i.call_ptr = null ()
    then B_as_ptr = addr (NULL_ALLOCATED_STRING);
    else B_as_ptr = B_parms_i.call_ptr;
    call APPEND_CHAR_PARAMETER ((A_as_ptr -> allocated_string.value), (B_as_ptr -> allocated_string.value), "call");

    return (many_parm_string);


MAKE_GLOBAL_PARAMETERS_STRING:
  entry (global_parms_i) returns (char (256) var);
    if global_parms_i.version ^= GLOBAL_PARAMETERS_VERSION_3
    then signal error;
    many_parm_string = "";
    just_differences = "0"b;
    call APPEND_ONOFF_PARAMETER (global_parms_i.alm, "0"b, "alm");
    call APPEND_ONOFF_PARAMETER (global_parms_i.automatic, "0"b, "automatic");
    call APPEND_ONOFF_PARAMETER (global_parms_i.buffer_ptr ^= null (), "0"b, "buffer");
    call APPEND_ONOFF_PARAMETER (global_parms_i.meter, "0"b, "meter");
    call APPEND_ONOFF_PARAMETER (global_parms_i.signals, "0"b, "signals");
    call APPEND_ONOFF_ALT_PARAMETER (global_parms_i.enabled, "0"b, "disable", "enable");
    call APPEND_ONOFF_ALT_PARAMETER (global_parms_i.long, "0"b, "brief", "long");
    call APPEND_ONOFF_ALT_PARAMETER (global_parms_i.loud, "0"b, "quiet", "loud");
    if global_parms_i.osw.file_path = ""
    then call APPEND_CHAR_PARAMETER ((global_parms_i.osw.stream_name), "", "output_switch");
    else call APPEND_CHAR_PARAMETER (global_parms_i.osw.file_path, "", "output_file");
    call APPEND_CHAR_PARAMETER (global_parms_i.spp.entry_name, "", "stop_proc");

    return (many_parm_string);

/* declarations */
    dcl  A_parms_ptr_i		 ptr unal parm;
    dcl  1 A_parms_i		 like parameters aligned based (A_parms_ptr_i);
    dcl  B_parms_ptr_i		 ptr unal parm;
    dcl  1 B_parms_i		 like parameters aligned based (B_parms_ptr_i);
    dcl  1 global_parms_i		 like trace_catch_$global_parameters aligned parm;
    dcl  just_differences_i		 bit aligned parm;
    dcl  A_as_ptr			 ptr;
    dcl  B_as_ptr			 ptr;
    dcl  just_differences		 bit aligned;
    dcl  many_parm_string		 char (256) var;

APPEND_N_PARAMETER:
    proc (A_n_i, B_n_i, control_arg_name_i);
      dcl	 A_n_i			   fixed bin (34) parm;
      dcl	 B_n_i			   fixed bin (34) parm;
      if just_differences & A_n_i = B_n_i
      then return;
      if A_n_i = 0
      then one_parm_string = "-no_" || control_arg_name_i;
      else call ioa_$rsnnl ("-^a ^d", one_parm_string, one_parm_length, control_arg_name_i, A_n_i);
      go to APPEND_STRING;

APPEND_ONOFF_PARAMETER:
    entry (A_onoff_i, B_onoff_i, control_arg_name_i);
      dcl	 A_onoff_i		   bit aligned parm;
      dcl	 B_onoff_i		   bit aligned parm;
      if just_differences & A_onoff_i = B_onoff_i
      then return;
      if A_onoff_i = "0"b
      then one_parm_string = "-" || control_arg_name_i || " off";
      else one_parm_string = "-" || control_arg_name_i || " on";
      go to APPEND_STRING;

APPEND_ONOFF_ALT_PARAMETER:
    entry (A_onoff_i, B_onoff_i, control_arg_name_i, alt_control_arg_name_i);
      if just_differences & A_onoff_i = B_onoff_i
      then return;
      if A_onoff_i = "0"b
      then one_parm_string = "-" || control_arg_name_i;
      else one_parm_string = "-" || alt_control_arg_name_i;
      go to APPEND_STRING;

APPEND_INOUT_PARAMETER:
    entry (A_inout_i, B_inout_i, control_arg_name_i);
      dcl	 A_inout_i		   bit (2) aligned parm;
      dcl	 B_inout_i		   bit (2) aligned parm;
      if just_differences & A_inout_i = B_inout_i
      then return;
      call ioa_$rsnnl ("-^a ^a", one_parm_string, one_parm_length, control_arg_name_i,
	 trace_$cv_bits_to_inout (A_inout_i));
      go to APPEND_STRING;

APPEND_CHAR_PARAMETER:
    entry (A_char256var_i, B_char256var_i, control_arg_name_i);
      dcl	 A_char256var_i		   char (256) var parm;
      dcl	 B_char256var_i		   char (256) var parm;
      if just_differences & A_char256var_i = B_char256var_i
      then return;
      if length (A_char256var_i) = 0
      then one_parm_string = "-no_" || control_arg_name_i;
      else if search (A_char256var_i, " ") = 0
      then call ioa_$rsnnl ("-^a ^a", one_parm_string, one_parm_length, control_arg_name_i, A_char256var_i);
      else call ioa_$rsnnl ("-^a ""^a""", one_parm_string, one_parm_length, control_arg_name_i, A_char256var_i);
      go to APPEND_STRING;

APPEND_STRING:
      if length (many_parm_string) > 0
      then
(nostrz):
        many_parm_string = many_parm_string || " ";
(nostrz):
      many_parm_string = many_parm_string || one_parm_string;
      return;

      dcl	 control_arg_name_i		   char (16) var parm;
      dcl	 alt_control_arg_name_i	   char (16) var parm;
      dcl	 one_parm_length		   fixed bin (21);
      dcl	 one_parm_string		   char (256) var;
    end APPEND_N_PARAMETER;
  end MAKE_PARAMETERS_STRING;
%page;
/* START OF DECLARATIONS */
/* format: ^insnl,^delnl */

/* Parameters */

    dcl  char256var_i		 char (256) var parm;
    dcl  compensation_idx_i		 fixed bin parm;
    dcl  entrypoint_i		 entry parm;
    dcl  inout_i			 bit (2) aligned parm;
    dcl  just_differences_i		 bit aligned parm;
    dcl  number_i			 fixed bin (34) parm;
    dcl  onoff_i			 bit aligned parm;
    dcl  parms_ptr_io		 ptr unal parm;
    dcl  transaction_id_i		 fixed bin (71) parm;
    dcl  tt_idx_i			 fixed bin parm;
    dcl  1 compensation_i		 aligned like compensation;
    dcl  1 output_switch_i		 like output_switch aligned parm;
    dcl  1 stop_proc_i		 like stop_proc aligned parm;


/* Automatic */

    dcl  compensation_idx		 fixed bin;
    dcl  tt_idx			 fixed bin;


/* Static */

    dcl  ZERO			 fixed bin (35) static options (constant) init (0);

    dcl  1 NULL_ALLOCATED_STRING	 aligned static options (constant),
	 2 version		 char (8) init ("TraceAS3"),
	 2 reference_count		 fixed bin init (0),
	 2 value_length		 fixed bin init (0),
	 2 value			 char (0) unal;

    dcl  1 INITIAL_GLOBAL_PARAMETERS	 aligned static options (constant),
	 2 version		 char (8) init ("TraceGP3"),
	 2 alm			 bit init ("0"b),	/* off */
	 2 automatic		 bit init ("0"b),	/* off */
	 2 meter			 bit init ("0"b),	/* off */
	 2 signals		 bit init ("0"b),	/* off */
	 2 enabled		 bit init ("1"b),	/* on  */
	 2 long			 bit init ("0"b),	/* off */
	 2 osw,
	   3 iocb_ptr		 ptr,
	   3 stream_name		 char (32) var init ("user_output"),
	   3 file_path		 char (256) var init (""),
	 2 spp,
	   3 entry_value		 entry (),
	   3 entry_name		 char (256) var init ("cu_$cl"),
	 2 trace_routine		 entry,
	 2 stop_routine		 entry,
	 2 loud			 bit init ("1"b),	/* on  */
	 2 calibrate		 bit init ("0"b),	/* off */
	 2 buffer_ptr		 ptr unal init (null ()),
	 2 not_used		 fixed bin init (0),
	 2 comps			 (4),
	   3 real_time		 fixed bin (53) init (0, 0, 0, 0),
	   3 vcpu_time		 fixed bin (53) init (0, 0, 0, 0);

    dcl  1 INITIAL_PARAMETERS		 aligned static options (constant),
	 2 version		 char (8) init ("TraceTP3"),
	 2 reference_count		 fixed bin init (0),
	 2 every			 fixed bin (34) init (0),
	 2 first			 fixed bin (34) init (0),
	 2 last			 fixed bin (34) init (0),
	 2 low			 fixed bin (34) init (0),
	 2 high			 fixed bin (34) init (0),
	 2 new_high		 bit init ("0"b),
	 2 arguments		 bit (2) init ("00"b),
	 2 not_used1		 bit init ("0"b),
	 2 stop_every		 fixed bin (34) init (0),
	 2 stop_low		 fixed bin (34) init (0),
	 2 stop			 bit (2) init ("00"b),
	 2 trace			 bit (2) init ("11"b),
	 2 call_ptr		 ptr unal init (null ());


/* Conditions */

    dcl  error			 condition;


/* Based */

    dcl  trace_storage		 area based (trace_catch_$trace_storage_ptr);


    dcl  PARAMETERS_VERSION_3		 char (8) aligned static options (constant) init ("TraceTP3");
    dcl  parameters_ptr		 ptr unal;
    dcl  1 parameters		 aligned based (parameters_ptr),
	 2 version		 char (8),
	 2 reference_count		 fixed bin,
	 2 every			 fixed bin (34),
	 2 first			 fixed bin (34),
	 2 last			 fixed bin (34),
	 2 low			 fixed bin (34),
	 2 high			 fixed bin (34),
	 2 new_high		 bit,
	 2 arguments		 bit (2),
	 2 not_used1		 bit,
	 2 stop_every		 fixed bin (34),
	 2 stop_low		 fixed bin (34),
	 2 stop			 bit (2),
	 2 trace			 bit (2),
	 2 call_ptr		 ptr unal;


    dcl  ALLOCATED_STRING_VERSION_3	 char (8) aligned static options (constant) init ("TraceAS3");
    dcl  allocated_string_value_length	 fixed bin;
    dcl  allocated_string_ptr		 ptr unal;
    dcl  1 allocated_string		 aligned based (allocated_string_ptr),
	 2 version		 char (8),
	 2 reference_count		 fixed bin,
	 2 value_length		 fixed bin,
	 2 value			 char (allocated_string_value_length refer (allocated_string.value_length)) unal;


/* External Variables */

    dcl  trace_$parameters_ptr	 ptr unal ext;
    dcl  1 trace_$global_parameters	 like trace_catch_$global_parameters aligned ext;

    dcl  trace_catch_$trace_storage_ptr	 ptr ext;
    dcl  trace_catch_$parameters_ptr	 ptr unal ext;


    dcl  GLOBAL_PARAMETERS_VERSION_3	 char (8) aligned static options (constant) init ("TraceGP3");
    dcl  1 trace_catch_$global_parameters aligned ext,
	 2 version		 char (8),
	 2 alm			 bit,
	 2 automatic		 bit,
	 2 meter			 bit,
	 2 signals		 bit,
	 2 enabled		 bit,
	 2 long			 bit,
	 2 osw			 like output_switch,
	 2 spp			 like stop_proc,
	 2 trace_routine		 entry,
	 2 stop_routine		 entry,
	 2 loud			 bit,
	 2 calibrate		 bit,
	 2 buffer_ptr		 ptr unal,
	 2 not_used		 fixed bin,
	 2 comps			 (4) like compensation;


/* External Entries */

    dcl  ioa_$rsnnl			 entry options (variable);
    dcl  trace_calibrate_		 entry (char (8) aligned, 1 like compensation aligned, 1 like compensation aligned);
    dcl  trace_print_$copy_osw	 entry (1 like output_switch aligned, 1 like output_switch aligned);
    dcl  trace_tables_$parameters_ptr	 entry (fixed bin) returns (ptr);
    dcl  trace_print_$allocate_buffer	 entry (ptr unal);
    dcl  trace_print_$copy_buffer_ptr	 entry (ptr unal, ptr unal);
    dcl  trace_print_$stop		 entry (fixed bin, fixed bin (53));
    dcl  trace_print_$trace		 entry (fixed bin, fixed bin (53));


/* format: insnl,delnl */
/* END OF DECLARATIONS */
%page;
/* START OF INCLUDE FILES */


%include trace_interface;

  end trace_parameters_;




		    trace_print_.pl1                10/24/88  1638.0r w 10/24/88  1400.1      217116



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

/*
   This program is called by trace_catch_ when the trace or stop conditions are satisfied.
   When called to trace, it formats and writes a trace message and executes a command line if required.
   When called to stop, it prints a stop message and checks the watch table.

   Initial Version: 25 February 1969 by BLW.
   Modified:  December 1974 by S.E. Barr.
   Modified:  1 May 1975 by RAB for -return_value.
   Modified:  Apr 1982 by Jeffrey D. Ives to use ioa_$ioa_switch for efficiency (instead of ioa_$ioa_stream).
   Modified:  July 1983 by Jeffrey D. Ives for multitasking and to trace unwinds and signals.
   Modified:  May 1984 by Jeffrey D. Ives for new trace interface and to separate trace and stop.
*/

/* format: style2,ifthendo,^indnoniterdo,thendo,^inditerdo,indproc,ind2,dclind5,idind32 */

trace_print_:
  proc ();
    signal error;
%page;
trace:
  entry (event_i);

    event_ptr = addr (event_i);
    if event.version ^= EVENT_VERSION_3
    then signal error;
    clock_reading = clock ();

    if event.kind = "ca"
    then
TRACE_CALL:
      do;
        if ^trace_$long ()
        then char256var = trace_$entrypoint_name (event.entry_idx);
        else do;
	call hcs_$fs_get_path_name ((event.return_ptr), dir_path, bname_length, entry_name, code);
	if code ^= 0
	then do;
	  call
	    ioa_$rsnnl ("^a from ^p", char256var, return_string_length, trace_$entrypoint_name (event.entry_idx),
	    event.return_ptr);
	end;
	else do;
	  call pl1_frame_$name ((event.callers_sp), bname_ptr, bname_length);

	  call interpret_bind_map_ ((event.return_ptr), cname, offset, code);
	  if code ^= 0
	  then do;
	    cname = entry_name;
	    offset = bin (rel (event.return_ptr), 18);
	  end;

	  if bname_ptr ^= null ()
	  then if cname = bname
	       then bname_ptr = null ();

	  if bname_ptr = null ()
	  then call
	         ioa_$rsnnl ("^a from ^a", char256var, return_string_length, trace_$entrypoint_name (event.entry_idx),
	         cname);
	  else call
	         ioa_$rsnnl ("^a from ^a$^a", char256var, return_string_length,
	         trace_$entrypoint_name (event.entry_idx), cname, bname);
	end;
        end;
      end TRACE_CALL;
    else if event.kind = "re"
    then char256var = trace_$entrypoint_name (event.entry_idx);
    else if event.kind = "un"
    then char256var = trace_$entrypoint_name (event.entry_idx) || " unwound";
    else if event.kind = "si"
    then
TRACE_SIGNAL:
      do;
        if event.arg_list_ptr -> arg_list.header.call_type ^= Interseg_call_type
        then char256var = "The signal_ routine has been called without an intersegment argument list.";
        else if event.arg_list_ptr -> arg_list.header.arg_count < 1
        then char256var = "The signal_ routine has been called without arguments.";
        else if event.arg_list_ptr -> arg_list.header.desc_count < 1
        then char256var = "The signal_ routine has been called without argument descriptors.";
        else if event.arg_list_ptr -> arg_list.desc_ptrs (1) -> arg_descriptor.type ^= char_dtype
        then char256var = "The first argument to signal_ is not a non-varying character string.";
        else do;
	bname_ptr = event.arg_list_ptr -> arg_list.arg_ptrs (1);
	bname_length = event.arg_list_ptr -> arg_list.desc_ptrs (1) -> arg_descriptor.size;

	call interpret_bind_map_ ((event.return_ptr), cname, offset, code);
	if code ^= 0
	then char256var = bname;
	else call ioa_$rsnnl ("^a from ^a|^o", char256var, return_string_length, bname, cname, offset);

	char256var = char256var || SIGNAL_PTR_STRING (2, "machine conditions");
	char256var = char256var || SIGNAL_PTR_STRING (3, "info");
	char256var = char256var || SIGNAL_PTR_STRING (4, "crawlout machine conditions");
        end;

SIGNAL_PTR_STRING:
  proc (arg_list_idx_i, ptr_name_i) returns (char (256) var);
    dcl  arg_list_idx_i		 fixed bin parm;
    dcl  ptr_name_i			 char (*) parm;
    dcl  return_string_length		 fixed bin;
    dcl  signal_ptr_string		 char (256) var;

    if event.arg_list_ptr -> arg_list.header.arg_count < arg_list_idx_i
    then signal_ptr_string = "";
    else if event.arg_list_ptr -> arg_list.header.desc_count < arg_list_idx_i
    then signal_ptr_string = "";
    else if event.arg_list_ptr -> arg_list.desc_ptrs (arg_list_idx_i) -> arg_descriptor.type ^= pointer_dtype
    then call
	 ioa_$rsnnl ("The ^a ptr argument to signal_ is not an aligned pointer", signal_ptr_string,
	 return_string_length, ptr_name_i);
    else if event.arg_list_ptr -> arg_list.arg_ptrs (arg_list_idx_i) -> based_ptr = null ()
    then signal_ptr_string = "";
    else if ptr_name_i = "info"
    then
      begin;
      dcl	 short_message		   char (8) aligned;
      dcl	 long_message		   char (100) aligned;
      dcl	 convert_status_code_	   entry (fixed bin (35), char (8) aligned, char (100) aligned);
%include condition_info_header;
      condition_info_header_ptr = event.arg_list_ptr -> arg_list.arg_ptrs (arg_list_idx_i) -> based_ptr;
      if condition_info_header.version ^= 1
      then call
	   ioa_$rsnnl ("  ^a at ^p (condition_info_header.version = ^d)", signal_ptr_string, return_string_length,
	   ptr_name_i, condition_info_header_ptr, condition_info_header.version);
      else do;
        if condition_info_header.status_code = 0
        then long_message = "";
        else call convert_status_code_ (condition_info_header.status_code, short_message, long_message);
        call
	ioa_$rsnnl ("  ^a:  ^a  ^a", signal_ptr_string, return_string_length, ptr_name_i, long_message,
	condition_info_header.info_string);
      end;
    end;
    else call
	 ioa_$rsnnl ("  ^a at ^p", signal_ptr_string, return_string_length, ptr_name_i,
	 event.arg_list_ptr -> arg_list.arg_ptrs (arg_list_idx_i) -> based_ptr);

    return (signal_ptr_string);

  end SIGNAL_PTR_STRING;

      end TRACE_SIGNAL;
    else call ioa_$rsnnl ("Unknown  trace event ""^a""", char256var, return_string_length, event.kind);

/* 
 CLOCK TIME    REAL SEC   VCPU SEC  PF    CALL# RECURSION/HIGHEST   ENTRYPOINT
19:01:00.460   0.000156   0.000156   0<-      1 1/1 wioctl_$control
*/

    osw = trace_$output_switch ();

    if trace_$long ()
    then do;
      if osw.iocb_ptr ^= LAST_OSW_IOCB_PTR_THAT_A_TRACE_MESSAGE_WAS_WRITTEN_TO
      then call
	   ioa_$ioa_switch (osw.iocb_ptr, "^12a ^25a ^a^13a ^a", " CLOCK TIME ", METERS_STRING_HEADER (),
	   DOTS_STRING (event.frame_count), COUNTS_STRING_HEADER (), "  ENTRYPOINT");
      call
        ioa_$ioa_switch (osw.iocb_ptr, "^12a ^25a ^a^13a ^a", trace_time_ (clock_reading),
        METERS_STRING (event.kind, event.frame), DOTS_STRING (event.frame_count), COUNTS_STRING (event.kind, event.saved),
        char256var);
    end;
    else do;
      if osw.iocb_ptr ^= LAST_OSW_IOCB_PTR_THAT_A_TRACE_MESSAGE_WAS_WRITTEN_TO
      then call
	   ioa_$ioa_switch (osw.iocb_ptr, "^a^13a ^a", DOTS_STRING (event.frame_count), COUNTS_STRING_HEADER (),
	   "  ENTRYPOINT");
      call
        ioa_$ioa_switch (osw.iocb_ptr, "^a^13a ^a", DOTS_STRING (event.frame_count),
        COUNTS_STRING (event.kind, event.saved), char256var);
    end;
    LAST_OSW_IOCB_PTR_THAT_A_TRACE_MESSAGE_WAS_WRITTEN_TO = osw.iocb_ptr;

    if event.kind = "ca" | event.kind = "re"
    then
DISPLAY_ARGUMENT_LIST_AND_CALL_CP:
      begin;
        dcl  indentation	     fixed bin;
        dcl  first_arg_to_print	     fixed bin;
        dcl  last_arg_to_print	     fixed bin;
        dcl  1 display_args_at	     aligned,
	     2 call		     bit unal,
	     2 return		     bit unal;
        dcl  cu_$cp			     entry (ptr, fixed bin (21), fixed bin (35));
        dcl  display_argument_list_	     entry (ptr, ptr, ptr, ptr, ptr, fixed bin, fixed bin, fixed bin);

        string (display_args_at) = trace_$arguments (event.entry_idx);
        if (event.kind = "ca" & display_args_at.call) | (event.kind = "re" & display_args_at.return)
        then do;
	first_arg_to_print = 1;
	if event.kind = "ca" & trace_$function (event.entry_idx)
	then last_arg_to_print = event.arg_list_ptr -> arg_list.header.arg_count - 1;
	else last_arg_to_print = event.arg_list_ptr -> arg_list.header.arg_count;
	if last_arg_to_print > 0
	then do;
	  if trace_$long ()
	  then indentation = min (event.frame_count, 40) + 54;
	  else indentation = min (event.frame_count, 40) + 15;
	  call
	    display_argument_list_ (osw.iocb_ptr, null (), null (), (event.arg_list_ptr), (event.entry_ptr),
	    first_arg_to_print, last_arg_to_print, indentation);
	end;
        end;

        char256var = trace_$call (event.entry_idx);
        if length (char256var) ^= 0
        then call cu_$cp (addrel (addr (char256var), 1), length (char256var), code);
      end DISPLAY_ARGUMENT_LIST_AND_CALL_CP;

    return;
%page;
stop:
  entry (event_i, watch_values_changed_i);

    event_ptr = addr (event_i);
    if event.version ^= EVENT_VERSION_3
    then signal error;
    osw = trace_$output_switch ();

    do iop = osw.iocb_ptr, iox_$error_output while (iop -> iocb.actual_iocb_ptr ^= osw.iocb_ptr -> iocb.actual_iocb_ptr);
      if event.kind = "ca"
      then call
	   ioa_$ioa_switch (iop, "^a: Stopping at the call of ^a.", trace_$me (),
	   trace_$entrypoint_name (event.entry_idx));
      else call
	   ioa_$ioa_switch (iop, "^a: Stopping at the return of ^a.", trace_$me (),
	   trace_$entrypoint_name (event.entry_idx));
    end;

    if watch_values_changed_i
    then
DISPLAY_CHANGED_LOCATIONS:
      begin;
        dcl  location_idx		     fixed bin;
        dcl  location_ptr		     ptr unal;
        dcl  prev_location_baseno	     bit (18) aligned;

        prev_location_baseno = ""b;
        do location_idx = 0 to trace_$num_locations () - 1;
	watch_values = trace_$location_values (location_idx);
	if watch_values.old ^= watch_values.new
	then do;
	  location_ptr = trace_$location_ptr (location_idx);
	  if baseno (location_ptr) ^= prev_location_baseno
	  then
	    do iop = osw.iocb_ptr,
	      iox_$error_output while (iop -> iocb.actual_iocb_ptr ^= osw.iocb_ptr -> iocb.actual_iocb_ptr);
	    call ioa_$ioa_switch (iop, "^a", trace_$location_seg_path (location_idx));
	    prev_location_baseno = baseno (location_ptr);
	  end;
	  do iop = osw.iocb_ptr,
	    iox_$error_output while (iop -> iocb.actual_iocb_ptr ^= osw.iocb_ptr -> iocb.actual_iocb_ptr);
	    call ioa_$ioa_switch (iop, "^20x^w -> ^w at ^p", watch_values.old, watch_values.new, location_ptr);
	  end;
	end;
        end;
      end DISPLAY_CHANGED_LOCATIONS;

    spp = trace_$stop_proc ();
    if spp.entry_value = cu_$cl
    then call cu_$cl (CL_FLAGS);
    else call spp.entry_value ();

    return;
%page;
allocate_buffer:
  entry (buffer_ptr_o);
    allocate buffer;
    buffer.h.version = BUFFER_VERSION_3;
    buffer.h.count = 0;
    buffer_ptr_o = buffer_ptr;
    return;

copy_buffer_ptr:
  entry (buffer_ptr_source_i, buffer_ptr_target_i);
    if buffer_ptr_target_i = buffer_ptr_source_i
    then return;
    buffer_ptr = buffer_ptr_target_i;
    buffer_ptr_target_i = buffer_ptr_source_i;
    if buffer_ptr = null ()
    then return;
    if buffer.h.version ^= BUFFER_VERSION_3
    then signal error;
    free buffer;
    return;


buffer_counts:
  entry (buffer_first_idx_o, buffer_count_o);
    buffer_ptr = trace_$buffer_ptr ();
    if buffer_ptr = null ()
    then do;
      buffer_first_idx_o = 0;
      buffer_count_o = 0;
    end;
    else do;
      if buffer.h.version ^= BUFFER_VERSION_3
      then signal error;
      buffer_first_idx_o = max (0, buffer.count - dim (buffer.e, 1));
      buffer_count_o = buffer.count;
    end;
    return;




buffer_event:
  entry (buffer_idx_i, frame_count_o, kind_o, entry_ptr_o, saved_counts_o, frame_meters_o);
    event_ptr = EVENT_PTR (buffer_idx_i);
    if event_ptr = null ()
    then do;
      frame_count_o = -1;
      kind_o = "!!";
      entry_ptr_o = null ();
      saved_counts_o = -1;
      frame_meters_o = -1;
    end;
    else do;
      frame_count_o = event.frame_count;
      kind_o = event.kind;
      entry_ptr_o = event.entry_ptr;
      saved_counts_o = event.saved;
      frame_meters_o = event.frame;
    end;
    return;



/*
 CLOCK TIME    REAL SEC   VCPU SEC  PF    CALL# RECURSION/HIGHEST   ENTRYPOINT
19:01:00.460   0.069478   0.000318   1<-      1 1/1 user_info_$homedir
*/

buffer_event_header:
  entry (buffer_idx_i) returns (char (256) var);
    event_ptr = EVENT_PTR (buffer_idx_i);
    if event_ptr = null ()
    then return ("There is no buffer or the buffer index is out of bounds.");

    if trace_$long ()
    then return (" CLOCK TIME  " || METERS_STRING_HEADER () || " " || DOTS_STRING (event.frame_count)
	 || COUNTS_STRING_HEADER () || "   ENTRYPOINT");
    else return (DOTS_STRING (event.frame_count) || COUNTS_STRING_HEADER () || "   ENTRYPOINT");




buffer_event_string:
  entry (buffer_idx_i) returns (char (256) var);
    event_ptr = EVENT_PTR (buffer_idx_i);
    if event_ptr = null ()
    then return ("There is no buffer or the buffer index is out of bounds.");

    if event.kind = "ca" | event.kind = "re"
    then char256var = trace_$entrypoint_name (trace_$entrypoint_index (event.entry_ptr));
    else if event.kind = "un"
    then char256var = trace_$entrypoint_name (trace_$entrypoint_index (event.entry_ptr)) || " unwound";
    else if event.kind = "si"
    then char256var = rtrim (addr (event.saved) -> based_signal_name);
    else char256var = "Unknown trace event """ || event.kind || """";

    if trace_$long ()
    then return (trace_time_ (addr (event.callers_sp) -> fb71based) || " " || METERS_STRING (event.kind, event.frame)
	 || " " || DOTS_STRING (event.frame_count) || COUNTS_STRING (event.kind, event.saved) || " " || char256var);
    else return (DOTS_STRING (event.frame_count) || COUNTS_STRING (event.kind, event.saved) || " " || char256var);
%page;
cv_file_path_to_osw:
  entry (char256var_i, referencing_ptr_i) returns (1 like output_switch aligned);
    osw.iocb_ptr = null ();
    osw.stream_name = "";
    osw.file_path = char256var_i;
    if osw.file_path = ""
    then return (osw);

    osw.stream_name = "trace_of_." || unique_chars_ (""b);

    if length (osw.file_path) < 6
    then osw.file_path = osw.file_path || ".trace";
    else if substr (osw.file_path, length (osw.file_path) - 5) ^= ".trace"
    then osw.file_path = osw.file_path || ".trace";

    call iox_$attach_name ((osw.stream_name), osw.iocb_ptr, "vfile_ " || osw.file_path, (referencing_ptr_i), code);
    if code ^= 0
    then call
	 sub_err_ (code, trace_$me (), ACTION_CANT_RESTART, null (), rv, "Attempting to attach file ""^a"".",
	 osw.file_path);

    call iox_$open (osw.iocb_ptr, Stream_output, "0"b, code);
    if code ^= 0
    then do;
      call iox_$detach_iocb (osw.iocb_ptr, rv);
      call sub_err_ (code, trace_$me (), ACTION_CANT_RESTART, null (), rv, "Attempting to open ""^a"".", osw.file_path);
    end;

    return (osw);


cv_stream_name_to_osw:
  entry (char32var_i) returns (1 like output_switch aligned);
    osw.iocb_ptr = null ();
    osw.stream_name = char32var_i;
    osw.file_path = "";
    if osw.stream_name ^= ""
    then do;
      if before (osw.stream_name, ".") = "trace_of_"
      then call
	   sub_err_ (ZERO, trace_$me (), ACTION_CANT_RESTART, null (), rv,
	   "The io stream prefix ""trace_of_."" is reserved for use by trace only.");
      call iox_$look_iocb ((osw.stream_name), osw.iocb_ptr, code);
      if code ^= 0
      then call
	   sub_err_ (code, trace_$me (), ACTION_CANT_RESTART, null (), rv, "Attempting to locate the io stream ""^a"".",
	   osw.stream_name);
    end;
    return (osw);


copy_osw:
  entry (osw_source_i, osw_dest_i);
    if osw_source_i.iocb_ptr = osw_dest_i.iocb_ptr
    then return;
    osw = osw_dest_i;
    osw_dest_i = osw_source_i;
    if osw.file_path = ""
    then return;

    call iox_$close (osw.iocb_ptr, code);
    if code ^= 0
    then call
	 sub_err_ (code, trace_$me (), ACTION_DEFAULT_RESTART, null (), rv, "Attempting to close file ""^a"".",
	 osw.file_path);

    code = 0;
    call iox_$detach_iocb (osw.iocb_ptr, code);
    if code ^= 0
    then call
	 sub_err_ (code, trace_$me (), ACTION_DEFAULT_RESTART, null (), rv, "Attempting to detach file ""^a"".",
	 osw.file_path);

    return;


cv_entry_name_to_spp:
  entry (char256var_i, referencing_ptr_i) returns (1 like stop_proc aligned);
    call cu_$make_entry_value (null (), spp.entry_value);
    spp.entry_name = char256var_i;
    if spp.entry_name ^= ""
    then do;
      spp.entry_value = cv_entry_ ((spp.entry_name), (referencing_ptr_i), code);
      if code ^= 0
      then call sub_err_ (code, trace_$me (), ACTION_CANT_RESTART, null (), rv, "-stop_proc ""^a"".", spp.entry_name);
    end;
    return (spp);
%page;
/* SUBROUTINES */


EVENT_PTR:
  proc (buffer_idx_i) returns (ptr unal);
    dcl  buffer_idx_i		 fixed bin (34) parm;
    dcl  buffer_ptr			 ptr unal;
    dcl  buffer_idx			 fixed bin (34);
    dcl  buffer_array_idx		 fixed bin;
    buffer_ptr = trace_$buffer_ptr ();
    buffer_idx = buffer_idx_i;
    if buffer_ptr = null ()
    then return (null ());
    if buffer.h.version ^= BUFFER_VERSION_3
    then signal error;
    if buffer_idx < 0 | buffer_idx < buffer.count - dim (buffer.e, 1) | buffer_idx >= buffer.count
    then return (null ());
    buffer_array_idx = mod (buffer_idx, dim (buffer.e, 1));
    if buffer.e (buffer_array_idx).version ^= EVENT_VERSION_3
    then signal error;
    return (addr (buffer.e (buffer_array_idx)));
  end EVENT_PTR;



METERS_STRING:
  proc (kind_i, meters_i) returns (char (40) var);
    dcl  kind_i			 char (2) parm;
    dcl  1 meters_i			 like meters aligned parm;
    dcl  meters_string		 char (40) var;
    dcl  return_string_length		 fixed bin;
    if kind_i = "re" | kind_i = "un"
    then call
	 ioa_$rsnnl ("^10.6f ^10.6f ^3d", meters_string, return_string_length, float (meters_i.real_time, 27) * 1e-6,
	 float (meters_i.vcpu_time, 27) * 1e-6, meters_i.page_faults);
    else meters_string = (25)" ";
    return (meters_string);

METERS_STRING_HEADER:
  entry () returns (char (25));
    return ("  REAL SEC   VCPU SEC  PF");
  end METERS_STRING;



DOTS_STRING:
  proc (number_of_dots_i) returns (char (40) var);
    dcl  number_of_dots_i		 fixed bin unal parm;
    dcl  dot_string			 char (40) var;
    dcl  return_string_length		 fixed bin;
    if number_of_dots_i <= maxlength (dot_string)
    then dot_string = copy (".", number_of_dots_i);
    else do;
      call ioa_$rsnnl ("[^d]", dot_string, return_string_length, number_of_dots_i);
      dot_string = copy (".", maxlength (dot_string) - length (dot_string)) || dot_string;
    end;
    return (dot_string);
  end DOTS_STRING;


COUNTS_STRING:
  proc (kind_i, saved_counts_i) returns (char (40) var);
    dcl  kind_i			 char (2) parm;
    dcl  1 saved_counts_i		 like counts aligned parm;
    dcl  kind_symbol		 char (2) aligned;
    dcl  counts_string		 char (40) var;
    dcl  return_string_length		 fixed bin;

    if kind_i = "ca"
    then kind_symbol = "->";
    else if kind_i = "re"
    then kind_symbol = "<-";
    else if kind_i = "un"
    then kind_symbol = "UW";
    else kind_symbol = "";

    if kind_i = "si"
    then counts_string = "Signal       ";
    else if kind_symbol = ""
    then counts_string = (13)" ";
    else call
	 ioa_$rsnnl ("^2a^7d ^d/^d", counts_string, return_string_length, kind_symbol, saved_counts_i.calls + 1,
	 saved_counts_i.level + 1, max (saved_counts_i.level + 1, saved_counts_i.max_level));

    return (counts_string);

COUNTS_STRING_HEADER:
  entry () returns (char (27));
    return ("    CALL# RECURSION/HIGHEST");
  end COUNTS_STRING;
%page;
/* START OF DECLARATIONS */
/* format: ^insnl,^delnl */


/* Parameters */

    dcl  buffer_count_o		 fixed bin (34) parm;
    dcl  buffer_first_idx_o		 fixed bin (34) parm;
    dcl  buffer_idx_i		 fixed bin (34) parm;
    dcl  buffer_ptr_o		 ptr unal parm;
    dcl  buffer_ptr_source_i		 ptr unal parm;
    dcl  buffer_ptr_target_i		 ptr unal parm;
    dcl  char32var_i		 char (32) var parm;
    dcl  char256var_i		 char (256) var parm;
    dcl  entry_ptr_o		 ptr unal parm;
    dcl  frame_count_o		 fixed bin parm;
    dcl  kind_o			 char (2) unal parm;
    dcl  referencing_ptr_i		 ptr parm;
    dcl  watch_values_changed_i	 bit aligned parm;
    dcl  1 event_i			 like event aligned parm;
    dcl  1 frame_meters_o		 like meters aligned parm;
    dcl  1 osw_dest_i		 like output_switch aligned parm;
    dcl  1 osw_source_i		 like output_switch aligned parm;
    dcl  1 saved_counts_o		 like counts aligned parm;


/* Automatic */

    dcl  bname_length		 fixed bin;
    dcl  bname_ptr			 ptr;
    dcl  clock_reading		 fixed bin (71);
    dcl  cname			 char (32) aligned;
    dcl  code			 fixed bin (35);
    dcl  char256var			 char (256) var;
    dcl  dir_path			 char (168);
    dcl  entry_name			 char (32);
    dcl  offset			 fixed bin (18);
    dcl  iop			 ptr;
    dcl  return_string_length		 fixed bin;
    dcl  rv			 fixed bin (35);

    dcl  1 osw			 aligned like output_switch;
    dcl  1 spp			 aligned like stop_proc;

    dcl  EVENT_VERSION_3		 char (4) aligned static options (constant) init ("TEV3");
    dcl  event_ptr			 ptr;
    dcl  1 event			 aligned based (event_ptr), /* Trace_catch_ knows this is 16 words.	*/
	 2 version		 char (4),
	 2 kind			 char (2) unal,
	 2 frame_count		 fixed bin unal,
	 2 frame			 like meters,
	 2 entry_ptr		 ptr unal,
	 2 saved			 like counts,
	 2 entry_idx		 fixed bin,
	 2 arg_list_ptr		 ptr unal,
	 2 callers_sp		 ptr unal,
	 2 return_ptr		 ptr unal;


/* Static */

    dcl  1 CL_FLAGS			 aligned static options (constant),
	 2 reset_sw		 bit unal init ("0"b),
	 2 mbz			 bit (35) unal init (""b);

    dcl  LAST_OSW_IOCB_PTR_THAT_A_TRACE_MESSAGE_WAS_WRITTEN_TO ptr static init (null ());
    dcl  ZERO			 fixed bin (35) static options (constant) init (0);


/* Conditions */

    dcl  error			 condition;


/* Based */

    dcl  based_ptr			 ptr based;
    dcl  based_signal_name		 char (24) aligned based;
    dcl  bname			 char (bname_length) based (bname_ptr);
    dcl  fb71based			 fixed bin (71) based;

    dcl  buffer_ptr			 ptr unal;
    dcl  BUFFER_VERSION_3		 char (8) aligned static options (constant) init ("TraceBF3");
    dcl  1 buffer			 aligned based (buffer_ptr),
	 2 h,
	   3 version		 char (8),
	   3 not_used		 fixed bin,
	   3 count		 fixed bin (34),
	 2 e			 (0:8191) like event; /* Trace_catch_ knows this dimension.		*/


/* External Variables */

    dcl  iox_$error_output		 ptr ext;


/* External Entries */

    dcl  cu_$cl			 entry (1 aligned, 2 bit (1) unal, 2 bit (35) unal);
    dcl  cu_$make_entry_value		 entry (ptr, entry);
    dcl  cv_entry_			 entry (char (*), ptr, fixed bin (35)) returns (entry);
    dcl  hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
    dcl  interpret_bind_map_		 entry (ptr, char (32) aligned, fixed bin (18), fixed bin (35));
    dcl  ioa_$rsnnl			 entry options (variable);
    dcl  ioa_$ioa_switch		 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_$detach_iocb		 entry (ptr, fixed bin (35));
    dcl  iox_$look_iocb		 entry (char (*), ptr, fixed bin (35));
    dcl  iox_$open			 entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
    dcl  pl1_frame_$name		 entry (ptr, ptr, fixed bin);
    dcl  sub_err_			 entry () options (variable);
    dcl  trace_time_		 entry (fixed bin (71)) returns (char (12));
    dcl  unique_chars_		 entry (bit (*)) returns (char (15));


/* format: insnl,delnl */
/* END OF DECLARATIONS */
%page;
/* START OF INCLUDE FILES */

%include arg_descriptor;
%page;
%include arg_list;
%page;
%include iocbx;


%include iox_modes;
%page;
%include std_descriptor_types;
%page;
%include sub_err_flags;
%page;
%include trace_interface;


  end trace_print_;




		    trace_recurse_.pl1              10/23/84  1256.2rew 10/23/84  1219.1       16713



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/*      Written in June 1983 by Jeffrey D. Ives.					*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


/* format: style2,^inddcls,ifthendo,^indnoniterdo,thendo,^inditerdo,ind2,dclind5,idind32 */
%page;
trace_recurse_:
  proc (number_of_times_i, entry_to_entry_elapsed_time_o, return_to_return_elapsed_time_o);

    number_of_times = number_of_times_i;

    entry_clock_reading = clock ();

    call trace_recurse_dummy_ (number_of_times, divider_clock_reading);

    return_clock_reading = clock ();

    entry_to_entry_elapsed_time_o = divider_clock_reading - entry_clock_reading;
    return_to_return_elapsed_time_o = return_clock_reading - divider_clock_reading;

    return;
%page;
/* START OF DECLARATIONS */
/* format: ^insnl,^delnl */

/* Parameters */
dcl  entry_to_entry_elapsed_time_o   fixed bin (53) parm;
dcl  number_of_times_i	       fixed bin (34) parm;
dcl  return_to_return_elapsed_time_o fixed bin (53) parm;

/* Automatic */
dcl  divider_clock_reading	       fixed bin (53);
dcl  entry_clock_reading	       fixed bin (53);
dcl  number_of_times	       fixed bin;
dcl  return_clock_reading	       fixed bin (53);

/* Static */

/* Conditions */

/* Based */

/* External Variables */

/* External Entries */
dcl  trace_recurse_dummy_	       entry (fixed bin, fixed bin (53));

/* format: insnl,delnl */
/* END OF DECLARATIONS */

  end trace_recurse_;




		    trace_recurse_dummy_.pl1        10/23/84  1256.2rew 10/23/84  1219.1       12798



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/*      Written in June 1983 by Jeffrey D. Ives.					*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


/* format: style2,^inddcls,ifthendo,^indnoniterdo,thendo,^inditerdo,ind2,dclind5,idind32 */


trace_recurse_dummy_:
  proc (number_of_times_io, return_clock_reading_o);

    number_of_times_io = number_of_times_io - 1;

    if number_of_times_io ^= 0
    then call trace_recurse_dummy_ (number_of_times_io, return_clock_reading_o);
    else return_clock_reading_o = clock ();

    return;



/* START OF DECLARATIONS */
/* format: ^insnl,^delnl */

/* Parameters */
dcl  return_clock_reading_o	       fixed bin (53) parm;
dcl  number_of_times_io	       fixed bin parm;

/* Automatic */

/* Static */

/* Conditions */

/* Based */

/* External Variables */

/* External Entries */
dcl  trace_recurse_dummy_	       entry (fixed bin, fixed bin (53));

/* format: insnl,delnl */
/* END OF DECLARATIONS */

  end trace_recurse_dummy_;




		    trace_repeat_.pl1               10/23/84  1256.2rew 10/23/84  1219.1       21132



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/*      Written in June 1983 by Jeffrey D. Ives.					*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


/* format: style2,^inddcls,ifthendo,^indnoniterdo,thendo,^inditerdo,ind2,dclind5,idind32 */
%page;
trace_repeat_:
  proc (number_of_times_i, entry_to_return_elapsed_time_o, return_to_entry_elapsed_time_o);

    entry_to_return_elapsed_time = 0;
    return_to_entry_elapsed_time = 0;

    do number_of_times = 0 to number_of_times_i;
      entry_clock_reading = clock ();

      call trace_repeat_dummy_ (return_clock_reading);

      if number_of_times ^= 0 /* Waste the first entry reading.		*/
      then do;
        return_to_entry_elapsed_time = return_to_entry_elapsed_time + (entry_clock_reading - old_return_clock_reading);
        entry_to_return_elapsed_time = entry_to_return_elapsed_time + (return_clock_reading - entry_clock_reading);
      end;

      old_return_clock_reading = return_clock_reading;
    end;

    entry_to_return_elapsed_time_o = entry_to_return_elapsed_time;
    return_to_entry_elapsed_time_o = return_to_entry_elapsed_time;

    return;
%page;
/* START OF DECLARATIONS */
/* format: ^insnl,^delnl */

/* Parameters */
dcl  entry_to_return_elapsed_time_o  fixed bin (53) parm;
dcl  number_of_times_i	       fixed bin (34) parm;
dcl  return_to_entry_elapsed_time_o  fixed bin (53) parm;

/* Automatic */
dcl  entry_clock_reading	       fixed bin (53);
dcl  entry_to_return_elapsed_time    fixed bin (53);
dcl  number_of_times	       fixed bin;
dcl  old_return_clock_reading	       fixed bin (53);
dcl  return_clock_reading	       fixed bin (53);
dcl  return_to_entry_elapsed_time    fixed bin (53);

/* Static */

/* Conditions */

/* Based */

/* External Variables */

/* External Entries */
dcl  trace_repeat_dummy_	       entry (fixed bin (53));

/* format: insnl,delnl */
/* END OF DECLARATIONS */

  end trace_repeat_;




		    trace_repeat_dummy_.pl1         10/23/84  1256.2rew 10/23/84  1219.2       10044



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/*      Written in June 1983 by Jeffrey D. Ives.					*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


/* format: style2,^inddcls,ifthendo,^indnoniterdo,thendo,^inditerdo,ind2,dclind5,idind32 */

trace_repeat_dummy_:
  proc (return_clock_reading_o);

    return_clock_reading_o = clock ();

    return;


/* START OF DECLARATIONS */
/* format: ^insnl,^delnl */

/* Parameters */
dcl  return_clock_reading_o	       fixed bin (53) parm;

/* Automatic */

/* Static */

/* Conditions */

/* Based */

/* External Variables */

/* External Entries */

/* format: insnl,delnl */
/* END OF DECLARATIONS */

  end trace_repeat_dummy_;




		    trace_tables_.pl1               10/23/84  1334.8rew 10/23/84  1219.2      226611



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/*
   This program manages the trace and watch tables and the tab (trace
   attributes) structures.  The tables are not simple arrays.  To promote
   efficient update, each consists of two stacks, one at each end of a large
   storage array.  Entrypoints in trace_catch_ are used to access and update
   the tables.

   Written: May 1984 by Jeffrey D. Ives.
*/
/* format: style2,ifthendo,^indnoniterdo,thendo,^inditerdo,indproc,ind2,dclind5,idind32 */


trace_tables_:
  procedure ();
    signal error;


/* INITIALIZE */

initialize:
  entry ();

    allocate tt in (trace_storage);
    call INIT_TABLE_HEADER (tt.h, dim (tt.e, 1));
    trace_catch_$tt_ptr = tt_ptr;

    allocate stt in (trace_storage);
    call INIT_TABLE_HEADER (stt.h, dim (stt.e, 1));
    trace_$stt_ptr = stt_ptr;

    allocate wt in (trace_storage);
    call INIT_TABLE_HEADER (wt.h, dim (wt.e, 1));
    trace_catch_$wt_ptr = wt_ptr;

    allocate swt in (trace_storage);
    call INIT_TABLE_HEADER (swt.h, dim (swt.e, 1));
    trace_$swt_ptr = swt_ptr;

    return;


INIT_TABLE_HEADER:
  proc (table_header_o, table_dim_i);
    dcl  1 table_header_o		 like table_header aligned parm;
    dcl  table_dim_i		 fixed bin parm;
    unspec (table_header_o) = ""b;
    table_header_o.version = TT_VERSION_3;
    table_header_o.max_count = table_dim_i;
    table_header_o.idx.high = table_dim_i;
    return;
  end INIT_TABLE_HEADER;
%page;
/* TRANSACTION BEGIN */

transaction_begin:
  entry ();

    if trace_catch_$tt_ptr -> tt.h.version ^= TT_VERSION_3
    then signal error;
    if trace_$stt_ptr -> tt.h.version ^= TT_VERSION_3 | trace_$stt_ptr -> tt.h.count ^= 0
    then signal error;

    if trace_catch_$wt_ptr -> wt.h.version ^= TT_VERSION_3
    then signal error;
    if trace_$swt_ptr -> wt.h.version ^= TT_VERSION_3 | trace_$swt_ptr -> wt.h.count ^= 0
    then signal error;

    return;


/* TRANSACTION BEGIN FORCE is the same as TRANSACTION END */

transaction_begin_force:				/* TRANSACTION END */
transaction_end:
  entry ();
    stt_ptr = trace_$stt_ptr;
    if stt.h.count = -1
    then stt.h.count = 0;				/* "*" case */
    else
      do stt_idx = 0 to stt.h.count - 1;
      te = trace_catch_$table_remove (stt_ptr, 0);	/* Removing the 0th one is the most efficient.	*/
      unspec (tte) = unspec (te);
      call FREE_TAB (tte.trace_attributes_ptr);
    end;
    swt_ptr = trace_$swt_ptr;
    if swt.h.count = -1
    then swt.h.count = 0;				/* "*" case */
    else
      do swt_idx = 0 to swt.h.count - 1;
      te = trace_catch_$table_remove (swt_ptr, 0);
    end;
    return;


/* ADD SPECIFIED ENTRYPOINTS */

add_specified_eps:
  entry (n_added_o, n_updated_o);
    tt_ptr = trace_catch_$tt_ptr;
    stt_ptr = trace_$stt_ptr;
    n_added = 0;
    n_updated = 0;
    if stt.h.count < 0
    then
      do tt_idx = 0 to tt.h.count - 1;			/* "*" case */
      te = trace_catch_$table_get (tt_ptr, tt_idx);
      call UPDATE_TTE (te);
    end;
    else
      do stt_idx = 0 to stt.h.count - 1;
      te = trace_catch_$table_get (stt_ptr, stt_idx);
      call UPDATE_TTE (te);
    end;
    n_added_o = n_added;
    n_updated_o = n_updated;
    return;

UPDATE_TTE:
  proc (te_i);
    dcl  1 te_i			 like te aligned parm;
    unspec (tte) = unspec (te_i);
    tab_ptr = tte.trace_attributes_ptr;
    tt_idx = trace_catch_$table_seek (tt_ptr, te.key);
    if tt_idx < 0
    then do;					/* Add it. */
      if tab.translator_id >= 0 /* If it can be traced. */
      then do;
        if ^trace_parameters_$update_parameters (tab.parms_ptr)
        then signal error;
      end;
      tab.reference_count = tab.reference_count + 1;
      tt_idx = trace_catch_$table_add (tt_ptr, te);
      if tt_idx < 0
      then signal error;
      n_added = n_added + 1;
    end;
    else do;					/* Update it. */
      if tab.translator_id >= 0 /* If it can be traced. */
      then do;
        if trace_parameters_$update_parameters (tab.parms_ptr)
        then n_updated = n_updated + 1;
      end;
    end;
  end UPDATE_TTE;


/* ADD SPECIFIED LOCATIONS */

add_specified_locs:
  entry (n_added_o, n_updated_o);
    wt_ptr = trace_catch_$wt_ptr;
    swt_ptr = trace_$swt_ptr;

    n_added = 0;
    n_updated = 0;
    if swt.h.count < 0
    then
      do wt_idx = 0 to wt.h.count - 1;			/* "*" case */
      te = trace_catch_$table_get (wt_ptr, wt_idx);
      unspec (wte) = unspec (te);
      if wte.old_value ^= wte.location_ptr -> based_value
      then do;
        call trace_catch_$table_put_data (wt_ptr, wt_idx, wte.location_ptr -> based_value);
        n_updated = n_updated + 1;
      end;
    end;
    else
      do swt_idx = 0 to swt.h.count - 1;
      te = trace_catch_$table_get (swt_ptr, swt_idx);
      unspec (wte) = unspec (te);
      wte.old_value = wte.location_ptr -> based_value;
      wt_idx = trace_catch_$table_seek (wt_ptr, te.key);
      if wt_idx < 0
      then do;					/* Add it. */
        unspec (te) = unspec (wte);
        wt_idx = trace_catch_$table_add (wt_ptr, te);
        if wt_idx < 0
        then signal error;
        n_added = n_added + 1;
      end;
      else do;					/* Update it. */
        te = trace_catch_$table_get (wt_ptr, wt_idx);
        if te.data ^= wte.old_value
        then do;
	call trace_catch_$table_put_data (wt_ptr, wt_idx, wte.old_value);
	n_updated = n_updated + 1;
        end;
      end;
    end;

    n_added_o = n_added;
    n_updated_o = n_updated;
    return;


/* REMOVE SPECIFIED ENTRYPOINTS */

remove_specified_eps:
  entry (n_removed_o);
    tt_ptr = trace_catch_$tt_ptr;
    stt_ptr = trace_$stt_ptr;
    n_removed = 0;
    if stt.h.count < 0
    then do;					/* "*" case */
      trace_$stt_ptr = null ();			/* Switch tables. */
      stt.h.count = 0;
      trace_catch_$tt_ptr = stt_ptr;
      trace_$stt_ptr = tt_ptr;
      n_removed = tt.h.count;
      do tt_idx = 0 to tt.h.count - 1;			/* Remove the meters. */
        te = trace_catch_$table_get (tt_ptr, tt_idx);
        unspec (tte) = unspec (te);
        tab_ptr = tte.trace_attributes_ptr;
        trace_catch_$removed = trace_catch_$removed + tab.local;
      end;
    end;
    else
      do stt_idx = 0 to stt.h.count - 1;
      te = trace_catch_$table_get (stt_ptr, stt_idx);
      tt_idx = trace_catch_$table_seek (tt_ptr, te.key);
      if tt_idx >= 0
      then do;					/* Remove it. */
        unspec (tte) = unspec (te);
        te = trace_catch_$table_remove (tt_ptr, tt_idx);
        if unspec (te) ^= unspec (tte)
        then signal error;
        tab_ptr = tte.trace_attributes_ptr;
        trace_catch_$removed = trace_catch_$removed + tab.local;
        call FREE_TAB (tab_ptr);
        n_removed = n_removed + 1;
      end;
    end;

    n_removed_o = n_removed;
    return;


/* REMOVE SPECIFIED LOCATIONS */

remove_specified_locs:
  entry (n_removed_o);
    wt_ptr = trace_catch_$wt_ptr;
    swt_ptr = trace_$swt_ptr;
    n_removed = 0;
    if swt.h.count < 0
    then do;					/* "*" case */
      trace_$swt_ptr = null ();			/* Switch them. */
      swt.h.count = 0;
      trace_catch_$wt_ptr = swt_ptr;
      trace_$swt_ptr = wt_ptr;
      n_removed = wt.h.count;
    end;
    else
      do swt_idx = 0 to swt.h.count - 1;
      te = trace_catch_$table_get (swt_ptr, swt_idx);
      wt_idx = trace_catch_$table_seek (wt_ptr, te.key);
      if wt_idx >= 0
      then do;					/* Remove it. */
        unspec (wte) = unspec (te);
        te = trace_catch_$table_remove (wt_ptr, wt_idx);
        if unspec (te.key) ^= unspec (wte.location_ptr)
        then signal error;
        n_removed = n_removed + 1;
      end;
    end;

    n_removed_o = n_removed;
    return;


/* TURN ON AND OFF SPECIFIED ENTRYPOINTS */

turn_on_specified_eps:
  entry (n_turned_o);
    what_we_want = "1"b;
    go to ON_OFF_JOIN;


turn_off_specified_eps:
  entry (n_turned_o);
    what_we_want = "0"b;
    go to ON_OFF_JOIN;


ON_OFF_JOIN:
    tt_ptr = trace_catch_$tt_ptr;
    stt_ptr = trace_$stt_ptr;

    n_turned = 0;
    if stt.h.count < 0
    then
      do tt_idx = 0 to tt.h.count - 1;			/* "*" case */
      te = trace_catch_$table_get (tt_ptr, tt_idx);
      unspec (tte) = unspec (te);
      tab_ptr = tte.trace_attributes_ptr;
      if tab.on ^= what_we_want
      then do;					/* Turn it. */
        tab.on = what_we_want;
        n_turned = n_turned + 1;
      end;
    end;
    else
      do stt_idx = 0 to stt.h.count - 1;
      te = trace_catch_$table_get (stt_ptr, stt_idx);
      tt_idx = trace_catch_$table_seek (tt_ptr, te.key);
      if tt_idx >= 0 /* If it is in the table...			*/
      then do;
        unspec (tte) = unspec (te);
        tab_ptr = tte.trace_attributes_ptr;
        if tab.on ^= what_we_want
        then do;					/* Turn it. */
	tab.on = what_we_want;
	n_turned = n_turned + 1;
        end;
      end;
    end;

    n_turned_o = n_turned;
    return;
%page;
/* METERS */


entrypoint_counts:
  entry (tt_idx_i) returns (1 aligned like counts);
    tt_idx = tt_idx_i;
    tt_ptr = trace_catch_$tt_ptr;
    if tt_idx < 0 | tt_idx >= tt.h.count
    then signal error;
    te = trace_catch_$table_get (tt_ptr, tt_idx);
    unspec (tte) = unspec (te);
    tab_ptr = tte.trace_attributes_ptr;
    return (tab.cts);


entrypoint_global_meters:
  entry (tt_idx_i) returns (1 like meters aligned);
    tt_idx = tt_idx_i;
    tt_ptr = trace_catch_$tt_ptr;
    if tt_idx < 0 | tt_idx >= tt.h.count
    then signal error;
    te = trace_catch_$table_get (tt_ptr, tt_idx);
    unspec (tte) = unspec (te);
    tab_ptr = tte.trace_attributes_ptr;
    return (tab.global);


entrypoint_local_meters:
  entry (tt_idx_i) returns (1 like meters aligned);
    tt_idx = tt_idx_i;
    tt_ptr = trace_catch_$tt_ptr;
    if tt_idx < 0 | tt_idx >= tt.h.count
    then signal error;
    te = trace_catch_$table_get (tt_ptr, tt_idx);
    unspec (tte) = unspec (te);
    tab_ptr = tte.trace_attributes_ptr;
    return (tab.local);


metered:
  entry () returns (1 like meters aligned);
    return (trace_catch_$metered);


removed:
  entry () returns (1 like meters aligned);
    return (trace_catch_$removed);


reset_meters:
  entry ();
    tt_ptr = trace_catch_$tt_ptr;
    do tt_idx = 0 to tt.h.count - 1;
      te = trace_catch_$table_get (tt_ptr, tt_idx);
      unspec (tte) = unspec (te);
      tab_ptr = tte.trace_attributes_ptr;
      tab.cts.calls = 0;
      tab.cts.max_level = 0;
      tab.local = 0;
      tab.global = 0;
    end;
    trace_catch_$removed = 1;
    trace_catch_$metered = 1;
    return;
%page;
/* ENTRYPOINTS */


entrypoint_index:
  entry (entry_ptr_i) returns (fixed bin);
    te.key = unspec (entry_ptr_i);
    return (trace_catch_$table_seek (trace_catch_$tt_ptr, te.key));


entrypoint_name:
  entry (tt_idx_i) returns (char (256) var);
    tt_idx = tt_idx_i;
    tt_ptr = trace_catch_$tt_ptr;
    if tt_idx < 0 | tt_idx >= tt.h.count
    then return ("entrypoint not in trace table");
    te = trace_catch_$table_get (tt_ptr, tt_idx);
    unspec (tte) = unspec (te);
    tab_ptr = tte.trace_attributes_ptr;
    if before (tab.name, "$") = after (tab.name, "$")
    then return (before (tab.name, "$"));
    else return (tab.name);


entrypoint_ptr:
  entry (tt_idx_i) returns (ptr);
    tt_idx = tt_idx_i;
    tt_ptr = trace_catch_$tt_ptr;
    if tt_idx < 0 | tt_idx >= tt.h.count
    then signal error;
    te = trace_catch_$table_get (tt_ptr, tt_idx);
    unspec (tte) = unspec (te);
    return (tte.entry_ptr);


entrypoint_seg_path:
  entry (tt_idx_i) returns (char (256) var);
    tt_idx = tt_idx_i;
    tt_ptr = trace_catch_$tt_ptr;
    if tt_idx < 0 | tt_idx >= tt.h.count
    then signal error;
    te = trace_catch_$table_get (tt_ptr, tt_idx);
    unspec (tte) = unspec (te);
    return (trace_entrypoints_$get_path_name (tte.entry_ptr));


entrypoint_status:
  entry (tt_idx_i) returns (char (32) var);
    tt_idx = tt_idx_i;
    tt_ptr = trace_catch_$tt_ptr;
    if tt_idx < 0 | tt_idx >= tt.h.count
    then signal error;
    te = trace_catch_$table_get (tt_ptr, tt_idx);
    unspec (tte) = unspec (te);
    tab_ptr = tte.trace_attributes_ptr;
    if tab.translator_id < 0
    then return ("cannot be traced");
    if tab.translator_id = 1
    then if ^trace_$alm ()
         then return ("off because -alm off");
    if tab.on
    then return ("on");
    else return ("off");


function:
  entry (tt_idx_i) returns (bit aligned);
    tt_idx = tt_idx_i;
    tt_ptr = trace_catch_$tt_ptr;
    if tt_idx < 0 | tt_idx >= tt.h.count
    then signal error;
    te = trace_catch_$table_get (tt_ptr, tt_idx);
    unspec (tte) = unspec (te);
    tab_ptr = tte.trace_attributes_ptr;
    return (tab.function);


num_entrypoints:
  entry () returns (fixed bin);
    return (trace_catch_$tt_ptr -> tt.h.count);


num_specified_entrypoints:
  entry () returns (fixed bin);
    stt_ptr = trace_$stt_ptr;
    if stt.h.count < 0
    then stt_ptr = trace_catch_$tt_ptr;			/* "*" case */
    return (stt.h.count);


parameters_ptr:
  entry (tt_idx_i) returns (ptr);
    tt_idx = tt_idx_i;
    tt_ptr = trace_catch_$tt_ptr;
    if tt_idx < 0 | tt_idx >= tt.h.count
    then signal error;
    te = trace_catch_$table_get (tt_ptr, tt_idx);
    unspec (tte) = unspec (te);
    tab_ptr = tte.trace_attributes_ptr;
    return (tab.parms_ptr);


specified_entrypoint_index:
  entry (stt_idx_i) returns (fixed bin);
    stt_idx = stt_idx_i;
    stt_ptr = trace_$stt_ptr;
    tt_ptr = trace_catch_$tt_ptr;
    if stt.h.count < 0
    then return (stt_idx);				/* "*" case */
    if stt_idx < 0 | stt_idx >= stt.h.count
    then signal error;
    te = trace_catch_$table_get (stt_ptr, stt_idx);
    tt_idx = trace_catch_$table_seek (tt_ptr, te.key);
    return (tt_idx);


translator_id:
  entry (tt_idx_i) returns (ptr);
    tt_idx = tt_idx_i;
    tt_ptr = trace_catch_$tt_ptr;
    if tt_idx < 0 | tt_idx >= tt.h.count
    then signal error;
    te = trace_catch_$table_get (tt_ptr, tt_idx);
    unspec (tte) = unspec (te);
    tab_ptr = tte.trace_attributes_ptr;
    return (tab.translator_id);
%page;
/* LOCATIONS */


location_ptr:
  entry (wt_idx_i) returns (ptr);
    wt_idx = wt_idx_i;
    wt_ptr = trace_catch_$wt_ptr;
    if wt_idx < 0 | wt_idx >= wt.h.count
    then signal error;
    te = trace_catch_$table_get (wt_ptr, wt_idx);
    unspec (wte) = unspec (te);
    return (wte.location_ptr);


location_seg_path:
  entry (wt_idx_i) returns (char (256) var);
    wt_idx = wt_idx_i;
    wt_ptr = trace_catch_$wt_ptr;
    if wt_idx < 0 | wt_idx >= wt.h.count
    then signal error;
    te = trace_catch_$table_get (wt_ptr, wt_idx);
    unspec (wte) = unspec (te);
    return (trace_entrypoints_$get_path_name (wte.location_ptr));


location_values:
  entry (wt_idx_i) returns (1 aligned like watch_values);
    wt_idx = wt_idx_i;
    wt_ptr = trace_catch_$wt_ptr;
    if wt_idx < 0 | wt_idx >= wt.h.count
    then signal error;
    te = trace_catch_$table_get (wt_ptr, wt_idx);
    unspec (wte) = unspec (te);
    my_watch_values.old = wte.old_value;
    my_watch_values.new = wte.location_ptr -> based_value;
    return (my_watch_values);


num_locations:
  entry () returns (fixed bin);
    return (trace_catch_$wt_ptr -> wt.h.count);


num_specified_locations:
  entry () returns (fixed bin);
    swt_ptr = trace_$swt_ptr;
    wt_ptr = trace_catch_$wt_ptr;
    if swt.h.count >= 0
    then return (swt.h.count);
    else return (wt.h.count);				/* "*" case */


specified_location_index:
  entry (swt_idx_i) returns (fixed bin);
    swt_idx = swt_idx_i;
    swt_ptr = trace_$swt_ptr;
    wt_ptr = trace_catch_$wt_ptr;
    if swt.h.count < 0
    then return (swt_idx);				/* "*" case */
    if swt_idx < 0 | swt_idx >= swt.h.count
    then signal error;
    te = trace_catch_$table_get (swt_ptr, swt_idx);
    wt_idx = trace_catch_$table_seek (wt_ptr, te.key);
    return (wt_idx);


specify_locations:
  entry (char256var_i);
    swt_ptr = trace_$swt_ptr;
    if char256var_i = "*"
    then do;
      if swt.h.count > 0
      then
LOCATIONS_STAR_ERROR:
        call sub_err_ (ZERO, trace_$me (), ACTION_CANT_RESTART, null (), rv,
	   "If you specify *, you cannot specify any other locations.");
      swt.h.count = -1;
    end;
    else do;
      if swt.h.count < 0
      then go to LOCATIONS_STAR_ERROR;
      wte.location_ptr = addrel (cv_ptr_ ((char256var_i), code), 0);
      if wte.location_ptr = null ()			/* Addrel zeros the bit offset.		*/
      then call sub_err_ (code, trace_$me (), ACTION_CANT_RESTART, null (), rv,
	      "I could not convert ""^a"" to a pointer value.", char256var_i);
      wte.old_value = wte.location_ptr -> based_value;	/* See if we blow up trying to reference it.	*/
      unspec (te) = unspec (wte);
      swt_idx = trace_catch_$table_add (swt_ptr, te);
    end;
    return;


specify_changed_locations:
  entry ();
    wt_ptr = trace_catch_$wt_ptr;
    swt_ptr = trace_$swt_ptr;
    if swt.h.count < 0
    then ;					/* "*" case */
    else
      do wt_idx = 0 to wt.h.count - 1;
      te = trace_catch_$table_get (wt_ptr, wt_idx);
      unspec (wte) = unspec (te);
      te.data = wte.location_ptr -> based_value;
      if te.data ^= wte.old_value
      then swt_idx = trace_catch_$table_add (swt_ptr, te);
    end;
    return;



/* MISCELLANEOUS */


add_entrypoint:					/* Called from trace_entrypoints_$add_entrypoint. */
  entry (entry_ptr_i, entry_name_i, translator_id_i, function_i) returns (fixed bin);
    tt_ptr = trace_catch_$tt_ptr;
    if tt.h.count = tt.h.max_count
    then return (null ());
    call ALLOCATE_TAB (entry_name_i, translator_id_i, function_i);
    if tab.translator_id >= 0 /* -1 means don't trace. */
    then do;
      if ^trace_parameters_$update_parameters (tab.parms_ptr)
      then signal error;
    end;
    tte.entry_ptr = entry_ptr_i;
    tte.trace_attributes_ptr = tab_ptr;
    unspec (te) = unspec (tte);
    tab.reference_count = tab.reference_count + 1;
    tt_idx = trace_catch_$table_add (tt_ptr, te);
    if tt_idx < 0
    then signal error;
    return (tt_idx);


specify_all_entrypoints:
  entry ();
    stt_ptr = trace_$stt_ptr;
    if stt.h.count > 0
    then call sub_err_ (ZERO, trace_$me (), ACTION_CANT_RESTART, null (), rv,
	    "If you specify all entrypoints, you cannot specify any particular entrypoints.");
    stt.h.count = -1;
    return;


specify_entrypoint:					/* Called from trace_entrypoints_$specify_entrypoints.	*/
  entry (entry_ptr_i, entry_name_i, translator_id_i, function_i);
    stt_ptr = trace_$stt_ptr;
    tt_ptr = trace_catch_$tt_ptr;
    if stt.h.count < 0
    then call /* "*" case */
	    sub_err_ (ZERO, trace_$me (), ACTION_CANT_RESTART, null (), rv,
	    "If you specify *, you cannot specify any other entrypoints.");
    if trace_catch_$table_seek (stt_ptr, unspec (entry_ptr_i)) >= 0
    then return;
    if stt.h.count = stt.h.max_count
    then call sub_err_ (ZERO, trace_$me (), ACTION_CANT_RESTART, null (), rv,
	    "You have specified too many entrypoints.  The limit is ^d.", stt.h.max_count);
    tt_idx = trace_catch_$table_seek (tt_ptr, unspec (entry_ptr_i));
    if tt_idx >= 0
    then do;
      te = trace_catch_$table_get (tt_ptr, tt_idx);
      unspec (tte) = unspec (te);
      tab_ptr = tte.trace_attributes_ptr;
    end;
    else do;
      tte.entry_ptr = entry_ptr_i;
      call ALLOCATE_TAB (entry_name_i, translator_id_i, function_i);
      tte.trace_attributes_ptr = tab_ptr;
      unspec (te) = unspec (tte);
    end;
    tab.reference_count = tab.reference_count + 1;
    stt_idx = trace_catch_$table_add (stt_ptr, te);
    if stt_idx < 0
    then signal error;
    return;
%page;
/* SUBROUTINES */


ALLOCATE_TAB:
  proc (entry_name_i, translator_id_i, function_i);
    dcl  entry_name_i		 char (65) var parm;
    dcl  translator_id_i		 fixed bin parm;
    dcl  function_i			 bit aligned parm;
    tab_name_length = length (entry_name_i);
    if tab_name_length > 65
    then signal error;
    allocate tab in (trace_storage);
    unspec (tab) = ""b;
    tab.version = TAB_VERSION_3;
    tab.parms_ptr = null ();
    tab.on = "1"b;
    tab.translator_id = translator_id_i;
    tab.function = function_i;
    tab.name_length = tab_name_length;
    tab.name = entry_name_i;
  end ALLOCATE_TAB;


FREE_TAB:
  proc (tab_ptr_io);
    dcl  tab_ptr_io			 ptr unal parm;
    dcl  tp			 ptr unal;
    tp = tab_ptr_io;
    if tp = null ()
    then return;
    tab_ptr_io = null ();
    if tp -> tab.version ^= TAB_VERSION_3
    then signal error;
    tp -> tab.reference_count = tp -> tab.reference_count - 1;
    if tp -> tab.reference_count < 0
    then signal error;
    if tp -> tab.reference_count > 0
    then return;
    if tp -> tab.parms_ptr ^= null ()
    then call trace_parameters_$free_parameters (tp -> tab.parms_ptr);
    free tp -> tab;
  end FREE_TAB;
%page;
/* START OF DECLARATIONS */
/* format: ^insnl,^delnl */

/* Parameters */

    dcl  char256var_i		 char (256) var parm;
    dcl  entry_name_i		 char (65) var parm;
    dcl  entry_ptr_i		 ptr unal parm;
    dcl  function_i			 bit aligned parm;
    dcl  n_added_o			 fixed bin parm;
    dcl  n_removed_o		 fixed bin parm;
    dcl  n_turned_o			 fixed bin parm;
    dcl  n_updated_o		 fixed bin parm;
    dcl  stt_idx_i			 fixed bin parm;
    dcl  swt_idx_i			 fixed bin parm;
    dcl  translator_id_i		 fixed bin parm;
    dcl  tt_idx_i			 fixed bin parm;
    dcl  wt_idx_i			 fixed bin parm;


/* Automatic */

    dcl  code			 fixed bin (35);
    dcl  entry_ptr			 ptr unal;
    dcl  n_added			 fixed bin;
    dcl  n_removed			 fixed bin;
    dcl  n_turned			 fixed bin;
    dcl  n_updated			 fixed bin;
    dcl  rv			 fixed bin (35);
    dcl  stt_idx			 fixed bin;
    dcl  swt_idx			 fixed bin;
    dcl  tt_idx			 fixed bin;
    dcl  wt_idx			 fixed bin;
    dcl  what_we_want		 bit aligned;

    dcl  1 te			 aligned,
	 2 key			 bit (36),
	 2 data			 bit (36);

    dcl  1 tte			 aligned,
	 3 entry_ptr		 ptr unal,
	 3 trace_attributes_ptr	 ptr unal;

    dcl  1 wte			 aligned,
	 3 location_ptr		 ptr unal,
	 3 old_value		 bit (36);

    dcl  1 my_watch_values		 like watch_values aligned;

/* Static */

    dcl  ZERO			 fixed bin (35) static options (constant) init (0);


/* Conditions */

    dcl  error			 condition;


/* Based */

    dcl  based_value		 bit (36) aligned based;
    dcl  trace_storage		 area based (trace_catch_$trace_storage_ptr);

    dcl  TAB_VERSION_3		 char (8) aligned static options (constant) init ("TraceTB3");
    dcl  tab_name_length		 fixed bin;
    dcl  tab_ptr			 ptr unal;
    dcl  1 tab			 aligned based (tab_ptr),
	 2 version		 char (8),
	 2 reference_count		 fixed bin,
	 2 parms_ptr		 ptr unal,
	 2 cts			 like counts,
	 2 local			 like meters,
	 2 on			 bit,
	 2 global			 like meters,
	 2 translator_id		 fixed bin,
	 2 function		 bit,
	 2 name_length		 fixed bin,
	 2 name			 char (tab_name_length refer (tab.name_length)) unal;

    dcl  1 table_header		 aligned based,
	 2 version		 char (8),	/* "TraceTT3" */
	 2 max_count		 fixed bin,
	 2 count			 fixed bin,
	 2 idx,					/* Must be double word aligned.		*/
	   3 low			 fixed bin,
	   3 high			 fixed bin,
	 2 working_storage		 fixed bin (71);	/* For trace_catch_				*/


    dcl  TT_VERSION_3		 char (8) aligned static options (constant) init ("TraceTT3");
    dcl  tt_ptr			 ptr;
    dcl  1 tt			 aligned based (tt_ptr),
	 2 h			 like table_header,
	 2 e			 (0:9999) fixed bin (66);

    dcl  stt_ptr			 ptr;
    dcl  1 stt			 like tt aligned based (stt_ptr);

    dcl  wt_ptr			 ptr;
    dcl  1 wt			 aligned based (wt_ptr),
	 2 h			 like table_header,
	 2 e			 (0:1023) fixed bin (66);

    dcl  swt_ptr			 ptr;
    dcl  1 swt			 like wt aligned based (swt_ptr);


/* External Variables */

    dcl  trace_catch_$trace_storage_ptr	 ptr ext;
    dcl  trace_catch_$tt_ptr		 ptr ext;
    dcl  trace_catch_$wt_ptr		 ptr ext;
    dcl  1 trace_catch_$metered	 like meters aligned ext;
    dcl  1 trace_catch_$removed	 like meters aligned ext;

    dcl  trace_$stt_ptr		 ptr ext;
    dcl  trace_$swt_ptr		 ptr ext;


/* External Entries */

    dcl  cv_ptr_			 entry (char (*), fixed bin (35)) returns (ptr);
    dcl  sub_err_			 entry () options (variable);
    dcl  trace_catch_$table_add	 entry (ptr, 1 like te aligned) returns (fixed bin);
    dcl  trace_catch_$table_get	 entry (ptr, fixed bin) returns (1 like te aligned);
    dcl  trace_catch_$table_put_data	 entry (ptr, fixed bin, bit (36) aligned);
    dcl  trace_catch_$table_remove	 entry (ptr, fixed bin) returns (1 like te aligned);
    dcl  trace_catch_$table_seek	 entry (ptr, bit (36) aligned) returns (fixed bin);
    dcl  trace_entrypoints_$get_path_name entry (ptr unal) returns (char (256) var);
    dcl  trace_parameters_$free_parameters entry (ptr unal);
    dcl  trace_parameters_$update_parameters entry (ptr unal) returns (bit aligned);


/* format: insnl,delnl */
/* END OF DECLARATIONS */
%page;
/* START OF INCLUDE FILES */


%include sub_err_flags;
%page;
%include trace_interface;

  end trace_tables_;




		    trace_time_.pl1                 10/23/84  1334.8rew 10/23/84  1219.2       22086



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

/*
   This program is called by trace_print_ to get a formatted clock reading.
   The format is HH:MM:SS.FFF.

   Written:  May 1984 by Jeffrey D. Ives.
*/

/* format: style2,ifthendo,^indnoniterdo,thendo,^inditerdo,indproc,ind2,dclind5,idind32 */
%page;
trace_time_:
  proc (clock_reading_i) returns (char (12));

    zone = "";
    call
      decode_clock_value_$date_time (clock_reading_i, de.month, de.dom, de.year, de.hour, de.minute, de.second,
      de.microsecond, de.dow, zone, code);
    if code ^= 0
    then de = 0;

    dec3 = de.hour;
    unspec (formatted_string.hour) = substr (unspec (dec3), 19, 18);
    formatted_string.colon1 = ":";
    dec3 = de.minute;
    unspec (formatted_string.minute) = substr (unspec (dec3), 19, 18);
    formatted_string.colon2 = ":";
    dec3 = de.second;
    unspec (formatted_string.second) = substr (unspec (dec3), 19, 18);
    formatted_string.dot = ".";
    dec3 = divide (de.microsecond, 1000, 20);
    unspec (formatted_string.millisecond) = substr (unspec (dec3), 10, 27);

    return (string (formatted_string));
%page;
/* START OF DECLARATIONS */
/* format: ^insnl,^delnl */


/* Parameters */

    dcl  clock_reading_i		 fixed bin (71) parm;


/* Automatic */

    dcl  code			 fixed bin (35);
    dcl  dec3			 fixed dec (3) aligned;
    dcl  zone			 char (3);

    dcl  1 de			 aligned,		/* Read de as decoded.			*/
	 2 month			 fixed bin,
	 2 dom			 fixed bin,
	 2 year			 fixed bin,
	 2 hour			 fixed bin,
	 2 minute			 fixed bin,
	 2 second			 fixed bin,
	 2 microsecond		 fixed bin (71),
	 2 dow			 fixed bin;

    dcl  1 formatted_string		 unal,
	 2 hour			 char (2),
	 2 colon1			 char (1),
	 2 minute			 char (2),
	 2 colon2			 char (1),
	 2 second			 char (2),
	 2 dot			 char (1),
	 2 millisecond		 char (3);


/* Static */


/* Conditions */


/* Based */


/* External Variables */


/* External Entries */

    dcl  decode_clock_value_$date_time	 entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (71), fixed bin, char (3), fixed bin (35));


/* format: insnl,delnl */
/* END OF DECLARATIONS */

  end trace_time_;




		    trace_transactions_.pl1         10/23/84  1334.8rew 10/23/84  1219.2       42777



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/*
   This program contains the trace operations that are too complicated for trace_.alm

   Written: May 1984 by Jeffrey D. Ives.
*/
/* format: style2,ifthendo,^indnoniterdo,thendo,^inditerdo,indproc,ind2,dclind5,idind32 */


trace_transactions_:
  procedure ();
    signal error;


/* INITIALIZE EVERYTHING is invoked by the firstref trap in trace_.alm. */

initialize_everything:
  entry ();

    unspec (my_area_info) = ""b;
    my_area_info.version = area_info_version_1;
    my_area_info.control.extend = "1"b;
    my_area_info.owner = trace_$me ();
    my_area_info.size = sys_info$max_seg_size;
    my_area_info.areap = null ();

    call define_area_ (addr (my_area_info), code);
    if code ^= 0
    then call sub_err_ (code, trace_$me (), ACTION_CANT_RESTART, null (), rv, "Call to define_area_ failed.");

    trace_catch_$trace_storage_ptr = my_area_info.areap;

    call trace_catch_$initialize ();

    call trace_tables_$initialize ();

    call trace_parameters_$initialize ();

    call add_epilogue_handler_ (trace_epilogue, code);
    if code ^= 0
    then call sub_err_ (code, trace_$me (), ACTION_DEFAULT_RESTART, null (), rv,
    "I could not add the epilogue handler.");

    return;


trace_epilogue:
  entry ();

    call transaction_begin_force (clock ());
    call trace_$set_enabled ("0"b);
    call trace_$set_output_switch (trace_$cv_stream_name_to_osw (""));
    if trace_$update_global_parms ()
    then;

    return;
%page;
/* TRANSACTION BEGIN */

transaction_begin:
  entry (transaction_id_i) returns (bit aligned);

    transaction_id = transaction_id_i;
    if transaction_id = 0
    then return ("0"b);

    if trace_$transaction_id ^= 0
    then return ("0"b);				/* A transaction is already in progress. */

    trace_$transaction_id = transaction_id;		/* Order is important for correct cleanup.	*/

    call trace_catch_$stop_tracing ();			/* Yank operator ptrs and move meters to tabs.	*/

    call trace_parameters_$transaction_begin ();

    call trace_tables_$transaction_begin ();

    return ("1"b);


/* TRANSACTION BEGIN FORCE */

transaction_begin_force:
  entry (transaction_id_i);

    trace_$transaction_id = transaction_id_i;		/* Order is important for correct cleanup.	*/

    call trace_catch_$stop_tracing ();			/* Yank operator ptrs and move meters to tabs.	*/

    call trace_parameters_$transaction_begin_force ();

    call trace_tables_$transaction_begin_force ();

    return;


/* TRANSACTION END */

transaction_end:
  entry (transaction_id_i) returns (bit aligned);

    if transaction_id_i ^= trace_$transaction_id
    then return ("0"b);

    call trace_parameters_$transaction_end ();

    call trace_tables_$transaction_end ();

    call trace_catch_$start_tracing ();			/* Plant operator ptrs and start global meters.	*/

    trace_$transaction_id = 0;

    return ("1"b);
%page;
/* START OF DECLARATIONS */
/* format: ^insnl,^delnl */

/* Parameters */

    dcl  transaction_id_i		 fixed bin (71) parm;


/* Automatic */

    dcl  code			 fixed bin (35);
    dcl  rv			 fixed bin (35);
    dcl  transaction_id		 fixed bin (71);

    dcl  1 my_area_info		 like area_info aligned;

/* Static */

    dcl  sys_info$max_seg_size	 fixed bin (35) ext;
    dcl  trace_catch_$trace_storage_ptr	 ptr ext;
    dcl  ZERO			 fixed bin (35) static options (constant) init (0);


/* Conditions */

    dcl  error			 condition;


/* Based */


/* External Variables */

    dcl  trace_$transaction_id	 fixed bin (71) ext;


/* External Entries */

    dcl  add_epilogue_handler_	 entry (entry, fixed bin (35));
    dcl  define_area_		 entry (ptr, fixed bin (35));
    dcl  sub_err_			 entry () options (variable);

    dcl  trace_catch_$initialize	 entry ();
    dcl  trace_catch_$start_tracing	 entry ();
    dcl  trace_catch_$stop_tracing	 entry ();
    dcl  trace_parameters_$initialize	 entry ();
    dcl  trace_parameters_$transaction_begin entry ();
    dcl  trace_parameters_$transaction_begin_force entry ();
    dcl  trace_parameters_$transaction_end entry ();
    dcl  trace_tables_$initialize	 entry ();
    dcl  trace_tables_$transaction_begin entry ();
    dcl  trace_tables_$transaction_begin_force entry ();
    dcl  trace_tables_$transaction_end	 entry ();


/* format: insnl,delnl */
/* END OF DECLARATIONS */
%page;
/* START OF INCLUDE FILES */


%include area_info;
%page;
%include sub_err_flags;
%page;
%include trace_interface;

  end trace_transactions_;




		    trace_version_.pl1              10/23/84  1334.9rew 10/23/84  1219.2        6849



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/*
   This program contains the identification of the trace facility.

   Written: May 1984 by Jeffrey D. Ives.
*/
/* format: style2,ifthendo,^indnoniterdo,thendo,^inditerdo,indproc,ind2,dclind5,idind32 */


trace_version_:
  procedure ();
    signal error;
    dcl  error			 condition;


me:
  entry () returns (char (32));

    return ("Trace");


version:
  entry () returns (char (32));

    return ("Version 3.0");

  end trace_version_;




		    watch.pl1                       01/11/85  1045.4rew 01/11/85  1035.0       94482



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/*

   This is the command interface to the watch part of the trace facility.

   Written: May 1984 by Jeffrey D. Ives.
*/
/* format: style2,ifthendo,^indnoniterdo,thendo,^inditerdo,indproc,ind2,dclind5,idind32 */
%page;
watch:
  procedure options (variable);

/* DISABLE TRACE_CATCH_ */

    transaction_id = clock ();
    on cleanup status = trace_$transaction_end (transaction_id);
						/* Disregard nonstandard use of status.	*/
    if ^trace_$transaction_begin (transaction_id) /* Temporarily disables trace_catch_.			*/
    then do;
      call com_err_ (code, ME, "There seems to be an incomplete invocation of trace,
watch, or trace_meters still on the stack.  Try the release command.");
      return;
    end;

/* SET UP A SUB_ERROR_ CONDITION HANDLER */

    call condition_ ("sub_error_", SUB_ERROR_HANDLER);

/* SET DEFAULT ACTIONS */

    add_remove_action = "";
    status = "0"b;

/* READ THE ARGUMENTS */

    call cu_$arg_count (arg_count, code);
    if code ^= 0
    then do;
      call com_err_ (code, ME);
      go to TRANSACTION_END;
    end;

    arg_idx = 1;
ARGUMENT_LOOP:
    do while (arg_idx <= arg_count);
      call cu_$arg_ptr (arg_idx, arg_ptr, arg_len, code);
      if code ^= 0
      then do;
        call com_err_ (code, ME);
        go to TRANSACTION_END;
      end;

      if length (arg) = 0
      then do;
        call com_err_ (code, ME, "A null argument was found where a location was expected.");
        go to TRANSACTION_END;
      end;

      if substr (arg, 1, 1) ^= "-"
      then
ENTRYPOINTS_ARGUMENT:
        do;
        call CHECK_NEXT_ARG (arg, 256, "watch", "locations", " control_args");
        call trace_$specify_locations ((arg));
        arg_idx = arg_idx + 1;
      end ENTRYPOINTS_ARGUMENT;

      else
CONTROL_ARGUMENT:
        do;
        if arg_idx + 1 > arg_count
        then next_arg_ptr = null ();
        else do;
	call cu_$arg_ptr (arg_idx + 1, next_arg_ptr, next_arg_len, code);
	if code ^= 0
	then do;
	  call com_err_ (code, ME);
	  go to TRANSACTION_END;
	end;

	if length (next_arg) > 0
	then if substr (next_arg, 1, 1) = "-"
	     then next_arg_ptr = null ();
        end;

        if arg = "-add" /* -add */
        then do;
	add_remove_action = "add";
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-changed" /* -changed */
        then do;
	call trace_$specify_changed_locations ();
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-remove" | arg = "-rm" /* -remove, -rm */
        then do;
	add_remove_action = "remove";
	arg_idx = arg_idx + 1;
        end;

        else if arg = "-status" | arg = "-st" /* -status, -st */
        then do;
	status = "1"b;
	arg_idx = arg_idx + 1;
        end;

        else do;
	call com_err_ (error_table_$badopt, ME, """^a""", arg);
	go to TRANSACTION_END;
        end;
      end CONTROL_ARGUMENT;
    end ARGUMENT_LOOP;
%page;
/* COMMIT ACTION and print a nice message something like this:

   Trace: 2 locations specified, 2 locations added.
*/

    call SAY_BEGIN ();

    n_specified = trace_$num_specified_locations ();

    if n_specified > 0
    then
LOCATION_ACTION:
      do;
      call SAY_N_LOCATIONS (n_specified, "specified");

      if add_remove_action = "" & ^status
      then add_remove_action = "add";

      if add_remove_action = "add"
      then
        begin;
	dcl  n_added		       fixed bin;
	dcl  n_updated		       fixed bin;
	call trace_$add_specified_locs (n_added, n_updated);
	call SAY_N_LOCATIONS (n_added, "added");
	if n_updated > 0
	then call SAY_N_LOCATIONS (n_updated, "updated");
        end;

      if add_remove_action = "remove"
      then
        begin;
	dcl  n_removed		       fixed bin;
	call trace_$remove_specified_locs (n_removed);
	call SAY_N_LOCATIONS (n_removed, "removed");
        end;
    end LOCATION_ACTION;

    n_locations = trace_$num_locations ();
    if n_locations = 0
    then call SAY ("watch table empty");
    else call SAY_N_LOCATIONS (n_locations, "in watch table");

    if ^trace_$enabled ()
    then call SAY ("trace is disabled");
    else if trace_$in_trace ()
    then call SAY ("trace is temporarily disabled");
    else if trace_$num_entrypoints () = 0
    then call SAY ("trace table empty");

    call SAY_END ();

    if status & n_locations ^= 0
    then
STATUS:
      begin;
        dcl  loc_idx		     fixed bin;
        dcl  loc_ptr		     ptr;
        dcl  n_not_in_wt		     fixed bin;
        dcl  old_seg_no		     bit (18) aligned;
        dcl  specified_loc_idx	     fixed bin;
        old_seg_no = ""b;
        n_not_in_wt = 0;
        if n_specified = 0
        then call ioa_ ("If you want status, you must specify some locations.");
        do specified_loc_idx = 0 to n_specified - 1;
	loc_idx = trace_$specified_location_index (specified_loc_idx);
	if loc_idx < 0
	then n_not_in_wt = n_not_in_wt + 1;
	else do;
	  loc_ptr = trace_$location_ptr (loc_idx);
	  if baseno (loc_ptr) ^= old_seg_no
	  then do;
	    call ioa_ ("^a", trace_$location_seg_path (loc_idx));
	    old_seg_no = baseno (loc_ptr);
	  end;
	  watch_values = trace_$location_values (loc_idx);
	  if watch_values.old = watch_values.new
	  then call ioa_ ("^20x^w    ^12x at ^p", watch_values.old, loc_ptr);
	  else call ioa_ ("^20x^w -> ^w at ^p", watch_values.old, watch_values.new, loc_ptr);
	end;
        end;
        if n_not_in_wt > 0
        then do;
	if n_not_in_wt = 1
	then call ioa_ ("^d of the specified locations was not in the watch table.", n_not_in_wt);
	else call ioa_ ("^d of the specified locations were not in the watch table.", n_not_in_wt);
        end;
      end STATUS;

    if arg_count = 0
    then call ioa_ ("Acts: -add/-remove -status.");

TRANSACTION_END:
    if ^trace_$transaction_end (transaction_id)		/* Re-enable trace_catch_. */
    then call com_err_ (ZERO, ME, "This invocation of the watch command ended abnormally.");

    return;



SAY:
  proc (action_i);
    if trace_$loud ()
    then do;
      call INIT ();
      call ioa_$nnl ("^a", action_i);
    end;
    return;

SAY_N_LOCATIONS:
  entry (num_i, action_i);
    if trace_$loud ()
    then do;
      call INIT ();
      if num_i = 1
      then call ioa_$nnl ("^d loc ^a", num_i, action_i);
      else call ioa_$nnl ("^d locs ^a", num_i, action_i);
    end;
    return;

SAY_BEGIN:
  entry ();
    n_things_said = 0;
    return;

SAY_END:
  entry ();
    if n_things_said > 0
    then call ioa_ (".");
    return;

INIT:
    proc ();
      if n_things_said = 0
      then call ioa_$nnl ("^a: ", ME);
      else call ioa_$nnl (", ");
      n_things_said = n_things_said + 1;
    end INIT;

    dcl  action_i			 char (*) parm;
    dcl  num_i			 fixed bin parm;
  end SAY;
%page;
CHECK_NEXT_ARG:
  proc (next_arg_i, max_arg_len_i, control_arg_i, syntax_i, comment_i);
    dcl  (next_arg_i, control_arg_i, syntax_i, comment_i)
				 char (*) parm;
    dcl  max_arg_len_i		 fixed bin (21);

    if addr (next_arg_i) = null ()
    then do;
      call com_err_ (error_table_$noarg, ME, "The syntax is: ^a ^a^a.", control_arg_i, syntax_i, comment_i);
      go to TRANSACTION_END;
    end;

    if length (next_arg_i) > max_arg_len_i
    then do;
      call com_err_ (error_table_$bigarg, ME, "The maximum length for ^a is ^d characters.
The syntax is: ^a ^a^a.", syntax_i, max_arg_len_i, control_arg_i, syntax_i, comment_i);
      go to TRANSACTION_END;
    end;
  end CHECK_NEXT_ARG;
%page;
/* SUBROUTINES */

SUB_ERROR_HANDLER:
  proc (mcptr_i, a_name_i, wcptr_i, info_ptr_i, continue_o);
    sub_error_info_ptr = info_ptr_i;
    condition_info_header_ptr = null ();
    if sub_error_info.name ^= trace_$me ()
    then go to CONTINUE;
    if sub_error_info.header.support_signal | sub_error_info.header.quiet_restart
    then go to HANDLED;
    if sub_error_info.header.default_restart
    then go to REPORT;
    if sub_error_info.header.cant_restart
    then go to REPORT_AND_ABORT;
    else go to CONTINUE;

REPORT_AND_ABORT:
    call com_err_ (sub_error_info.header.status_code, ME, "^a", sub_error_info.header.info_string);
    go to TRANSACTION_END;

REPORT:
    call com_err_ (sub_error_info.header.status_code, ME, "^a", sub_error_info.header.info_string);

HANDLED:
    continue_o = "0"b;
    return;

CONTINUE:
    continue_o = "1"b;
    return;

    dcl  mcptr_i			 ptr parm;
    dcl  a_name_i			 char (*) parm;
    dcl  info_ptr_i			 ptr parm;
    dcl  wcptr_i			 ptr parm;
    dcl  continue_o			 bit aligned;

%include condition_info_header;

%include sub_error_info;

  end SUB_ERROR_HANDLER;
%page;
/* START OF DECLARATIONS */
/* format: ^insnl,^delnl */


/* Automatic */

    dcl  add_remove_action		 char (8) init ("");
    dcl  arg_count			 fixed bin init (0);
    dcl  arg_idx			 fixed bin init (0);
    dcl  arg_len			 fixed bin (21) init (0);
    dcl  arg_ptr			 ptr init (null ());
    dcl  code			 fixed bin (35) init (0);
    dcl  n_locations		 fixed bin;
    dcl  n_specified		 fixed bin init (0);
    dcl  n_things_said		 fixed bin init (0);
    dcl  next_arg_idx		 fixed bin init (0);
    dcl  next_arg_len		 fixed bin (21) init (0);
    dcl  next_arg_ptr		 ptr init (null ());
    dcl  status			 bit aligned init ("0"b);
    dcl  transaction_id		 fixed bin (71) init (0);


/* Static */

    dcl  ME			 char (32) static options (constant) init ("watch");
    dcl  ZERO			 fixed bin (35) static options (constant) init (0);


/* Conditions */

    dcl  cleanup			 condition;


/* Based */

    dcl  arg			 char (arg_len) based (arg_ptr);
    dcl  next_arg			 char (next_arg_len) based (next_arg_ptr);


/* External Variables */

    dcl  error_table_$badopt		 fixed bin (35) ext;
    dcl  error_table_$bigarg		 fixed bin (35) ext;
    dcl  error_table_$noarg		 fixed bin (35) ext;


/* External Entries */

    dcl  com_err_			 entry options (variable);
    dcl  condition_			 entry (char (*), entry);
    dcl  cu_$arg_count		 entry (fixed bin, fixed bin (35));
    dcl  cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
    dcl  ioa_			 entry () options (variable);
    dcl  ioa_$nnl			 entry () options (variable);


/* format: insnl,delnl */
/* END OF DECLARATIONS */
%page;
/* START OF INCLUDE FILES */


%include trace_interface;


  end watch;

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