



		    as_meters.pl1                   08/04/87  1455.5rew 08/04/87  1222.1      155664



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

as_meters: proc;

/* Command to print >sc1>as_meter_table.
   Coded by Tom Casey, March 1980.
   Modified May 1981 by T. Casey to print asmt meters in header.
   Modified June 1981 by T. Casey for MR9.0 to print the ABS_TRYLOG meter.
   Modified July 1981 by T. Casey to add -reset, -report_reset, &c.
*/


/****^  HISTORY COMMENTS:
  1) change(87-07-21,Herbst), approve(87-07-21,MCR7694),
     audit(87-07-21,GDixon), install(87-08-04,MR12.1-1055):
      A) Update for AS_METER_NAMES array declared in
         as_meter_numbers.incl.pl1.
                                                   END HISTORY COMMENTS */


/* Ext. Entries */

dcl  cu_$arg_count entry returns (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl (ioa_, ioa_$rsnnl, com_err_) entry options (variable);
dcl  date_time_ entry (fixed bin (71), char (*));
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));
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  release_temp_segment_ entry (char (*), ptr, fixed bin (35));

/* Automatic and Based */

dcl  code fixed bin (35);
dcl  ignore_code fixed bin (35);			/* crossref will show where we ignore return codes */
dcl  i fixed bin;
dcl (month, day, year, hour, minute, second, dow) fixed bin;
dcl  usec fixed bin (71);
dcl  zone char (3) init ("");
dcl (asmtp, asmtep) ptr init (null);
dcl  argp ptr, argl fixed bin, arg char (argl) based (argp);
dcl  totalsw bit (1) aligned init (""b);
dcl  namesw bit (1) aligned init ("1"b);
dcl  shortnamesw bit (1) aligned init (""b);
dcl  total_real_time fixed bin (71);
dcl  sigma_vcpu fixed bin (71) init (0);
dcl  sigma_pf fixed bin (34) init (0);

dcl  dtstr char (16);
dcl  now fixed bin (71);
dcl  today char (8);
dcl (reset_sw, report_reset_sw, un_reset_sw, temp_un_reset_sw, pct_sw,
     no_header_sw, meter_sw) bit (1) aligned init (""b);

dcl  asmt_copy (asmt_length) fixed bin (35) aligned based;	/* overlay to copy asmt segment */
dcl  asmt_length fixed bin;				/* length of overlay */

dcl 1 rasmt like asmt aligned based (real_asmtp);		/* "rasmt" is easier to type than "real_asmtp -> asmt" */

/* Static */

dcl  real_asmtp ptr int static init (null);		/* ptr to real as_meter_table, in >sc1 (or test dir) */
dcl  temp_ptr (2) ptr int static init ((2) null);		/* ptrs to two temp segs */
dcl  prev_asmtp ptr defined (temp_ptr (1));		/* 1st one points to copy of as_meter_table made at reset time */
dcl  diff_asmtp ptr defined (temp_ptr (2));		/* 2nd one points to difference between copy and current values */

dcl  reset bit (1) int static init (""b);		/* on if we have saved a copy because user said -reset */
dcl  reset_time fixed bin (71) int static;		/* time that reset was done */

dcl  selected (36) bit (1) unaligned int static init ((36) (1)"1"b);
dcl  sysdir char (168) int static init (">sc1");

/* Constant */

dcl  me char (9) int static options (constant) init ("as_meters");
dcl  digits char (10) int static options (constant) init ("0123456789");

dcl  UPPER char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
dcl  LOWER char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz");

/* Builtin */

dcl (addr, clock, divide, float, hbound, length, ltrim, mod, null, size, substr, translate) builtin;

	if real_asmtp = null then do;			/* get ptr to as_meter_table if we don't already have it */
	     call hcs_$initiate (sysdir, "as_meter_table", "", (0), (1), real_asmtp, code);
	     if real_asmtp = null then do;
		call com_err_ (code, me, "^a>as_meter_table", sysdir);
		return;
	     end;
	end;

	now = clock ();
	call date_time_ (now, dtstr);
	today = substr (dtstr, 1, 8);

	do i = 1 to cu_$arg_count ();
	     call cu_$arg_ptr (i, argp, argl, ignore_code);
	     if arg = "-tt" | arg = "-total" | arg = "-totals" then
		totalsw = "1"b;
	     else if arg = "-sh" | arg = "-short"
	     | arg = "-short_name" | arg = "-shnm" then do;
		shortnamesw = "1"b;
		namesw = ""b;
	     end;
	     else if arg = "-rs" | arg = "-reset" then
		reset_sw = "1"b;
	     else if arg = "-rrs" | arg = "-report_reset" then
		reset_sw, report_reset_sw = "1"b;
	     else if arg = "-urs" | arg = "-unreset" then
		un_reset_sw = "1"b;
	     else if arg = "-turs" | arg = "-temp_unreset" then
		temp_un_reset_sw = "1"b;
	     else if arg = "-pct" | arg = "-percent" then
		pct_sw = "1"b;
	     else if arg = "-nhe" | arg = "-no_header" then
		no_header_sw = "1"b;
	     else if arg = "-mt" | arg = "-meter" then
		call get_selected_meter_names;
	     else do;
		call com_err_ (0, "as_meters", "Unknown argument: ^a", arg);
		return;
	     end;
	end;					/* end loop thru arglist */

/* Decide what to do: report, reset, or some combination or variation of them */

	if reset_sw then				/* if user wants to reset now */
	     if ^report_reset_sw then			/* and he doesn't want a report first */
		goto do_reset;			/* go do the reset */

	asmtp = real_asmtp;				/* assume we'll print real asmt, until we discover otherwise */

	if un_reset_sw then				/* if user wants to permanently cancel a previous reset */
	     if reset then				/* and there was one */
		do;				/* then cancel it */
		reset = ""b;			/* forget it was done */
		call release_temp_segment_ (me, prev_asmtp, code); /* release the seg it was in */
		if code ^= 0 then goto temp_seg_error;
	     end;

	if reset then				/* if we did a reset previously */
	     if ^temp_un_reset_sw then		/* and user doesn't want to temporarily ignore it */
		do;				/* then subtract previous values from current ones */
		call get_temp_segment_ (me, diff_asmtp, code); /* we always release this when done printing */
		if code ^= 0 then goto temp_seg_error;
		asmtp = diff_asmtp;			/* we'll print the seg containing the differences */
		asmt =				/* if this works, I'll buy the compiler writers a beer */
		     real_asmtp -> asmt - prev_asmtp -> asmt; /* subtract everything */
	     end;

/* Compute total real time. This does not include real time spent in un-metered code, so it is a little low. */

	total_real_time = 0;
	do i = 1 to hbound (asmt.entry, 1);		/* add up individual real times */
	     total_real_time = total_real_time + asmt.entry (i).real_time; /* NOT tot_real_time */
	end;					/* that would be double counting */

/* Print header */

	if no_header_sw then goto skip_header;

	if ^totalsw then				/* print heading (different if reset or not) */
	     if reset & ^temp_un_reset_sw then
		call ioa_ ("Reset at ^a; metering time: ^a", dt (reset_time), ti (now - reset_time));
	     else call ioa_ ("Startup at ^a, vcpu = ^.3f, pf = ^d; metering time: ^a", dt (asmt.startup_clock),
		asmt.startup_vcpu/1.0e6, asmt.startup_pf, ti (now - asmt.startup_clock));
	call ioa_ ("Latest update^[ (in progress)^] at ^a, rt = ^.3f, vcpu = ^.3f, pf = ^d",
	     (rasmt.update_in_progress ^= 0), dt (rasmt.latest_clock),
	     total_real_time/1.0e6, asmt.latest_vcpu/1.0e6, asmt.latest_pf);

	if totalsw then goto do_reset;		/* no more output wanted; go reset (if wanted) & return */

	if rasmt.global_entered > 0 then
	     call ioa_ ("There ^[is^;are^] ^d call^[s^] in progress.",
	     (rasmt.global_entered = 1), rasmt.global_entered, (rasmt.global_entered > 1));

	call ioa_ ("Logins: ^d int, ^d abs, ^d dmn; logouts: ^d int, ^d abs, ^d dmn.", asmt.logins, asmt.logouts);

	call ioa_ ("ASMT: ^d, RT: ^.3f, VCPU: ^.3f, PF: ^d^/",
	     asmt.asmt_count, asmt.asmt_real_time/1.0e6, asmt.asmt_vcpu/1.0e6, asmt.asmt_pf);

/* Print a line of column headings, and then one or more lines for each used (and selected) entry */

	call ioa_ ("^5tUPD_TIME^14tCOUNT^20tTOTAL_REAL^31tTOTAL_VCPU^42tTOTALPF^50t^6xREAL^61t^6xVCPU^72t^5xPF");
	if pct_sw then call ioa_;			/* blank line if printing 4-line group per entry */

skip_header:

	do i = 1 to hbound (asmt.entry, 1);
	     asmtep = addr (asmt.entry (i));
	     if asmte.entry_count > 0 & selected (i) then do;
		call ioa_ (
"^[^3a^s^;^s^2d)^]^[*^;^x^]^8a^14t^5d^[(^d)^;^s^]^20t^10.3f^31t^10.3f^42t^7d^50t^10.3f^61t^10.3f^72t^7d^[^x^a^]",
		     shortnamesw, substr (AS_METER_NAMES (i), 1, 3), i, 
		     asmte.entered > 0, tm (rasmt.entry (i).update_clock),
		     asmte.entry_count, (asmte.recursive_entry_count ^= 0),
		     asmte.recursive_entry_count,
		     asmte.tot_real_time/1.0e6, asmte.tot_vcpu/1.0e6,
		     asmte.tot_pf, 
		     asmte.real_time/1.0e6, asmte.vcpu/1.0e6, asmte.pf,
		     namesw, AS_METER_NAMES (i));
		sigma_vcpu = sigma_vcpu + asmte.vcpu;
		sigma_pf = sigma_pf + asmte.pf;

/* If -pct arg given, print 3 more lines for this entry:
     percent of total, per-call usage, pf per (real vcpu) sec */

		if pct_sw then do;

/* percent of total */
		     if asmt.latest_pf > 0 then	/* avoid zerodivides */
			call ioa_ ("^5t% of tot^20t^8.1f%^31t^8.1f%^42t^6.1f%^50t^8.1f%^61t^8.1f%^72t^6.1f%",
			(1.0e2*asmte.tot_real_time)/total_real_time,
			(1.0e2*asmte.tot_vcpu)/asmt.latest_vcpu,
			(1.0e2*asmte.tot_pf)/asmt.latest_pf,
			(1.0e2*asmte.real_time)/total_real_time,
			(1.0e2*asmte.vcpu)/asmt.latest_vcpu,
			(1.0e2*asmte.pf)/asmt.latest_pf);

/* per-call usage */
		     call ioa_ ("^5tper-call^20t^10.3f^31t^10.3f^42t^7.2f^50t^10.3f^61t^10.3f^72t^7.2f",
			asmte.tot_real_time / (1.0e6*asmte.entry_count),
			asmte.tot_vcpu/ (1.0e6*asmte.entry_count),
			float (asmte.tot_pf)/asmte.entry_count,
			asmte.real_time/ (1.0e6*asmte.entry_count),
			asmte.vcpu/ (1.0e6*asmte.entry_count),
			float (asmte.pf)/asmte.entry_count);

/* page faults per real and vcpu second */
		     if asmte.vcpu > 0 then		/* avoid zerodivides */
			call ioa_ ("^5tpf/sec^20t^8.1f^31t^8.1f^50t^8.1f^61t^8.1f",
			(1.0e6*asmte.tot_pf)/asmte.tot_real_time,
			(1.0e6*asmte.tot_pf)/asmte.tot_vcpu,
			(1.0e6*asmte.pf)/asmte.real_time,
			(1.0e6*asmte.pf)/asmte.vcpu);
		     call ioa_;			/* separate the 4-line per-entry groups with blank lines */
		end;				/* end -pct given */
	     end;					/* end this entry used and selected */
	end;					/* end loop thru all entries */

/* Compute and print the "Other" usage, i.e. that not included in any of the above meters */

	if ^meter_sw then do;			/* only when printing all meters */
	     sigma_vcpu = asmt.latest_vcpu - sigma_vcpu - asmt.startup_vcpu;
	     sigma_pf = asmt.latest_pf - sigma_pf - asmt.startup_pf;
	     call ioa_ ("^/Other (not metered) vcpu and pf:^61t^10.3f^72t^7d", sigma_vcpu/1.0e6, sigma_pf);
	     if pct_sw
	     & asmt.latest_pf > 0 then		/* avoid zerodivides */
		call ioa_ ("^61t^8.1f%^72t^6.1f%", (1.0e2*sigma_vcpu)/asmt.latest_vcpu, (1.0e2*sigma_pf)/asmt.latest_pf);
	     call ioa_;				/* blank line at end */
	end;

/* If we did a reset previously, release the temp seg containing the differences. */
	if reset then do;
	     call release_temp_segment_ (me, diff_asmtp, code);
	     if code ^= 0 then goto temp_seg_error;
	end;

/* If user wants to do a reset now, save a copy of the live asmt */

do_reset:	if reset_sw then do;			/* if user wants to reset now, save current values */
	     if prev_asmtp = null then do;		/* if we don't have a temp seg to save them, get one */
		call get_temp_segment_ (me, prev_asmtp, code);
		if code ^= 0 then goto temp_seg_error;
	     end;
	     asmt_length = size (asmt);		/* size of stuff to copy */
	     prev_asmtp -> asmt_copy = real_asmtp -> asmt_copy;
	     reset_time = now;
	     reset = "1"b;				/* remember that we have saved the values */
	end;

	return;

temp_seg_error: call com_err_ (code, me, "(temp segment)");
error_return:
	return;

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

dt:	proc (clk) returns (char (17) varying);		/* to format and return the date (if not today) and time */

dcl  clk fixed bin (71);
dcl  c17 char (17) varying;
dcl  c8 char (8);
dcl  hhmmss char (8) init ("hh:mm:ss");
dcl  dtsw bit (1) aligned;

	     dtsw = "1"b;
	     goto dt_common;

tm:	     entry (clk) returns (char (8));		/* to format and return just the time */

	     dtsw = ""b;

dt_common:
	     call date_time_ (clk, dtstr);
	     call decode_clock_value_$date_time (clk, month, day, year, hour, minute, second, usec, dow, zone, code);
	     substr (hhmmss, 1, 2) = substr (dtstr, 11, 2); /* whoever invented the tenths of a minute date time format */
	     substr (hhmmss, 4, 2) = substr (dtstr, 13, 2); /* should be forced to use watches and clocks */
	     if code = 0 then do;			/* whose faces are calibrated in tenths of a minute */
		substr (hhmmss, 7, 1) = substr (digits, 1+divide (second, 10, 17, 0)); /* and whose second hands */
		substr (hhmmss, 8, 1) = substr (digits, 1+mod (second, 10)); /* jump ahead every 6 seconds */
	     end;
	     else substr (hhmmss, 7, 2) = "??";		/* if code is nonzero, we don't know the seconds */

	     if dtsw then do;			/* return date (if not today) as well as time */
		if substr (dtstr, 1, 8) = today then
		     c17 = hhmmss;			/* just return time, since date is today */
		else do;
		     c17 = substr (dtstr, 1, 8);
		     c17 = c17 || " ";
		     c17 = c17 || hhmmss;
		end;
		return (c17);
	     end;
	     else do;				/* we can only return 8 chars, so just return time */
		c8 = hhmmss;
		if substr (dtstr, 1, 8) ^= today then do; /* KLUDGE to flag time as not in current day */
		     substr (c8, 3, 1) = "!";		/* I said it was a kludge ... */
		     substr (c8, 6, 1) = "!";		/* but we only have 8 characters */
		end;

		return (c8);
	     end;

	end dt;

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

get_selected_meter_names: proc;			/* process args after -meter */

dcl  ix fixed bin;
dcl  name_arg char (8) varying;

	     if ^meter_sw then do;			/* if this is first -meter arg on command line */
		selected (*) = ""b;			/* clear all the switches */
		meter_sw = "1"b;			/* remember that we did so */
	     end;

get_next_meter_arg:
	     call cu_$arg_ptr (i+1, argp, argl, code);	/* look at next arg */
	     if code ^= 0 then return;		/* if no more args */
	     if substr (arg, 1, 1) = "-" then return;	/* if it is a control arg */

	     i = i + 1;				/* we're going to use this arg; bump index to next one */

	     if arg = "all" then do;
		selected (*) = "1"b;
		meter_sw = ""b;			/* we aren't printing a subset of the meters */
		return;
	     end;

	     name_arg = translate (arg, UPPER, LOWER);	/* get it in all upper case */

	     do ix = 1 to hbound (AS_METER_NAMES, 1)	/* look for exact match between arg and meter name */
		while (AS_METER_NAMES (ix) ^= name_arg); end;

	     if ix <= hbound (AS_METER_NAMES, 1) then do;
		selected (ix) = "1"b;
		goto get_next_meter_arg;
	     end;

	     do ix = 1 to hbound (AS_METER_NAMES, 1)	/* look for match between arg and first few chars of meter name */
		while (substr (AS_METER_NAMES (ix), 1, length (name_arg)) ^= name_arg); end;

	     if ix <= hbound (AS_METER_NAMES, 1) then do;
		selected (ix) = "1"b;
		goto get_next_meter_arg;
	     end;

	     call com_err_ (0, me, "Unknown meter name: ^a", arg);
	     goto error_return;

	end get_selected_meter_names;

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

ti:	proc (int) returns (char (9) varying);		/* format and return a time interval as HHH:MM:SS */

dcl  int fixed bin (71);
dcl  rs char (9) varying;
dcl  int_pic pic "zzzzzzzz9";
dcl  sum fixed bin;

	     hour = divide (int, 3600*1000000, 71, 0);
	     minute = divide (int, 60*1000000, 71, 0) - hour*60;
	     second = divide (int, 1000000, 71, 0) - hour*3600 - minute*60;
	     sum = second + minute*1000 + hour*1000000;	/* HHH0MM0SS */

	     if sum > 999999999 then do;		/* avoid blowup in picture conversion */
		if hour > 999999 then
		     rs = "999999+hr";
		else call ioa_$rsnnl ("^6d+hr", rs, (0), hour);
	     end;
	     else do;
		int_pic = sum;
		if substr (int_pic, 3, 1) ^= " " then substr (int_pic, 4, 1) = ":"; /* HHH:MM0SS */
		if substr (int_pic, 6, 1) ^= " " then substr (int_pic, 7, 1) = ":"; /* HHH:MM:SS */
		rs = ltrim (int_pic);
	     end;

	     return (rs);

	end ti;

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

test:	entry (testdir);

dcl  testdir char (*);

	sysdir = testdir;				/* the arg better be there, or we'll take a fault */

	if real_asmtp ^= null then			/* be sure to initiate new segs */
	     call hcs_$terminate_noname (real_asmtp, ignore_code);

	do i = 1 to 2;
	     if temp_ptr (i) ^= null then
		call release_temp_segment_ (me, temp_ptr (i), ignore_code);
	end;
	reset = ""b;				/* in case there was a reset in effect */

	return;
 %include as_meter_numbers;
 %include as_meter_table;

     end as_meters;




		    as_who.pl1                      10/16/92  1251.6r w 10/16/92  1249.0      353862



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


/* format: style4 */

/* AS_WHO - print information about who's on Multics.
   This is a privileged version for use by the Answering Service.
   This entry point also works as an active function, which returns
   Person_id.Project_id of processes which would have been printed.

   AS_WHO$LONG - same thing, but more information.

   AS_WHO$HMU - give header lines with nusers and load.

   This command types out the userid's of listed logged-in users
   from the segment "answer_table", which is maintained by the answering service
   program "lg_ctl_". The possible arguments are as follows:

   .	-lg	print "long who"
   .	-nhe	omit headers
   .	-as	print information on absentee users
   .	-dmn	print information on daemon users
   .	-sc	print information on secondary users
   .      -cpu      print information about cpu usage
   .      -idle     print information about idle time
   .	-connected   
   .                print information about connected processes
   .	-disc	print information about disconnected processes
   .      -process_id, -pid 
   .                print out the process id for each process listed
   .	-pdir_volume {LVname}
   .	-pdv {LVname}  
   .                print pdir volumes, or print only users with pdir volume = LVname
   . 	-channel channel_id_starname
   . 	-chn channel_id_starname
   .		print information on users using named channels
   .	-gp xx	print information on group xx
   .	-nm	sort lines on user name
   .	-pj	sort lines on project id
   .		(the default sort is by time logged in)
   .      -ia       print information on interactive users
   .	Name	list only users with person name "Name"
   .	.Proj	list only users with project name "Proj"
   .	Name.Proj	list only users with person name "Name" and project "Proj"
   END DESCRIPTION */


/****^  HISTORY COMMENTS:
  1) change(70-09-06,VanVleck), approve(), audit(), install():
     Initial coding.
  2) change(71-07-01,EDS), approve(), audit(), install():
     for absentees.
  3) change(76-07-01,Wells), approve(), audit(), install():
     to understand about FTP channels.
  4) change(77-08-01,Casey), approve(), audit(), install():
     to optionally print the pdir volume of each user.
  5) change(78-09-01,Johnson), approve(), audit(), install():
     for long tty channel names (ring0 demultiplexing).
  6) change(78-12-01,Casey), approve(), audit(), install():
     to know about the foreground absentee queue.
  7) change(79-03-21,GDixon), approve(), audit(), install():
     to add -channel, -no_header and [as_who].
  8) change(79-04-01,Casey), approve(), audit(), install():
     for MR7.0a to print foreground and background absentee users
     separately in heading.
  9) change(79-12-01,Hornig), approve(), audit(), install():
     for process preservation and max_users.
 10) change(80-09-06,VanVleck), approve(), audit(), install():
     for CPU and Idle.
 11) change(80-12-01,Kittlitz), approve(), audit(), install():
     for hmu ignore most control args.
 12) change(81-07-07,Herbst), approve(), audit(), install():
     to allow starnames and not implicitly assume Name -> Name*.
 13) change(81-07-07,Herbst), approve(), audit(), install():
     as_who$hmu fixed not to list names with -ia.
 14) change(81-11-01,Kittlitz), approve(), audit(), install():
     user_table_entry conversion.
 15) change(81-12-01,Kittlitz), approve(), audit(), install():
     whotab changes.
 16) change(84-11-01,Pandolf), approve(), audit(), install():
     to include hc_lock.
 17) change(85-12-12,Newcomb), approve(85-12-12,MCR7263),
     audit(86-01-09,Margolin), install(86-01-28,MR12.0-1008):
     added the -connected ctl arg; made some minor corrections to declarations
     and argument processing/AF usage; changed to use ssu_ standalone
     invocation; fixed some unreported bugs.
 18) change(86-03-18,MSharpe), approve(86-04-28,MCR7405),
     audit(86-07-01,EJSharpe), install(86-08-18,MR12.0-1130):
     Added -process_id (-pid) control arg, Removed undocumented -net
     control arg.
 19) change(86-07-10,Hartogs), approve(86-07-10,MCR7451),
     audit(86-08-14,GWMay), install(86-08-18,MR12.0-1130):
     Fix bugs in as_who.  Correct so that idle and cpu times include number of
     hours.  Access ring0_peek only when necessary, thereby allowing use by
     users with access to some system tables.
 20) change(86-08-22,Hartogs), approve(86-08-22,PBF7451),
     audit(86-08-22,Lippard), install(86-08-22,MR12.0-1139):
     Fixed to work with .project_id.
 21) change(87-04-26,GDixon), approve(87-05-01,MCR7741),
     audit(87-05-06,Parisek), install(87-08-03,MR12.1-1055):
     Upgraded for change to answer_table.incl.pl1 and user_table_entry.incl.pl1
 22) change(87-08-11,Hartogs), approve(87-08-11,MCR7714),
     audit(87-08-11,Lippard), install(87-08-13,MR12.1-1085):
     Fixed to work correctly on successive invocation with -idle and -cpu.
 23) change(91-03-21,Vu), approve(91-03-21,MCR8244), audit(91-12-05,Zimmerman),
     install(91-12-06,MR12.5-1002):
     as_who incorrectly interprets preemption.
 24) change(92-10-02,Zimmerman), approve(92-10-02,MCR8269),
     audit(92-10-05,WAAnderson), install(92-10-16,MR12.5-1026):
     Lack of access to copy info from tc_data is now reported on each
     invocation, rather than once per process.
                                                   END HISTORY COMMENTS */

%page;
as_who:
     procedure options (variable, separate_static);

/* START OF DECLARATIONS */

/* Automatic */
dcl  argno fixed bin init (0),			/* number of argument */
     arg_count fixed bin init (0),
     retp ptr init (null ()),				/* ptr to af return arg. */
     ap ptr init (null ()),				/* ptr to argument */
     (pp1, pp2) ptr init (null ()),			/* temporaries */
     al fixed bin (21) init (0),			/* lth of argument */
     code fixed bin (35) init (0),			/* file-system error code */
     (f1, f2) float bin init (0),			/* conversion temps */
     retl fixed bin (21) init (0),			/* max length of af return arg. */
     sort fixed bin init (SORT_BY_DATE),		/* type of sort */
     no_usage bit (1) init (FALSE),			/* 1 if can't get CPU usage */
     have_read_apt bit (1) init (FALSE),
     long bit (1) aligned init (FALSE),			/* 1 if long who wanted */
     abs bit (1) aligned init (FALSE),			/* 1 if only information on absentee users */
     afsw bit (1) aligned init (FALSE),			/* 1 if as_who entry invoked as active fnc */
     dmn bit (1) aligned init (FALSE),			/* 1 if only info on daemon users */
     iasw bit (1) aligned init (FALSE),			/* 1 if interactives. */
     connected_sw bit (1) aligned init (FALSE),		/* 1 if only connected */
     disc_sw bit (1) aligned init (FALSE),		/* 1 if only disconnected */
     chnsw bit (1) aligned init (FALSE),		/* 1 if only users of given channels selected. */
     nhesw bit (1) aligned init (FALSE),		/* 1 if headings should not be printed. */
     no_ulist bit (1) aligned init (FALSE),		/* 1 if only header ("hmu" cmd) */
     pid_sw bit (1) aligned init (FALSE),		/* 1 if displaying pid */
     sbsw bit (1) aligned init (FALSE),			/* 1 if only secondarys */
     selgp char (8) aligned init (""),			/* Selects group */
     selx fixed bin init (0),				/* if particular users wanted */
     sel_starsw bit (1) init (FALSE),			/* ON if asking for a set of users */
     dotl fixed bin init (0),				/* location of dot in arg */
     channel_name char (32),				
     chnnm char (32) init ("**"),		/* channels tag used to select users. */
     sel_names (100) char (32),
     (i, j) fixed bin init (0),			/* index */
     ary (256) fixed bin,				/* sort array */
     d fixed bin init (0),				/* distance between sorted elems */
     last fixed bin init (0),				/* highest index in whotab */
     swap fixed bin init (0),				/* 1 if a swap was done */
     ajd fixed bin init (0),				/* temp for sort, ary(j+d) */
     (time, time1) char (16) init (""),			/* ASCII time */
     why char (124) init (""),			/* reason for shutdown */
     clock_time fixed bin (71) init (0),
     (prim, nolist, anon) char (1) init (""),		/* pretty print temps */
     grp char (8) init (""),				/* ... */
     absdn char (168) init (""),			/* ... */
     absen char (32) init (""),			/* ... */
     aj fixed bin init (0),				/* temp, ary(j) */
     did fixed bin init (0),				/* count of lines printed */
     abs_name char (6) init (""),			/* temp for absentee equiv of tty name */
     select_sw fixed bin init (0),			/* switch to indicate whether user is selected */
     pers char (28) init (""),			/* temp for name */
     proj char (28) init (""),			/* temp for project */
     process_id bit (36),				/* temp for 1st half of pid */
     absentee_users fixed bin init (0),			/* temp for max number of absentee users */
     abs_running fixed bin init (0),			/* Shows any residual users */
     foreground_users fixed bin init (0),		/* temp for number of foreground absentee users */
     fancy char (1),				/* used to eliminate certain new line chars on hmu */
     k fixed bin init (0);				/* index */
dcl  max_chan_name fixed bin init (6);			/* max length of name of a tty channel */
dcl  pdvsw bit (1) init (FALSE);
dcl  pdlvix fixed bin init (0);
dcl  lvnm char (32) init ("");
dcl  proc_usage char (10) init ("");
dcl  proc_idle char (10) init ("");
dcl  (cpusw, idlesw) bit (1) init (FALSE);
dcl  sci_ptr ptr init (null ());

/* Based */
dcl
     arg char (al) unaligned based (ap),		/* pickup for args */
     ret char (retl) varying based (retp);		/* af return argument. */

/* Constant */
dcl  (
     FALSE bit (1) init ("0"b),
     MY_NAME char (6) init ("as_who"),
     MY_NAME_HMU char (21) init ("as_who$how_many_users"),
     MY_NAME_LONG char (11) init ("as_who$long"),
     NL char (1) init ("
"),
     SORT_BY_DATE fixed bin init (0),
     SORT_BY_NAME fixed bin init (1),
     SORT_BY_PROJECT fixed bin init (2),
     TEN_UNITS fixed bin init (10.0e0),                    /* Ten units are stored for each normal user */
     TRUE bit (1) init ("1"b)
     ) int static options (constant);

/* Internal Static */
dcl  (
     ip ptr init (null),				/* ptr to installation_parms */
     initializer_process bit (1) init ("0"b /* FALSE */),
     static_ansp ptr init (null),			/* ptr to answer table */
     static_autp ptr init (null),			/* ptr to absentee user table, used to decide when to */
						/* re-init various pointers to tables */
     static_dtp ptr init (null),
     static_dutp ptr init (null),			/* ptr to daemon user table */
     sysdir char (64) init (""),			/* must be set first time through */
     tcml fixed bin (19) init (0),
     tcmp0 ptr init (null ()),
     whoptr ptr init (null)				/* ptr to system "whotab" */
     ) int static;

/* Error codes */
dcl  (error_table_$badopt,
     error_table_$logical_volume_not_defined,
     error_table_$noarg,
     error_table_$too_many_args
     ) fixed bin (35) ext static;

/* Entry */
dcl  check_star_name_$entry entry (char(*), fixed bin(35));
dcl  match_star_name_ entry (char(*), char(*), fixed bin(35));
dcl  disk_table_$get_dtp entry (ptr);
dcl  mdc_$read_disk_table entry (ptr, fixed bin (35));
dcl  get_process_id_ entry returns (bit (36));
dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  (ioa_, ioa_$nnl) entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35));
dcl  ring_zero_peek_ entry (ptr, ptr, fixed bin (19), fixed bin (35));
dcl  ring_zero_peek_$get_max_length_ptr entry (ptr, fixed bin (19), fixed bin (35));
dcl  ssu_$abort_line entry () options (variable);
dcl  ssu_$arg_count entry (ptr, fixed bin);
dcl  ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21));
dcl  ssu_$destroy_invocation entry (ptr);
dcl  ssu_$get_temp_segment entry (ptr, char (*), ptr);
dcl  ssu_$return_arg entry (ptr, fixed bin, bit (1) aligned, ptr,
	fixed bin (21));
dcl  ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry,
	fixed bin (35));

/* External static */
dcl  sys_info$system_control_dir char (168) varying aligned external static;

/* Builtin */
dcl  (addr, addrel, clock, divide, fixed, hbound, index, length, max, null, rtrim, search, substr) builtin;

/* Condition */
dcl  cleanup condition;
%page;
/* as_who:					*/
/*     procedure options (variable, separate_static);	*/

	on cleanup call clean_up ();
	call ssu_$standalone_invocation (sci_ptr, MY_NAME, "",
	     null (), ABORT_ENTRY, code);
	if code ^= 0 then go to exit_no_cleanup;

	call ssu_$return_arg (sci_ptr, arg_count, afsw,
	     retp, retl);

	if afsw then do;
	     ret = "";
	     nhesw = TRUE;
	end;

arglp:	if arg_count ^= 0 then
READ_ARGS:     do argno = 1 to arg_count;
	     call ssu_$arg_ptr (sci_ptr, argno, ap, al);	/* get nth argument */

	     if arg = "-nm" | arg = "-name" then sort = SORT_BY_NAME;
	     else if arg = "-pj" | arg = "-project" then sort = SORT_BY_PROJECT;
	     else if arg = "-lg" | arg = "-long" then long = TRUE; /* long who? */
	     else if arg = "-nhe" | arg = "-no_header" then nhesw = TRUE; /* omit headers ? */
	     else if arg = "-as" | arg = "-absentee" then abs = TRUE; /* absentee users? */
	     else if arg = "-dmn" | arg = "-daemon" then dmn = TRUE; /* Daemons? */
	     else if arg = "-ia" | arg = "-interactive" then iasw = TRUE;
	     else if arg = "-connected" then connected_sw = TRUE;
	     else if arg = "-disconnected" | arg = "-disc" then disc_sw = TRUE; /* disconnected processes */
	     else if arg = "-process_id" | arg = "-pid" then pid_sw = TRUE; /* display the process_id */
	     else if arg = "-gp" | arg = "-group" then do;
		if argno = arg_count then
BAD_GROUP:	     call ssu_$abort_line (sci_ptr, error_table_$noarg, "-group requires a load control group name.");
		argno = argno + 1;
		call ssu_$arg_ptr (sci_ptr, argno, ap, al);
		if index (arg, "-") = 1 then
		     go to BAD_GROUP;
		selgp = arg;
	     end;
	     else if arg = "-sc" | arg = "-secondary" then sbsw = TRUE; /* Secondary users? */
	     else if arg = "-pdir_volume" | arg = "-pdv" then
PROCESS_PDIR_VOL_ARG:
		do;				/* optionally followed by LVname */
		if argno = arg_count then
		     pdvsw = TRUE;			/* no lvname */
		else do;				/* see if next arg is lvname or ctl arg */
		     call ssu_$arg_ptr (sci_ptr, argno + 1, ap, al);
		     if index (arg, "-") = 1 then
			pdvsw = TRUE;		/* ctl arg ==> no LV name */
		     else do;
			lvnm = arg;		/* remember the name, for later lookup in disk_table */
			pdvsw = FALSE;		/* don't print each users pdlvname - they will all be the same */
			argno = argno + 1;		/* increment so we don't re-process LVname */
		     end;
		end;
	     end PROCESS_PDIR_VOL_ARG;
	     else if arg = "-cpu" then cpusw = TRUE;
	     else if arg = "-idle" then idlesw = TRUE;

	     else if arg = "-chn" | arg = "-channel" then do;
		chnsw = TRUE;
		if argno = arg_count then
bad_chn:		     call ssu_$abort_line (sci_ptr, error_table_$noarg, "-channel requires a channel id argument.");
		argno = argno + 1;
		call ssu_$arg_ptr (sci_ptr, argno, ap, al);
		if index (arg, "-") = 1 then
		     go to bad_chn;
		chnnm = arg;
		call check_star_name_$entry (chnnm, code);
		if code < 0 | code > 2 then
		     call ssu_$abort_line (sci_ptr, code, "Invalid channel id ^a.", arg);
	     end;
	     else if index (arg, "-") = 1 then
		call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a", arg);
	     else do;				/* n.o.t.a., must be user-selection */
		selx = selx + 1;			/* up index in select array */
		if selx > hbound (sel_names, 1) then
		     call ssu_$abort_line (sci_ptr, error_table_$too_many_args,
			"Too many selection parameters given, maximum is ^d.", hbound (sel_names, 1));
		if search (arg, "*?") ^= 0 then sel_starsw = TRUE; /* stars specified at all */
		dotl = index (arg, ".");		/* where's the dot? */
		if dotl = 0 then sel_names (selx) = arg || ".*"; /* Person_starname -> Person_starname.* */
		else if dotl = 1 then do;
		     sel_starsw = TRUE;		/* asking for a set of users */
		     sel_names (selx) = "*" || arg;	/* Proj_starname -> *.Proj_starname */
		end;
		else sel_names (selx) = arg;
	     end;
	end READ_ARGS;

go:	if static_autp = null then do;		/* is this the first call? */
	     if sysdir = "" then sysdir = sys_info$system_control_dir;
	     call initiate_file_ (sysdir, "installation_parms", R_ACCESS, ip, (0) /* ignore bit count */, code);
	     if ip = null then call ssu_$abort_line (sci_ptr, code, "installation_parms");
	     call initiate_file_ (sysdir, "daemon_user_table", R_ACCESS, static_dutp, (0) /* ignore bit count */, code);
	     if static_dutp = null then call ssu_$abort_line (sci_ptr, code, "daemon_user_table");
	     call initiate_file_ (sysdir, "whotab", R_ACCESS, whoptr, (0) /* ignore bit count */, code);
	     if whoptr = null then call ssu_$abort_line (sci_ptr, code, "whotab");
	     call initiate_file_ (sysdir, "answer_table", R_ACCESS, static_ansp, (0) /* ignore bit count */, code);
	     if static_ansp = null then call ssu_$abort_line (sci_ptr, code, "answer_table");

	     if static_ansp->anstbl.as_procid = get_process_id_ () then
						/* if we are the initializer process */
		initializer_process = TRUE;		/* remember that because we have a disk table copy */
	     else initializer_process = FALSE;		/* we don't, so we have to make one */
						/* set autp so we don't re-initialize every invocation */
	     call initiate_file_ (sysdir, "absentee_user_table", R_ACCESS, static_autp, (0) /* ignore bit count */, code);
	     if static_autp = null then call ssu_$abort_line (sci_ptr, code, "absentee_user_table");
	end;

          if (cpusw | idlesw) & tcmp0 = null then do;
	     call ring0_get_$segptr ("", "tc_data", tcmp0, code);
	     if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "tc_data");
	     call ring_zero_peek_$get_max_length_ptr (tcmp0, tcml, code);
	     if code ^= 0 then do;
		tcmp0 = null;
		call ssu_$abort_line (sci_ptr, code, "tc_data");
	     end;
	     
          end;

	ansp = static_ansp;
	autp = static_autp;
	dutp = static_dutp;

	if connected_sw & disc_sw then do;
	     iasw = TRUE;				/* conn & disc users = interactive */
	     connected_sw, disc_sw = FALSE;
	end;

	if pdvsw | lvnm ^= "" then do;		/* if we need disk_table */
	     if static_dtp = null then do;		/* if we don't have it, get it */
		if initializer_process then		/* if this is the initializer process, we always have a copy */
		     call disk_table_$get_dtp (static_dtp); /* of disk_table in ring 4, so get ptr to that */
		else				/* otherwise we have to make a copy and update it each time */
		     call ssu_$get_temp_segment (sci_ptr, "disk_table", static_dtp);
	     end;

	     if ^initializer_process then do;		/* update as_who_disk_table */
		call mdc_$read_disk_table (static_dtp, code);
		if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "error from mdc_$read_disk_table");
	     end;

	     dtp = static_dtp;

	     if lvnm ^= "" then do;			/* if -pdv LVname given, look up LVname in disk_table */
		do i = 1 to dt.n_lv_entries
		     while (dt.lv_array (i).lvname ^= lvnm); end;
		if i > dt.n_lv_entries then
		     call ssu_$abort_line (sci_ptr, error_table_$logical_volume_not_defined, "^a", lvnm);
		pdlvix = i;			/* remember disk table index of the specified vol */
	     end;
	end;
	max_chan_name = 6;				/* compute length of longest channel name */
	do j = 1 to anstbl.current_size;
	     utep = addr (anstbl.entry (j));
	     if ute.active >= NOW_LOGGED_IN then
		max_chan_name = max (max_chan_name, length (rtrim (ute.tty_name)));
	end;

	if nhesw then go to no_header;
	if no_ulist then fancy = " ";			/* reduce number of new lines between totals */
	else fancy = NL;

	clock_time = clock ();
	absentee_users = autbl.max_abs_users;
	abs_running = absentee_users + autbl.n_abs_run;
	foreground_users = autbl.n_abs_run - autbl.n_background_abs;

	if ^sbsw &
	     ^chnsw &
	     selgp = "" &
	     pdlvix = 0 &
	     selx = 0 then do;			/* print header if no users selected */
	     if dmn then do;
		call ioa_ ("^d daemons.", whotab.n_daemons);
		if no_ulist then go to pnl;
	     end;
	     if (connected_sw | disc_sw | iasw | chnsw) then do;
		if no_ulist then do;
		     f1 = anstbl.n_units / TEN_UNITS;
		     f2 = anstbl.max_units / TEN_UNITS;
		     go to print_ia_hdr;
		end;
		call ioa_ ("");
		if long then go to prt_user_header;
		else go to ias;
	     end;
	     if abs then do;
		if long then do;
		     call ioa_ ("Absentee users = ^d background^[,^x^d foreground^;^s^]; Max background absentee users = ^d^a",
			autbl.n_background_abs, (foreground_users ^= 0), foreground_users, absentee_users, fancy);
		     go to prt_user_header;		/* Print listing header */
		end;
		call ioa_ ("");			/* Print blank line first */
		go to print_abs_hdr;		/* print short absentee header only */
	     end;
	     if dmn then do;
		call ioa_ ("");
		if long then go to prt_user_header;
		else go to daemons;
	     end;

	     f1 = anstbl.n_units / TEN_UNITS;		/* format up units */
	     f2 = anstbl.max_units / TEN_UNITS;		/* ... */
	     if long then do;			/* long who? */
		call date_time_ (whotab.timeup, time);	/* yup. make heading */
		call ioa_ ("^/Multics ^a; ^a", whotab.sysid, installation_parms.installation_id);
		call ioa_ ("Load = ^.1f of ^.1f units; users = ^d of ^d", f1, f2, anstbl.n_users, anstbl.max_users);
		if abs_running > 0
		then call ioa_ ("Absentee users = ^d background^[,^x^d foreground^;^s^]; Max background absentee users = ^d",
			autbl.n_background_abs, (foreground_users ^= 0), foreground_users, absentee_users);
		call ioa_ ("Daemon users = ^d", whotab.n_daemons);
		call ioa_ ("System up since ^a", time);
		if whotab.nextsd ^= 0 then do;
		     why = whotab.why;
		     if why < "" then why = "";
		     call date_time_ (whotab.nextsd, time);
		     if whotab.until = 0 then call ioa_ ("Scheduled shutdown at ^a ^a", time, why);
		     else do;
			call date_time_ (whotab.until, time1);
			call ioa_ ("Scheduled shutdown from ^a to ^a ^a", time, time1, why);
		     end;
		end;
		call date_time_ (whotab.lastsd, time);
		if whotab.erfno = "crash" then call ioa_ ("Last crash was at ^a^a", time, fancy);
		else if whotab.lastsd = 0 then call ioa_ ("^a", fancy);
		else if whotab.erfno = "" then call ioa_ ("Last shutdown was at ^a^a", time, fancy);
		else call ioa_ ("Last crash (ERF# ^a) was at ^a^a", whotab.erfno, time, fancy);
prt_user_header:
		if no_ulist then go to pnl;
		call ioa_ ("^4xLogin at^6xTTY  Load^3xChan^vxGroup^3x^[^3xCPU^3x   ^]^[^3xIdle^2x  ^]^[ Process ID  ^] PNDS  User ID^[^2x(pdir_volume)^]^/",
		     max_chan_name - length ("   "), cpusw, idlesw, pid_sw, pdvsw);
	     end;
	     else do;				/* short who. */
print_ia_hdr:	call ioa_ ("^/Multics ^a, load ^.1f/^.1f; ^d/^d users, ^d daemons.", whotab.sysid,
		     f1, f2, anstbl.n_users, anstbl.max_users, whotab.n_daemons);
		if abs_running > 0 & (^no_ulist | abs | (^iasw & ^dmn))
		then				/* ! */
print_abs_hdr:	     call ioa_ ("Absentee users ^d/^d^[^x(+^d FG)^]",
			autbl.n_background_abs, absentee_users, (foreground_users ^= 0), foreground_users);
		call ioa_$nnl ("^a", fancy);		/* Could have put in a conditional */
	     end;
	end;
no_header:
	if no_ulist then go to pnl;			/* if "hmu" command */
	if (connected_sw | disc_sw | iasw) then go to ias;
	if abs then go to abs_portion;		/* if "as_who -as" command */
	if dmn then go to daemons;

ias:	last = anstbl.current_size;			/* save high limit on who */
	do j = 1 to last;				/* set up sort array */
	     ary (j) = j;				/* ... */
	end;

	d = last;					/* set up for Shell sort */
pass:	d = divide (d + 1, 2, 17, 0);			/* ... */
	swap = 0;					/* ... */
	do j = 1 to last - d;			/* comparison loop */
	     aj = ary (j);				/* make temps */
	     ajd = ary (j + d);			/* ... */
	     pp1 = addr (anstbl.entry (aj));
	     pp2 = addr (anstbl.entry (ajd));
	     if sort = SORT_BY_DATE then
		if pp1 -> ute.login_time > pp2 -> ute.login_time then go to ic;
	     if sort = SORT_BY_NAME then
		if pp1 -> ute.person > pp2 -> ute.person then go to ic;
	     if sort = SORT_BY_PROJECT then
		if pp1 -> ute.project > pp2 -> ute.project then go to ic;
		else if pp1 -> ute.project = pp2 -> ute.project then
		     if pp1 -> ute.person > pp2 -> ute.person then do;
ic:			ary (j) = ajd;		/* No. Swap entries */
			ary (j + d) = aj;		/* ... */
			swap = swap + 1;		/* remember a swap */
		     end;
	end;
	if swap > 0 then go to pass;			/* if out of order do it again */
	if d > 1 then go to pass;			/* ... */

	do j = 1 to last;				/* now the print loop */
	     utep = addr (anstbl.entry (ary (j)));	/* set up ptr to user */
	     if ute.active < NOW_LOGGED_IN then go to skip; /* skip dead entries */
	     pers = ute.person;			/* copy personal name */
	     proj = ute.project;			/* copy project */
	     if pid_sw then process_id = ute.proc_id;     /* copy process id */
	     if selgp ^= "" then if ute.group ^= selgp then go to skip;
	     if pdlvix > 0 & ute.pdir_lvix ^= pdlvix then goto skip;
	     if sbsw then if ute.standby_line = 0 then go to skip;
	     if connected_sw then
		if ute.uflags.disconnected then go to skip;
	     if disc_sw then if ^ute.uflags.disconnected then goto skip;
	     if chnsw then do;			/* select users by channel id. */
		call match_star_name_ (ute.tty_name, chnnm, code);
		if code ^= 0 then go to skip;
	     end;

	     if selx = 0 then go to print;		/* any users selected? */
	     call select;				/* check for selected users */
	     if select_sw = 0 then go to skip;		/* user not in selected group */

print:	     did = did + 1;				/* remember we did one */
	     if ute.anonymous = 0 then anon = " ";
	     else anon = "*";
	     if ute.preempted ^= 0 then prim = "X";
	     else if ute.at.nobump then prim = "+";	/* Can be bumped by operator? */
	     else if ute.standby_line = 1 then prim = "S";/* Secondary? */
	     else if ute.cant_bump_until < clock_time then prim = ">";
	     else prim = " ";
	     if pdvsw then call get_lvnm ((ute.pdir_lvix)); /* sets lvnm */
	     call get_usage (ute.proc_id, ute.cpu_usage);
	     if afsw then do;
                    ret = ret || rtrim (pers);
                    ret = ret || ".";
                    ret = ret || rtrim (proj);
                    ret = ret || " ";
               end;
	     else if long then do;			/* long who? */
		call date_time_ (ute.login_time, time); /* yup. */
		if substr (time, 1, length ("mm/dd/yy")) = substr (time1, 1, length ("mm/dd/yy")) then substr (time, 1, length ("mm/dd/yy")) = (8)" ";
		else time1 = time;
		f1 = ute.user_weight / TEN_UNITS;	/* get nice units */
		if ute.at.nolist then nolist = "N";
		else nolist = " ";
		grp = ute.group;			/* Get group */
		if grp = "Other" then grp = "";

/**** Avoid operator mistakes by not displaying channel name when the user
      is disconnected.  This channel name is not terribly useful anyway in
      this case, and prevents attempting to bump disconnected users by channel
      name (which may result in bumping the user currently on that channel). */
		if ute.uflags.disconnected then channel_name = "";
		   else channel_name = ute.tty_name;
		call ioa_ ("^16a  ^4a ^4.1f^3x^va ^8a^[^11a ^;^s^]^[^11a^;^s^] ^[^12.3b ^;^s^]^1a^1a^[D^; ^]^[S^; ^] ^1a^a.^a^[^2x(^a)^;^s^]",
		     time, ute.tty_id_code, f1,
		     max_chan_name, channel_name, grp,
		     cpusw, proc_usage,
		     idlesw, proc_idle, pid_sw, process_id,
		     prim, nolist, ute.uflags.disconnected, ute.uflags.suspended, anon,
		     pers, proj, pdvsw, lvnm);
	     end;
	     else do;				/* short who. */
		call ioa_ ("^[^11a ^;^s^]^[^11a ^;^s^]^[^12.3b  ^;^s^]^a^a.^a ^a^[^2x(^a)^;^s^]",
		     cpusw, proc_usage,
		     idlesw, proc_idle, pid_sw, process_id,
		     anon, pers, proj, prim, pdvsw, lvnm);
	     end;
skip:	end;
	if (connected_sw | disc_sw | iasw) then if ^abs then if ^dmn then go to done;
		else go to daemons;

abs_portion:
	if autbl.n_abs_run <= 0 then go to daemons;
	do j = 1 to autbl.current_size;		/* run through table */
	     utep = addr (autbl.entry (j));		/* get address of abs user entry */
	     if ute.active = 0 then go to skip1;	/* only look at used entries */
	     pers = ute.person;			/* copy personal name */
	     proj = ute.project;			/* copy project name */
	     if pid_sw then process_id = ute.proc_id;     /* copy process id */
	     if selgp ^= "" then if ute.group ^= selgp then go to skip1;
	     if pdlvix > 0 & ute.pdir_lvix ^= pdlvix then goto skip1;
	     if sbsw then go to skip1;

	     call ioa_$rsnnl ("abs^d", abs_name, k, j);
	     if chnsw then do;			/* select absentee users by abs_name. */
		call match_star_name_ (abs_name, chnnm, code);
		if code ^= 0 then go to skip1;
	     end;

	     if selx = 0 then go to print1;		/* are any users selected */
	     call select;				/* check for selected users */
	     if select_sw = 0 then go to skip1;		/* user not in selected group */
print1:	     did = did + 1;				/* increment count of printed persons */
	     if ute.anonymous = 0 then anon = " ";
	     else anon = "*";
	     call expand_pathname_ ((ute.input_seg), absdn, absen, code);
	     k = index (absen, ".absin");
	     if k > 0 then substr (absen, k) = "";
	     if pdvsw then call get_lvnm ((ute.pdir_lvix)); /* sets lvnm */
	     call get_usage (ute.proc_id, ute.cpu_usage);
	     if afsw then do;
                    ret = ret || rtrim (pers);
	          ret = ret || ".";
		ret = ret || rtrim (proj);
		ret = ret || " ";
	     end;    
               else if long then do;
		call date_time_ (ute.login_time, time);
		if substr (time, 1, length ("mm/dd/yy")) = substr (time1, 1, length ("mm/dd/yy")) then substr (time, 1, length ("mm/dd/yy")) = (8)" ";
		else time1 = time;
		f1 = ute.user_weight / TEN_UNITS;
		grp = ute.group;
		if grp = "Other" then grp = "";
		call ioa_ ("^16a  Q ^[FG^s^;^d^x^] ^4.1f^3x^va ^8a^[^11a ^;^s^]^[^11a^;^s^]^[ ^12.3b^;^s^] A  ^[S^; ^] ^1a^a.^a (^a)^[^2x(^a)^;^s^]",
		     time, (ute.queue = 0), ute.queue, f1,
		     max_chan_name, abs_name, grp,
		     cpusw, proc_usage,
		     idlesw, proc_idle, pid_sw, process_id,
		     ute.uflags.suspended,
		     anon, pers, proj, absen, pdvsw, lvnm);
	     end;
	     else call ioa_ ("^[^11a ^;^s^]^[^11a ^;^s^]^[^12.3b  ^;^s^]^a^a.^a (^a)^[^2x(^a)^;^s^]",
		     cpusw, proc_usage,
		     idlesw, proc_idle, pid_sw, process_id,
		     anon, pers, proj, absen, pdvsw, lvnm);
skip1:	end;

daemons:	if abs then if ^dmn then go to done;
	do j = 1 to dutbl.current_size;		/* print out daemons */
	     utep = addr (dutbl.entry (j));
	     if ute.active ^= NOW_HAS_PROCESS then go to skip2; /* skip if not in */
	     pers = ute.person;
	     proj = ute.project;
	     if pid_sw then process_id = ute.proc_id;
	     if selgp ^= "" then if ute.group ^= selgp then go to skip2;
	     if pdlvix > 0 & ute.pdir_lvix ^= pdlvix then goto skip2;
	     if sbsw then go to skip2;

	     if chnsw then do;			/* select daemons by tty_name */
		call match_star_name_ (ute.tty_name, chnnm, code);
		if code ^= 0 then go to skip2;
	     end;

	     if selx = 0 then go to print2;
	     call select;
	     if select_sw = 0 then go to skip2;
print2:	     did = did + 1;
	     if pdvsw then call get_lvnm ((ute.pdir_lvix)); /* sets lvnm */
	     call get_usage (ute.proc_id, ute.cpu_usage);
	     if afsw then do;
	          ret = ret || rtrim (pers);
		ret = ret || ".";
		ret = ret || rtrim (proj);
		ret = ret || " ";
               end;
	     else if long then do;
		call date_time_ (ute.login_time, time);
		if substr (time, 1, length ("mm/dd/yy")) = substr (time1, 1, length ("mm/dd/yy")) then substr (time, 1, length ("mm/dd/yy")) = (8)" ";
		else time1 = time;
		f1 = ute.user_weight / 1e1;
		if ute.at.nolist then nolist = "N"; else nolist = " ";
		grp = ute.group;
		if grp = "Other" then grp = "";

/**** Avoid operator mistakes by not displaying channel name when the user
      is disconnected.  This channel name is not terribly useful anyway in
      this case, and prevents attempting to bump disconnected users by channel
      name (which may result in bumping the user currently on that channel). */
		if ute.uflags.disconnected then channel_name = "";
		else channel_name = ute.tty_name;
		call ioa_ ("^16a  ^4a ^4.1f^3x^va ^8a^[^11a ^;^s^]^[^11a^;^s^]^[^12.3b^;^s^] D^1a    ^a.^a^[^2x(^a)^;^s^]",
		     time, ute.tty_id_code, f1,
		     max_chan_name, channel_name, grp,
		     cpusw, proc_usage,
		     idlesw, proc_idle, pid_sw, process_id,
		     nolist, pers, proj, pdvsw, lvnm);
	     end;
	     else do;				/* short */
		call ioa_ ("^[^11a ^;^s^]^[^11a ^;^s^]^[^12.3b  ^;^s^]^a.^a D^[^2x(^a)^;^s^]",
		     cpusw, proc_usage,
		     idlesw, proc_idle, pid_sw, process_id,
		     pers, proj, pdvsw, lvnm);
	     end;
skip2:	end;

done:	if afsw then do;
	     if length (ret) > 0 then			/* remove trailing blank from list of pers.proj ids */
		ret = substr (ret, 1, length (ret) - 1);
	end;
	else if selx ^= 0 then			/* If user names specified */
	     if did = 0 then do;			/* if printed nobody */
		if pdlvix = 0 then			/* if users were not eliminated because of -pdv LVname */
		     call ioa_ ("User^[s^] not logged in.", selx > 1 | sel_starsw);
	     end;
	     else					/* ! */
pnl:		call ioa_ ("");			/* extra CR */
	else if did ^= 0				/* were any printed? */
	then go to pnl;

	if pdlvix ^= 0 & did = 0 then
	     call ioa_ ("No^[ne of the specified^] users have process directories on volume ""^a""",
		((selgp ^= "") | sbsw | selx ^= 0 | connected_sw | disc_sw | iasw | abs | dmn), lvnm);

exit:	call clean_up;				/* releases temp segs etc. */
exit_no_cleanup:
	return;					/* done. */

/* end as_who; */
%page;
clean_up: proc;

/* reset a pointer and get rid of the ssu invocation, and thus */
/* any temporary storage acquired. */

	if ^initializer_process then static_dtp = null;	/* destroy will release temp seg, if acquired */
	if sci_ptr ^= null then call ssu_$destroy_invocation (sci_ptr);

     end clean_up;
%skip (6);
as_who$long: entry;
	on cleanup call clean_up ();
	call ssu_$standalone_invocation (sci_ptr, MY_NAME_LONG, "",
	     null (), ABORT_ENTRY, code);
	if code ^= 0 then go to exit_no_cleanup;

	call ssu_$arg_count (sci_ptr, arg_count);	/* not allowed to be an AF */

	long = TRUE;				/* set switch and join up */
	go to arglp;
%skip (6);
as_who$how_many_users:
as_who$hmu: entry ();

	call ssu_$standalone_invocation (sci_ptr, MY_NAME_HMU, "",
	     null (), ABORT_ENTRY, code);
	if code ^= 0 then go to exit_no_cleanup;

	call ssu_$arg_count (sci_ptr, arg_count);	/* not allowed to be an AF */
	if arg_count > 0				/* no args allowed */
	then call ssu_$abort_line (sci_ptr, error_table_$too_many_args, "No arguments allowed, ^d given.", arg_count);

	no_ulist = TRUE;				/* do just a
						   header */
	go to go;
%page;
as_who$as_who_init: entry (sysdirname);

dcl  sysdirname char (*) parameter;

	sysdir = sysdirname;
	static_ansp, static_autp, static_dutp = null;
	return;
%skip (6);
ABORT_ENTRY:
     procedure ();
	go to exit;
     end ABORT_ENTRY;
%skip (6);
select: proc;
						/* internal procedure to see if user is selected by name */

dcl  group_id char (32);
dcl  code fixed bin (35);

	select_sw = 1;				/* assume that user is part of selected group */
	group_id = rtrim (pers) || "." || proj;
	do k = 1 to selx;				/* search all classes of selection */
	     call match_star_name_ (group_id, sel_names (k), code);
	     if code = 0 then return;
	end;

	select_sw = 0;				/* user is not part of selected group */
	return;
     end select;
%skip (6);
get_lvnm: proc (lvix);
dcl  lvix fixed bin;

	if lvix > 0 & lvix <= dt.n_lv_entries then
	     lvnm = dt.lv_array (lvix).lvname;
	else lvnm = "?";
	return;

     end get_lvnm;
%page;

get_usage: proc (x, y);

dcl  x bit (36) aligned;
dcl  y fixed bin (71);
dcl  i fixed bin, code fixed bin (35);
dcl  white_len fixed bin;
dcl  date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);
dcl find_char_$last_in_list entry (char (*), char (*)) returns (fixed bin (21));
	if no_usage then do;
abort:	     proc_usage = "";
	     proc_idle = "";
	     return;
	end;

/* Grab metering data we need. */

	if ^have_read_apt then do;
	     call ssu_$get_temp_segment (sci_ptr, "apt", tcmp);
	     call ring_zero_peek_ (tcmp0, tcmp, tcml, code);
	     if code ^= 0 then do;
		no_usage = TRUE;
		go to abort;
	     end;	
	     have_read_apt = TRUE;
	end;

	aptep = addrel (tcmp, tcm.apt_offset);
	do i = 0 to tcm.apt_size - 1;
	     if apte.processid = x then go to found;
	     aptep = addrel (aptep, tcm.apt_entry_size);
	end;
	go to abort;
found:	proc_usage = date_time_$format ("^ZZHd:^ZZMH:^99.(6)9UM", apte.virtual_cpu_time+ y, "gmt", "");
          if substr (proc_usage, 1, length ("::")) = "::" then substr (proc_usage, 1, length ("  ")) = "  ";
          if substr (proc_usage, 1, length (":")) = ":" then substr (proc_usage, 1, length (" ")) = " ";
	proc_usage = substr (proc_usage, 1, find_char_$last_in_list (proc_usage, ".") + 1);
          do white_len = 1 to 9 - find_char_$last_in_list (proc_usage, ".");
             	proc_usage = " " || substr (proc_usage, 1, find_char_$last_in_list (proc_usage, ".") + 1);
          end;
          proc_idle = date_time_$format ("^ZZHd:^ZZMH:^99.(6)9UM", clock () - apte.state_change_time, "gmt", "");
	if substr (proc_idle, 1, length ("::")) = "::" then substr (proc_idle, 1, length ("  ")) = "  ";
	if substr (proc_idle, 1, length (":")) = ":" then substr (proc_idle, 1, length (" ")) = " ";
	proc_idle = substr (proc_idle, 1, find_char_$last_in_list (proc_idle, ".") + 1);
	do white_len = 1 to 9 - find_char_$last_in_list (proc_idle, ".");
		proc_idle = " " || substr (proc_idle, 1, find_char_$last_in_list (proc_idle, ".") + 1);
          end;   
	if fixed (apte.state, 18) = 2 then proc_idle = (9)" " || "R";
	else if fixed (apte.state, 18) = 3 then proc_idle = (9)" " || "W";
	else if fixed (apte.state, 18) = 1 then proc_idle = (9)" " || "X";
	return;

     end get_usage;

%page; %include absentee_user_table;
%page; %include access_mode_values;
%page; %include answer_table;
%page; %include apte;
%page; %include daemon_user_table;
%page; %include dialup_values;
%page; %include disk_table;
%page; %include hc_lock;
%page; %include installation_parms;
%page; %include tcm;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;
%page; %include whotab;

     end as_who;




		    call_finder.pl1                 10/27/83  1614.3r   10/27/83  1441.5       99189



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


call_finder: proc;

/* Finds all calls to entries with a given segment name

   Written by:	Richard A. Barnes 24 January 1974	*/

/*  Modified on 4 June 1975 by J. C. Whitmore to attempt use of system privilege initiate */

/*  Modified 11/10/82 by R. Holmstedt to use the new object_info include file */
/* Changed to use interpret_link_info.incl.pl1 05/12/83 S. Herbst */


dcl (alen, i, nargs, nentry, ncompilers, total) fixed bin;
dcl (aptr, sptr) ptr;
dcl (all, added_access) bit (1) aligned;

dcl  root char (168) aligned init (">");
dcl  dir char (168);				/* full directory name */
dcl  ename char (32);				/* entry name */
dcl  target char (32) aligned;

dcl 1 entry (256),
    2 name char (65),
    2 refs fixed bin;

dcl 1 compiler_table (32),
    2 cname char (8),
    2 segs fixed bin,
    2 uses fixed bin;

dcl  arg char (alen) based (aptr);

dcl  have_priv bit (1) int static init ("1"b);		/* assume we have privileges for now */
dcl  code fixed bin (35);
dcl  me char (11) int static init ("call_finder");
dcl  nl char (1) int static init ("
");
dcl  ftotal float bin;
dcl  total_object_segs fixed bin init (0);
dcl  total_segs_with_call fixed bin init (0);

dcl 1 segment_acl aligned,
    2 access_name char (32),
    2 modes bit (36) init ("1"b),			/* r */
    2 zero_pad bit (36) init ("0"b),
    2 status_code fixed bin (35);

dcl 1 delete_acl aligned,
    2 access_name char (32),
    2 status_code fixed bin (35);

dcl  error_table_$moderr fixed bin (35) ext;

dcl  cleanup condition;

dcl (addr, addrel, divide, fixed, float, hbound, index, ltrim, null, rtrim, substr) builtin;

dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  get_group_id_ entry () returns (char (32) aligned);
dcl  hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  hcs_$delete_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  system_privilege_$initiate_count entry
	(char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  interpret_link_ entry (ptr, ptr, fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  ios_$write_ptr entry (ptr, fixed bin, fixed bin (7));
dcl  object_info_$display entry (ptr, fixed bin (24), ptr, fixed bin (35));
dcl  sweep_disk_ entry (char (168) aligned, entry);



	all = "0"b;
	nentry, ncompilers = 0;
	call cu_$arg_count (nargs);

/* get name of target */

	call cu_$arg_ptr (1, aptr, alen, code);

	if code ^= 0
	then do;
err:	     call com_err_ (code, me,
		"^/Usage: call_finder entry {-all, path}, ^/^-The root is default starting node for path.");
	     return;
	end;
	if substr (arg, 1, 1) = "-" then goto err;
	target = arg;

/* get other 2 args */
	if nargs > 3 then goto err;
	do i = 2 to nargs;
	     call cu_$arg_ptr (i, aptr, alen, code);

	     if substr (arg, 1, 1) = "-" then do;
		if arg = "-all" | arg = "-a" then do;
		     if all = "1"b then goto err;
				/* if all true then second time thru */
		     all = "1"b;
		end;
		else goto err;
	     end;

	     else do;
		call expand_path_ (aptr, alen, addr (root), null, code);
		if code ^= 0 then go to err;
	     end;
	end;

/* Now call the sweeper program */

	segment_acl.access_name,
	     delete_acl.access_name = get_group_id_ ();
	sptr = null;
	added_access = "0"b;
	on condition (cleanup) call clean_up;

	call sweep_disk_ (root, counter);

/* now print out totals */

sum:	total = 0;
	do i = 1 to nentry;
	     total = total + refs (i);
	end;

	ftotal = total;

	call ioa_ ("^/^d total object segments searched^/^d segments call ^a with ^d calls^/",
	     total_object_segs, total_segs_with_call, target, total);

	do i = 1 to nentry;
	     call ioa_ ("^a^65t^4d^70t^7.2f%", name (i), refs (i), 100.0 * (float (refs (i))/ftotal));
	end;

	call ioa_ ("");
	do i = 1 to ncompilers;
	     call ioa_ ("^8a^8d^10d", compiler_table (i).cname, compiler_table (i).segs, compiler_table (i).uses);
	end;
	return;
	
counter:	proc (superior, parent, levels, pename, bptr, nptr);

dcl  superior char (168) aligned,			/* superior directory path */
     parent char (32) aligned,			/* parent directory name */
     levels fixed bin,				/* distance from root */
     pename char (32) aligned,			/* entry name */
     bptr ptr,					/* ptr to branch structure */
     nptr ptr;					/* ptr to names area */

dcl (i, j, n) fixed bin;
dcl (lptr, liptr) ptr;
dcl  reference char (68) varying aligned;
dcl  nbits fixed bin (24);
dcl (first, firstlink) bit (1) aligned;
dcl  code fixed bin (35);
dcl  line char (80);
dcl  written fixed bin (7);

dcl  segment_type bit (2) int static init ("01"b);

dcl 1 branch based aligned,
    2 type bit (2) unal,
    2 nnames bit (16) unal,
    2 nindex bit (18) unal;

dcl 1 link_header based aligned,
    2 object_seg fixed bin,
    2 def_section bit (18) unal,
    2 first_reference bit (18) unal,
    2 section_thread ptr,
    2 linkage_ptr ptr,
    2 begin_links bit (18) unal,
    2 section_length bit (18) unal,
    2 obj_seg bit (18) unal,
    2 combined_length bit (18) unal;

dcl 1 linkword based aligned,
    2 pad bit (30) unal,
    2 ft2 bit (6) unal;

dcl 1 auto_interpret_link_info aligned like interpret_link_info;

dcl (no_read_permission, not_in_read_bracket, seg_fault_error, program_interrupt, record_quota_overflow,
     linkage_error) condition;

dcl  length builtin;

%include object_info;

dcl  1 obj_info like object_info;


%include interpret_link_info;
%page;
/* first, see if we could have an object segment */
               obj_info.version_number = object_info_version_2;
	     if bptr -> branch.type ^= segment_type then return;

	     ename = pename;
	     if index (ename, ".") ^= 0 then return;
	     if substr (ename, 1, 1) = "!" then return;

/* we might have one, so let's initiate it */

	     if superior ^= ""
	     then dir = rtrim (superior) || ">" || parent;
	     else dir = parent;

	     on linkage_error begin;
		have_priv = "0"b;
		go to init_seg;
	     end;

init_seg:

	     if have_priv
	     then call system_privilege_$initiate_count (dir, ename, "", nbits, 1, sptr, code);
	     else call hcs_$initiate_count (dir, ename, "", nbits, 1, sptr, code);

	     revert linkage_error;			/* we have the privilege we need */

	     if sptr = null
	     then if code = error_table_$moderr
		then do;
		     call hcs_$add_acl_entries (dir, ename, addr (segment_acl), 1, code);
		     if code ^= 0 then return;
		     added_access = "1"b;
		     if have_priv
		     then call system_privilege_$initiate_count (dir, ename, "", nbits, 1, sptr, code);
		     else call hcs_$initiate_count (dir, ename, "", nbits, 1, sptr, code);
		     if sptr = null then go to finish;
		end;
		else return;

/* prepare for somebody's interfering with us */

	     on condition (cleanup) call clean_up;
	     on condition (record_quota_overflow) go to finish;
	     on condition (program_interrupt) go to finish;
	     on condition (seg_fault_error) go to finish;
	     on condition (no_read_permission) go to finish;
	     on condition (not_in_read_bracket) go to finish;

/* object_info_ will tell us about the object segment */

	     call object_info_$display (sptr, nbits, addr (obj_info), code);
	     if code ^= 0 then go to finish;

	     total_object_segs = total_object_segs + 1;

/* record count of compiler names. */

	     do j = 1 to ncompilers while (compiler_table (j).cname ^= obj_info.compiler);
	     end;
	     if j <= ncompilers then compiler_table (j).segs = compiler_table (j).segs + 1;
	     else if j <= hbound (compiler_table, 1) then do;
		ncompilers = j;
		compiler_table (j).cname = obj_info.compiler;
		compiler_table (j).segs = 1;
		compiler_table (j).uses = 0;
	     end;
	     else do;
		call com_err_ (0, me, "compiler table full");
		call clean_up;
		go to sum;
	     end;

/* now, we have to look at the links */

	     first, firstlink = "1"b;
	     lptr = addrel (obj_info.linkp, obj_info.linkp -> link_header.begin_links);
	     n = divide (obj_info.llng - fixed (obj_info.linkp -> link_header.begin_links, 18), 2, 17, 0);


	     do i = 1 to n;
		if lptr -> linkword.ft2 = "100110"b	/* fault 2 tag */
		then do;

/* we have a link, see if it points at target seg */

		     auto_interpret_link_info.version = INTERPRET_LINK_INFO_VERSION_1;

		     call interpret_link_ (addr (auto_interpret_link_info), lptr, code);
		     if code ^= 0 then go to finish;

		     if auto_interpret_link_info.segment_name = target
		     then do;

/* PAYDIRT! */

			if firstlink then do;
			     firstlink = "0"b;
			     total_segs_with_call = total_segs_with_call + 1;
			     compiler_table (j).uses = compiler_table (j).uses + 1;
			end;

			reference = rtrim (auto_interpret_link_info.segment_name) ||
			     rtrim (auto_interpret_link_info.entry_point_name) || " ";

/* put entry into table */

			do j = 1 to nentry while (entry (j).name ^= reference);
			end;

			if j <= nentry
			then entry (j).refs = entry (j).refs + 1;
			else if j <= hbound (entry, 1)
			then do;
			     nentry = j;
			     entry (j).name = reference;
			     entry (j).refs = 1;
			end;
			else do;
			     call com_err_ (0, me, "table_overflow");
			     call clean_up;
			     go to sum;
			end;

/* print out information */

			if all then do;
			     if first then do;
				call ioa_ ("^/>^a>^a (^a)", ltrim(dir,">"), ename, obj_info.compiler);
				first = "0"b;
				line = " ";
				written = 1;
			     end;

			     if length (reference) + written >= length (line)
			     then call write;

			     substr (line, written+1, length (reference)) = reference;
			     written = written + length (reference);
			end;
		     end;
		end;

		lptr = addrel (lptr, 2);
	     end;

/* write list line */

	     if ^ first then call write;

/* CLEAN UP! */

clean_up:	     entry;

finish:
	     if sptr ^= null
	     then do;
		call hcs_$terminate_noname (sptr, code);
		sptr = null;
	     end;

	     if added_access
	     then do;
		call hcs_$delete_acl_entries (dir, ename, addr (delete_acl), 1, code);
		added_access = "0"b;
	     end;

	     return;


write:	     proc;

		written = written + 1;
		substr (line, written, 1) = nl;
		call ios_$write_ptr (addr (line), 0, written);
		written = 1;

	     end;

	end;

     end;




		    check_dir.pl1                   10/27/83  1614.3rew 10/27/83  1441.5       51894



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


check_dir: proc;

dcl (path, dn) char (168) aligned,
    (en, char32) char (32) aligned,
     myid char (32) aligned,
     line char (120) aligned,
     datstr char (16) aligned,
    (c1, char1) char (1) aligned,
    (i, j, k, l, m, n) fixed bin,
    (ii, jj) fixed bin,
    (pers, tpers (10)) char (32) aligned,
    (proj, tproj (10)) char (32) aligned,
    (tag, ttag (10)) char (4) aligned,
     nids fixed bin init (1),
     idx fixed bin init (2),
     fb71 fixed bin (71) init (0),
     bitc fixed bin (24),
     movelen fixed bin,
     areap ptr init (null),
     barea area ((512)) based (areap),
    (eptr, nptr) ptr init (null),
     ap ptr,
     al fixed bin,
     bchr char (al) unaligned based (ap),
     ec fixed bin (35),
    (p, q) ptr;

dcl  bcs char (131071) based (p) aligned;

dcl  NL char (1) aligned int static init ("
");

dcl (addr, null, substr, index, unspec, length, bit, fixed, divide, mod, abs) builtin;

dcl  establish_cleanup_proc_ entry (entry),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     get_wdir_ entry () returns (char (168) aligned),
     get_system_free_area_ entry (ptr),
     get_group_id_$tag_star entry () returns (char (32) aligned),
     expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)),
     ioa_ entry options (variable),
     ioa_$rsnnl entry options (variable),
     ioa_$nnl entry options (variable),
     ioa_$rs entry options (variable),
     date_time_ entry (fixed bin (71), char (*) aligned),
     com_err_ entry options (variable);

dcl  hcs_$star_list_ entry (char (*) aligned, char (*) aligned, fixed bin (3),
     ptr, fixed bin, fixed bin, ptr, ptr, fixed bin (35)),
     hcs_$get_bc_author entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (35));

dcl  hcs_$list_acl entry (char (*) aligned, char (*) aligned, ptr, ptr, ptr, fixed bin, fixed bin (35)),
     hcs_$list_dir_acl entry (char (*) aligned, char (*) aligned, ptr, ptr, ptr, fixed bin, fixed bin (35)),
     hcs_$add_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35)),
     hcs_$add_dir_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35)),
     hcs_$delete_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35)),
     hcs_$delete_dir_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35)),
     hcs_$replace_acl entry (char (*) aligned, char (*) aligned, ptr, fixed bin, bit (1) aligned, fixed bin (35)),
     hcs_$replace_dir_acl entry (char (*) aligned, char (*) aligned, ptr, fixed bin, bit (1) aligned, fixed bin (35));

dcl 1 btime based aligned,
    2 xpad bit (20) unal,
    2 xdtm bit (36) unal,
    2 ypad bit (16) unal;

dcl 1 br (n) based (eptr) aligned,
    2 type bit (2) unal,
    2 nnam bit (16) unal,
    2 nindex bit (18) unal,
    2 dtm bit (36) unal,
    2 dtu bit (36) unal,
    2 mode bit (5) unal,
    2 pad bit (13) unal,
    2 recs bit (18) unal;

dcl  names (100) char (32) aligned based (nptr);

/* ------------------------------------------------------ */

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then do;
wd:	     dn = get_wdir_ ();
	     go to join;
	end;
	else if bchr = "-wd" then go to wd;

	call expand_path_ (ap, al, addr (dn), null, ec);
	if ec ^= 0 then go to er;

join:	call get_system_free_area_ (areap);
	call establish_cleanup_proc_ (clean);
	myid = get_group_id_$tag_star ();
idlp:	tpers (nids), tproj (nids), ttag (nids) = "*";
	i = index (myid, ".");
	if i = 0 then tpers (nids) = myid;
	else do;
	     if i > 1 then tpers (nids) = substr (myid, 1, i-1);
	     j = index (substr (myid, i+1), ".");
	     if j = 0 then tproj (nids) = substr (myid, i+1);
	     else do;
		tproj (nids) = substr (myid, i+1, j-1);
		ttag (nids) = substr (myid, i+j+1);
	     end;
	end;
	call cu_$arg_ptr (idx, ap, al, ec);
	if ec = 0 then do;				/* If given any ids, override */
	     nids = idx - 1;
	     idx = idx + 1;
	     myid = bchr;
	     go to idlp;
	end;

	call hcs_$star_list_ (dn, "**", 2, areap, n, k, eptr, nptr, ec);
	if ec ^= 0 then do;
er:	     call com_err_ (ec, "check_dir", dn);
	     return;
	end;

	do i = 1 to n;
	     if br (i).type = "10"b then go to skip;
	     en = names (fixed (br (i).nindex, 18));
	     call hcs_$get_bc_author (dn, en, char32, ec);
	     if ec ^= 0 then call com_err_ (ec, "check_dir", "^a>^a", dn, en);
	     else do;
		ii = index (char32, ".");
		pers = substr (char32, 1, ii-1);
		jj = index (substr (char32, ii+1), ".");
		proj = substr (char32, ii+1, jj-1);
		tag = substr (char32, ii+jj+1);
		do m = 1 to nids;
		     if tpers (m) = "*" then;
		     else if tpers (m) ^= pers then go to fail;
		     if tproj (m) = "*" then;
		     else if tproj (m) ^= proj then go to fail;
		     if ttag (m) = "*" then;
		     else if ttag (m) ^= tag then go to fail;
		     go to skip;			/* all match. so not list */
fail:		end;

list:		addr (fb71) -> xdtm = br (i).dtm;
		call date_time_ (fb71, datstr);
		call ioa_ ("^32a^8x^16a  ^32a", en, datstr, char32);
	     end;
skip:	end;

	call clean;

	return;

clean:	proc;

	     if eptr ^= null then
	     free eptr -> br in (barea);
	     if nptr ^= null then
	     free nptr -> names in (barea);

	end clean;

     end;




		    ckauth.pl1                      10/27/83  1614.3rew 10/27/83  1441.5       42408



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


ckauth: proc;

/* CKAUTH - check for file authored by given user */


dcl  path char (168) aligned,				/* root of tree */
     ctime char (24) aligned,
    (co, dp) char (64) aligned,			/* titles for report */
    (c1, char1) char (1) aligned,
    (i, j, k, l, m, n) fixed bin,
    (t1, t2) fixed bin,
     rolder (0: 90) fixed bin,
     folder (0: 90) fixed bin,
     movelen fixed bin,
     slp ptr,
     lth fixed bin (24),
     NL char (1) aligned,
     kk fixed bin,
     ap ptr,
     al fixed bin,
     bchr char (al) unaligned based (ap),
     ec fixed bin,
     total fixed bin int static,
     name char (32) aligned int static init ("Dumper.SysDaemon.a"),
     an fixed bin init (2),
     modsw bit (1) init ("1"b),
    (p, q, p1, q1, p2, q2) ptr;

dcl  clock_ ext entry returns (fixed bin (71)),
     com_err_ entry options (variable),
     ioa_$rsnnl entry options (variable),
     cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin),
     sweep_disk_ ext entry (char (168) aligned, entry),
     expand_path_ ext entry (ptr, fixed bin, ptr, ptr, fixed bin),
     ioa_ entry options (variable),
     date_time_ entry (fixed bin (71), char (*) aligned),
     hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (24),
     fixed bin (2), ptr, fixed bin),
     get_wdir_ entry returns (char (168) aligned),
     hcs_$get_author entry (char (*) aligned, char (*) aligned, fixed bin, char (*) aligned, fixed bin),
     hcs_$get_bc_author entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin),
     hcs_$acl_add1 entry (char (*) aligned, char (*) aligned, char (*) aligned,
     fixed bin (5), (3) fixed bin (3), fixed bin),
     hcs_$terminate_noname entry (ptr, fixed bin);

dcl  bcs char (262144) aligned based (slp);

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

dcl 1 movetable based aligned,
    2 moveary (movelen) fixed bin (35);

/* --------------------- */

	total = 0;
	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then path = ">";
	else path = bchr;

arglp:	call cu_$arg_ptr (an, ap, al, ec);
	if ec = 0 then do;
	     if substr (bchr, 1, 1) = "-" then do;
		if bchr = "-author" | bchr = "-at" then do;
		     modsw = "0"b;
		end;
		else do;
		     call com_err_ (0, "ckauth", "unknown option ^a", bchr);
		     return;
		end;
	     end;
	     else do;				/* not control arg, must be access name */
		name = bchr;
		if index (name, ".") = 0 then do;
		     call com_err_ (0, "ckauth", "no period in access control name ^a", name);
		     return;
		end;
	     end;
	     an = an + 1;
	     go to arglp;
	end;

/* Now, go to work. Call disk sweeper program */

	call sweep_disk_ (path, counter);
	call ioa_ ("Total ^d", total);

	return;

counter:	proc (sdn, sen, lvl, een, bptr, nptr);

dcl  sdn char (168) aligned,				/* superior dir name */
     sen char (32) aligned,				/* dirname */
     lvl fixed bin,					/* distance from root */
     een char (32) aligned,				/* entry name */
     bptr ptr,					/* ptr to info structure */
     nptr ptr;					/* ptr to names structure */

dcl  xp char (168) aligned,
     xi fixed bin,
     hisid char (32) aligned,
     mode fixed bin (5);

dcl 1 branch based (bptr) aligned,			/* thing returned by star_long */
    2 type bit (2) unal,
    2 nname bit (16) unal,
    2 nindex bit (18) unal,
    2 dtm bit (36) unal,
    2 dtu bit (36) unal,
    2 mode bit (5) unal,
    2 pad bit (13) unal,
    2 records bit (18) unal;

dcl 1 links based (bptr) aligned,
    2 type bit (2) unal,				/* 00b */
    2 nname bit (16) unal,
    2 nindex bit (18) unal,
    2 dtm bit (36) unal,
    2 dtd bit (36) unal,
    2 pln bit (18) unal,
    2 pnindex bit (18) unal;

dcl  names (100) char (32) based (nptr);

	xi = fixed (branch.type);
	if xi ^= 1 then return;
	     call ioa_$rsnnl ("^a>^a", xp, xi, sdn, sen);
	     if modsw then call hcs_$get_bc_author (xp, een, hisid, ec);
	     else call hcs_$get_author (xp, een, 0, hisid, ec);
	     if ec ^= 0 then do;
		call com_err_ (ec, "ckauth", "^a>^a", xp, een);
	     end;
	     else do;
		if name = hisid then do;
		     total = total + 1;
		     call ioa_ ("^a>^a", xp, een);
		end;
	     end;

	end counter;

     end ckauth;




		    command_usage_count.pl1         10/27/83  1614.3rew 10/27/83  1441.5      162963



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


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Name: command_usage_count							*/
	/*									*/
	/* Status:								*/
	/* 1) Modified in July, 1983 by G. Dixon - increase number of commands which can be	*/
	/*    monitored from 200 (user_list_size) to max number of usage_list.commands entries	*/
	/*    which will fit in a segment.						*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


command_usage_count:
cuc:
     procedure () options (variable);

dcl  code fixed bin (35),
     errsw bit (1),
     first fixed bin init (user_list_size),
     last_index fixed bin init (0),
     me char (19) static init ("command_usage_count"),
     message char (80) var,
     tempstring char (32) var,
     userseg_name char (32);

dcl  arg char (argl) based (argp),			/* argument from cu_$arg_ptr */
     argl fixed bin,
     argp ptr;

dcl  arg_no fixed bin init (1),			/* no. of argument being processed */
     nargs fixed bin;				/* no. of arguments */

dcl  comlist (40) char (32) var,			/* array for command name arguments */
     ncom fixed bin init (0);				/* length of the array */

dcl (i, j, k, list_size, maxj, total) fixed bin;		/* temporaries */

dcl (usage_list_ptr, segptr, usage_totals_ptr, user_list_ptr) pointer;

dcl (add,						/* add request given */
     all,						/* -all option given */
     clear,					/* -clear option given */
     delete,					/* delete request given */
     header,					/* heading printed */
     i_locked_it,					/* control lock needs opened */
     print,					/* print request given */
     total_only) bit (1) init ("0"b);			/* -total option given */

%include command_usage;

dcl  com_err_ ext entry options (variable),
     copy_acl_ ext entry (char (*), char (*), char (*), char (*), bit (1), fixed bin (35)),
     cu_$arg_count ext entry (fixed bin),
     cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     cv_dec_check_ ext entry (char (*), fixed bin (35)) returns (fixed bin (35)),
     hcs_$delentry_file ext entry (char (*), char (*), fixed bin (35)),
     hcs_$fs_get_path_name ext entry (ptr, char (*), fixed bin, char (*), fixed bin (35)),
     hcs_$initiate ext entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     hcs_$make_ptr ext entry (ptr, char (*), char (*), ptr, fixed bin (35)),
     hcs_$make_seg ext entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)),
     hcs_$terminate_noname ext entry (ptr, fixed bin (35)),
     hcs_$truncate_seg ext entry (ptr, fixed bin, fixed bin (35)),
     get_temp_segment_ entry (character (*), pointer, fixed binary (35)),
     release_temp_segment_ entry (character (*), pointer, fixed binary (35)),
     ioa_ entry options (variable);

dcl (error_table_$badcall,
     error_table_$badopt,
     error_table_$bad_conversion,
     error_table_$bigarg,
     error_table_$inconsistent,
     error_table_$namedup,
     error_table_$noarg,
     error_table_$noentry,
     error_table_$notalloc,
     error_table_$seglock,
     error_table_$too_many_names,
     error_table_$zero_length_seg) external static fixed bin (35);

dcl  cleanup condition;

dcl (addr, fixed, index, length, null, rel, size, substr) builtin;

/* PROCESS ARGUMENT LIST */


	call cu_$arg_count (nargs);
arg_get:	call cu_$arg_ptr (arg_no, argp, argl, code);
	if code ^= 0 then go to err_nomsg;
	if arg_no = 1 then go to key;

	if substr (arg, 1, 1) = "-" then go to ctl_arg;	/* control argument found */

	if ncom >= 40 then do;			/* too many command name arguments ? */
	     code = error_table_$too_many_names;
	     go to err_nomsg;
	end;

	if argl > 32 then do;			/* command name argument too long ? */
	     code = error_table_$bigarg;
	     go to arg_err;
	end;

	ncom = ncom + 1;
	comlist (ncom) = arg;
	go to arg_loop;

ctl_arg:	if add | print then				/* for add or print requests only: */
	     if arg = "-tt" | arg = "-total" then do;	/*   check for "-total" option */
	     total_only = "1"b;
	     go to arg_loop;
	end;

	if delete | print then			/* for delete or print requests only: */
	     if arg = "-a" | arg = "-all" then do;	/*   check for "-all" option */
	     all = "1"b;
	     go to arg_loop;
	end;

	if print then				/* for print requests only: */
	     if arg = "-ft" | arg = "-first" then do;	/*   check for "-first n" option */
	     arg_no = arg_no + 1;
	     call cu_$arg_ptr (arg_no, argp, argl, code);
	     if code ^= 0 then go to err_nomsg;
	     first = cv_dec_check_ (arg, code);
	     if code ^= 0 then do;
		code = error_table_$bad_conversion;
		go to arg_err;
	     end;
	     go to arg_loop;
	end;

	if print then				/* for print requests only: */
	     if arg = "-cl" | arg = "-clear" then do;	/*   check for "-clear" option */
	     clear = "1"b;
	     go to arg_loop;
	end;

	if print then				/* for print requests only: */
	     if arg = "-brief" | arg = "-bf" then do;	/*   check for "-brief" option */
	     header = "1"b;				/* don't print heading */
	     go to arg_loop;
	end;

	code = error_table_$badopt;			/* unknown control option */
	go to arg_err;

key:	if arg = "pr" | arg = "print" then do;		/* print request */
	     print = "1"b;
	     go to arg_loop;
	end;
	if arg = "add" then do;			/* add request */
	     add = "1"b;
	     go to arg_loop;
	end;
	if arg = "dl" | arg = "delete" then do;		/* delete request */
	     delete = "1"b;
	     go to arg_loop;
	end;
	code = error_table_$badcall;			/* unknown key argument */
	go to arg_err;

arg_loop: arg_no = arg_no + 1;
	if arg_no <= nargs then go to arg_get;



/* CHECK ARGUMENT CONSISTENCY */


	if all & ncom ^= 0 then do;
	     code = error_table_$inconsistent;
	     message = "-all and " || comlist (1);
	     go to err_msg;
	end;
	if total_only & first ^= user_list_size then do;
	     code = error_table_$inconsistent;
	     message = "-total and -first";
	     go to err_msg;
	end;

	if ncom = 0 then				/* add request must specify a command name list */
	     if add | (delete & ^all) then do;		/* "-all" is default for print, but not for delete */
	     code = error_table_$noarg;
	     go to err_nomsg;
	end;


/* INITIATE LIST AND TOTALS SEGMENTS */

	call hcs_$make_ptr (null, "command_usage_list_", "", usage_list_ptr, code);
	if code ^= 0 then go to list_err;

	call hcs_$make_ptr (null, "command_usage_totals_", "", usage_totals_ptr, code);
	if code ^= 0 then go to totals_err;


/* SET LOCK FOR MODIFICATION REQUESTS */


	if add | delete | clear then do;		/* if any modification of the control or */
	     if ^usage_list.locked then do;		/* usage segments is requested, then set */
		usage_list.locked = "1"b;		/* a lock against other modification requests */
		i_locked_it = "1"b;			/* remember to reset the lock */

		on cleanup begin;			/* reset lock if aborted */
		     usage_list.locked = "0"b;	/* entrance to this condition proves */
		end;				/* that i set lock */

	     end;
	     else do;				/* lock is already set */
		code = error_table_$seglock;
		message = "command_usage_list_^/The command list is being edited - try again later.";
		go to err_msg;
	     end;
	end;

	list_size = usage_list.n_commands;		/* copy command name list size */

	if add then go to add_com;


/* PROCESS PRINT AND DELETE REQUESTS */


	if list_size = 0 then do;			/* see if anything is there to process. */
	     code = error_table_$zero_length_seg;
	     message = "command_usage_list_^/The command name list is empty.";
	     go to err_msg;
	end;
	if print & ^total_only then do;		/* get a scratch segment if needed */
	     call get_temp_segment_ ((me), user_list_ptr, code);
	     if user_list_ptr = null () then go to temp_err;
	end;

/* If we are deleting entries, things get juggled around, so turn off usage
   monitoring for a few milliseconds.  We don't want to set a lock that would
   be waited on by any process executing any command (including one attempting
   to reset that lock).  Losing a few tallies isn't that important. */

	if delete then usage_list.n_commands = 0;

	if ncom ^= 0 then go to select;		/* print or delete selected entries */

	do k = 1 to list_size;			/* print or delete all entries */
	     if commands.primary (k) then call print_or_delete; /* process each command name group */
	end;
	if ^delete then go to print_done;
						/* we just deleted every thing, so */
						/* truncate segments to zero length */
	call hcs_$truncate_seg (usage_list_ptr, 0, code);
	if code ^= 0 then go to list_err;
	call hcs_$truncate_seg (usage_totals_ptr, 0, code);
	if code ^= 0 then go to totals_err;
						/* Note: truncating command_usage_list_ resets the lock */
	return;					/* so just return */

select:	do j = 1 to ncom;				/* go through list of command name arguments */
	     do k = 1 to list_size;			/* find name in the control list */
		if commands.name (k) = comlist (j) then go to found;
	     end;
	     go to next_com;			/* not there, print error message when done */
found:	     if ^commands.primary (k) then k = commands.slot (k);	/* get the primary entry of the command group */
	     call print_or_delete;			/* process command group */
	     comlist (j) = "";			/* clear argument from list to say we did it */
next_com: end;

	if delete then do;				/* truncate control segment */
	     call hcs_$truncate_seg (usage_list_ptr, fixed (rel (addr (commands.name (list_size+1)))), code);
	     if code ^= 0 then go to list_err;
	     usage_list.n_commands = list_size;		/* turn monitoring back on */
	end;
	do j = 1 to ncom;				/* check for names not found */
	     if comlist (j) ^= "" then
		call com_err_ (error_table_$noentry, (me), "^a", comlist (j));
	end;
print_done:
	if print & ^total_only then
	     call release_temp_segment_ ((me), user_list_ptr, (0));

	go to quit;				/* done */


/* PROCESS ADD REQUESTS */


add_com:	if list_size = 0 then do;			/* initialize */
	     call hcs_$fs_get_path_name (usage_totals_ptr, usage_list.directory, k, "", code);
	     if code ^= 0 then go to totals_err;
	     call hcs_$truncate_seg (usage_totals_ptr, 0, code);
	     if code ^= 0 then go to totals_err;
	end;

	do k = 1 to list_size;			/* check for duplication of command names */
	     do j = 1 to ncom;
		if commands.name (k) = comlist (j) then do;
		     code = error_table_$namedup;
		     message = comlist (j) || "^/Command name already in table.";
		     go to err_msg;
		end;
	     end;
	     if commands.primary (k) then last_index = commands.slot (k); /* locate last used index in totals list */
	end;

          usage_list_size = ncom + list_size;
	if usage_list_size > 7000 then do;
	     code = error_table_$notalloc;		/* would adding this command group make too many ? */
	     message = "command_usage_list_^/The command name list is full.";
	     go to err_msg;
	end;

	if ^total_only then do;			/* if creating a user usage segment, */
	     if length (comlist (1)) < 27 then go to add_user_seg; /* check length of the first command name */
	     do j = 2 to ncom;			/* too long - search names for a shorter one */
		if length (comlist (j)) < 27 then do;	/* found one - move to the front of the list */
		     tempstring = comlist (1);
		     comlist (1) = comlist (j);
		     comlist (j) = tempstring;
		     go to add_user_seg;
		end;
	     end;

	     code = error_table_$bigarg;
	     message = "Some command name must be less than 27 characters long.^/Add request ignored.";
	     go to err_msg;

add_user_seg:  
	     userseg_name = comlist (1) || ".usage";	/* create segment name */
	     call hcs_$make_seg (usage_list.directory, userseg_name, "", 01011b, user_list_ptr, code);
	     if user_list_ptr = null then go to userseg_err;
	     call copy_acl_ (usage_list.directory, "command_usage_totals_",
	     usage_list.directory, userseg_name, errsw, code);
	     if code ^= 0 then
		if errsw then go to userseg_err;
	     else go to totals_err;

	     call hcs_$truncate_seg (user_list_ptr, 0, code); /* truncate segment */
	     if code ^= 0 then go to userseg_err;

	     call hcs_$terminate_noname (user_list_ptr, code); /* done with user segment */
	     if code ^= 0 then go to userseg_err;

	end;

	do j = 1 to ncom;
	     commands.name (list_size+j) = comlist (j);	/* copy command name to list entry */
	     commands.primary (list_size+j) = "0"b;		/* say entry is not a primary one */
	     commands.slot (list_size+j) = list_size + 1;	/* make secondaries point to primary entry */
	end;

	commands.primary (list_size+1) = "1"b;		/* now make the first entry a primary entry */
	commands.slot (list_size+1) = last_index + 1;	/* it's slot element points to the usage totals tally */
	commands.count_users (list_size+1) = ^total_only;	/* says whether a user usage segment exists */
	usage_totals (last_index + 1) = 0;		/* clear usage total tally */
	usage_list.n_commands = list_size + ncom;		/* finally increase size of command name list */



/* EXIT */


quit:	if i_locked_it then usage_list.locked = "0"b;	/* if lock set by this process, reset it */
	return;
	

/* INTERNAL PROCEDURE TO PROCESS A SINGLE PRINT OR DELETE REQUEST */


print_or_delete: proc;
dcl  j fixed bin;

	     if delete then go to delete_com;

	     if ^header then do;			/* heading needed */
		if total_only then

		     call ioa_ ("USAGE^-COMMAND^/COUNT^-GROUP^/");
		else
		call ioa_ ("USAGE^-COMMAND^-USER^-USER^/COUNT^-GROUP^-COUNT^-NAME^/");
		header = "1"b;			/* heading now printed */
	     end;

	     total = usage_totals (commands.slot (k));	/* save usage total */

	     if clear then				/* reset total if clearing */
		usage_totals (commands.slot (k)) = 0;

	     if commands.count_users (k) then			/* if a user usage segment exists and */
		if ^total_only | clear then do;	/* we need it, then initiate it */

		userseg_name = commands.name (k) || ".usage"; /* segment name */
		call hcs_$initiate (usage_list.directory, userseg_name, "", 0, 1, segptr, code);
		if segptr = null () then go to userseg_err;

		if ^total_only then			/* if printing user counts, copy them to temporary */
		     user_list_ptr -> user_list = segptr -> user_list;

		if clear then do;			/* reset user counts if clearing */
		     call hcs_$truncate_seg (segptr, 0, code);
		     if code ^= 0 then go to userseg_err;
		end;

		call hcs_$terminate_noname (segptr, code); /* done with segment */
		if code ^= 0 then go to userseg_err;

	     end;

	     call ioa_ ("^5d^-^a", total, commands.name (k));	/* now do the printing */
	     do i = k+1 to list_size while (^commands.primary (i));
		call ioa_ ("^-^a", commands.name (i));	/* print all names in the command group */
	     end;

	     if ^commands.count_users (k) | total_only then return;

	     do i = 1 to user_list_size;			/* print the user usage counts */
		maxj = 1;				/* in descending order */
		do j = 1 to user_list_size;		/* find the largest tally */
		     if user_list.count (j) > user_list.count (maxj) then maxj = j;
		end;

		if user_list.count (maxj) = 0 then go to end_of_print; /* if the largest is zero, then done */
		if i > first then go to end_of_print;	/* check -first n value */
		total = total - user_list.count (maxj);	/* check user counts against total */

		tempstring = user_list.name (maxj);	/* copy user identifcation */
		j = index (tempstring, "*");		/* form is "person.project.*" */
		if j ^= 0 then			/* we want only "person.project" */
		     tempstring = substr (tempstring, 1, j-2);
		call ioa_ ("^2-^5d^-^a", user_list.count (maxj), tempstring); /* print a line */
		user_list.count (maxj) = 0;		/* clear this entry and repeat */
	     end;

end_of_print:  if total > 0 then			/* print result of error check */
		call ioa_ ("^2-^5d^-^a", total, "all others");
	     call ioa_ ("");
	     return;

delete_com:    if commands.count_users (k) then do;		/* is there a user usage segment ? */
		userseg_name = commands.name (k) || ".usage"; /* yes */
		call hcs_$delentry_file (usage_list.directory, userseg_name, code); /* delete it */
		if code ^= 0 then go to userseg_err;
	     end;
	     if all then return;			/* if deleting everything, the following is not needed */

	     do i = commands.slot (k) to user_list_size;		/* move total tallies past deleted one down by one */
		usage_totals (i) = usage_totals (i+1);
	     end;

	     do i = k+1 to list_size while (^commands.primary (i)); /* find size of command group we are deleting */
	     end;
	     i = i - k;				/* "i" is now the size */

	     do j = k to list_size;			/* move command entries past this group down */
		commands.name (j) = commands.name (j+i);
		commands.primary (j) = commands.primary (j+i);
		if commands.primary (j) then commands.slot (j) = commands.slot (j+i) - 1; /* total tally moved down one */
		else commands.slot (j) = commands.slot (j+i) - i;	/* primary entry moved down by i */
		commands.count_users (j) = commands.count_users (j+i);
	     end;
	     list_size = list_size - i;		/* shorten command list length */
	     return;				/* done */
	end print_or_delete;
	

/* ERROR ROUTINES */


arg_err:	call com_err_ (code, (me), arg);		/* never called with lock set */
	return;

list_err: message = "command_usage_list_";
	go to err_msg;

totals_err: message = "command_usage_totals_";
	go to err_msg;

userseg_err: message = userseg_name;
	go to err_msg;

temp_err: message = "temporay segment";

err_msg:	if i_locked_it then				/* may be called with lock set */
	     if delete & ^all then usage_list.n_commands = list_size;
	call com_err_ (code, (me), message);
	go to quit;

err_nomsg: call com_err_ (code, (me));			/* never called with lock set */
	return;

     end command_usage_count;




		    console_edit.pl1                10/27/83  1614.3rew 10/27/83  1441.5       16029



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


console_edit: proc;

/* CONSOLE_REPORT - produce a report of console use

   Input is the accounting deck for the month
   THVV 2/71
   */

dcl (path, dn) char (168) aligned,
     en char (32) aligned,
     j fixed bin,
     idc char (8) aligned,
     ask_ entry options (variable),
     ask_$ask_line entry options (variable),
     ask_$ask_clr entry options (variable),
     ec fixed bin;

dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin),
     com_err_ entry options (variable),
     hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5),
     ptr, fixed bin);

dcl (null, addr) builtin;


%include console_report_data;

/* ============================= */

	path = "termseg";
	call expand_path_ (addr (path), 7, addr (dn), addr (en), ec);
	call hcs_$make_seg (dn, en, "", 1011b, tsp, ec);
	if tsp = null then do;
er:	     call com_err_ (ec, "cdei", path);
	     return;
	end;
	call ask_$ask_clr;
loop:	call ask_ ("idcode ", idc);
	if idc = "callexit" then return;
	do j = 1 to nterms;
	     if id (j) = idc then go to f1;
	end;
	j, nterms = nterms + 1;
	call ask_$ask_clr ();
	go to loop;
f1:	if cm (j) ^= "" then call ask_$ask_line (cm (j), cm (j));
	else call ask_$ask_line ("where ", cm (j));
	go to loop;

     end;




		    cv_cmf.rd                       12/01/89  1002.2rew 12/01/89  1000.0      397080



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

/* format: style2,indcomtxt */

/* CV_CMF - Program to compile the Channel Master File into a Channel Definition Table.
   Written August 1975 by THVV
   Modified 751117 by PG to add access_name stmt
   Modified 760512 by Mike Grady to add baud stmt and FNP info
   Modified 760705 by D. M. Wells to understand about FTP channels
   Modified November 1976 by T. Casey to allow name: ttyNXX-ttyNYY; and Baud: NNN;
   Modified 761229 by D. M. Wells to allow compatibility for renamed items --
   line_type TELNET and service_types FTP and MC
   Modified 770624 by Robert Coren to make terminal types be character strings
   and to add dont_read_answerback attribute.
   Modified Fall 1978 by Larry Johnson for demultiplexing.
   Modified April 1979 by Larry Johnson to move most checking of multiplexer
   and sub-channel specifications into multiplexer specific modules,
   and to allow FNP's to be specified other than those running MCS.
   Modified July 1979 by C. Hornig to allow non-FNP MCS channels.
   Modified 1979 August 21 by Art Beattie to accomodate a change to cdt.incl.pl1.
   Modified January 1981 by E. N. Kittlitz to eliminate cdte.phone_no.
   Modified May 1981 by Robert Coren to call parse_tty_name_.
   Modified December 1981 by Benson I. Margulies for cdt tree.
   Modified April 1982 by Robert Coren for change to baud_rates.incl.pl1.
   Modified July 1982 by E. N. Kittlitz for [severity] and cmf suffix.
   Modified August 1982 by E. N. Kittlitz for check_acs.
   Modified January 1983 by Keith Loepere for generic_destination.
   Modified 84-01-09 by BIM for more access control flags.
*/


/* HISTORY COMMENTS:
  1) change(86-09-21,Beattie), approve(86-09-21,MCR7542),
     audit(86-10-31,Brunelle), install(86-11-12,MR12.0-1211):
     Remove references to the 963 and 029 preaccess commands and
     remove support for ARDS, 202_ETX, 2741 and 1050 in system
     interfaces.
  2) change(87-03-17,Beattie), approve(87-05-04,MCR7682),
     audit(87-05-29,Parisek), install(87-07-17,MR12.1-1042):
     Fix bug in mpx_error where errors in CMF that are detected by
     multiplexers were not getting displayed.
                                                   END HISTORY COMMENTS */


/*++

BEGIN	/ <no-token>			/ ERROR(2)				/ RETURN \

mainloop	/ FNP : <any-token> ;		/ LEX(2) open_fnp LEX(2) PUSH(mainloop)		/ do_fnp \
	/ name : <any-token> ;		/ LEX(2) open_chn LEX(2) PUSH(mainloop)		/ do_name \

	\" Master Keywords.  These supply defaults for all cdte's following.

	/ Access_class : <access_class> ;	/ LEX(4) [dft.access_class = access_class_value] / mainloop \
	/ Access_class :			/ LEX(2) ERROR(10) NEXT_STMT			/ mainloop \
	/ Check_acs :                           / LEX(2) PUSH(mainloop) PUSH (assign_dft_access)   / checksub \
	/ Attributes :			/ LEX(2) PUSH(mainloop) PUSH(assign_dft)	/ attsub \
	/ Baud : <legal_baud> ;		/ LEX(2) [dft.baud_rate = baud_rate_value; dft.flags.autobaud = ""b]
									LEX(2)	/ mainloop \
	/ Baud : auto ;			/ LEX(2) [dft.baud_rate = 0; dft.flags.autobaud = "1"b]
									LEX(2)	/ mainloop \
	/ Baud : none ;			/ LEX(2) [dft.baud_rate = 0; dft.flags.autobaud = ""b]
									LEX(2)	/ mainloop \
	/ Baud :				/ LEX(2) ERROR(29) NEXT_STMT			/ mainloop \
	/ Line_type : <legal_line_type> ;	/ LEX(2) [dft.line_type = line_type_value] LEX(2)	/ mainloop \
	/ Line_type :			/ LEX(2) ERROR(11) NEXT_STMT			/ mainloop \
	/ Terminal_type : <any-token> ;		/ LEX(2) check_terminal_type
					 [dft.initial_terminal_type = terminal_type_value] LEX(2)
										/ mainloop \
	/ Terminal_type :			/ LEX(2) ERROR(8) NEXT_STMT			/ mainloop \
	/ Comment : <any-token> ;		/ LEX(2) [dft.comment = token_value] LEX(2)	/ mainloop \
	/ Initial_command : <any-token> ;	/ LEX(2) [dft.initial_command = token_value; dft.execute_initial_command = token_value ^= ""] LEX(2) / mainloop \
	/ Generic_destination : <any-token> ;	/ LEX(2) [addr (dft.initial_command) -> generic_destination = token_value; dft.generic_destination_present = token_value ^= ""] LEX(2) / mainloop \
	/ Charge : <legal_charge> ;		/ LEX(2) [dft.charge_type = charge_value] LEX(2)	/ mainloop \
	/ Charge :			/ LEX(2) ERROR(12) NEXT_STMT			/ mainloop \
	/ Service : <legal_service> ;		/ LEX(2) [dft.service_type = service_value] LEX(2) / mainloop \
	/ Service :			/ LEX(2) ERROR(16) NEXT_STMT			/ mainloop \
	/ FNP_required_up_time : <decimal-integer> ; / LEX(2) [cdt.acceptable_fnp_tbf = token.Nvalue] LEX(2)
										/ mainloop \
	/ FNP_required_up_time :		/ LEX(2) ERROR(44) NEXT_STMT			/ mainloop \
	/ Spare_channel_count : <decimal-integer> ; / LEX(2) [cdt.spare_channel_count = token.Nvalue] LEX(2)
										/ mainloop \
	/ Spare_channel_count :		/ LEX(2) ERROR(47) NEXT_STMT			/ mainloop \

	/ end ;				/					/ RETURN \
	/ <any-token> :			/ ERROR(3) NEXT_STMT			/ mainloop \
	/ <any-token>			/ ERROR(4) NEXT_STMT			/ mainloop \
	/ <no-token>			/ ERROR(5)				/ RETURN \


	\" 
	\" do_name subroutine - handles name sub-keywords

do_name	/ access_class : <access_class> ;	/ LEX(4) [cdte.access_class = access_class_value] / do_name \
	/ access_class :			/ LEX(2) ERROR(10) NEXT_STMT			/ do_name \
	/ baud : auto ;			/ LEX(2) [cdte.flags.autobaud = "1"b; cdte.baud_rate = 0]
									LEX(2)	/ do_name \
	/ baud : none ;			/ LEX(2) [cdte.flags.autobaud = "0"b; cdte.baud_rate = 0]
									LEX(2)	/ do_name \
	/ baud : <legal_baud> ;		/ LEX(2) [cdte.baud_rate = baud_rate_value] LEX(2) / do_name \
	/ baud :				/ LEX(2) ERROR(29) NEXT_STMT			/ do_name \
          / check_acs :                           / LEX(2) PUSH(do_name) PUSH(assign_access)        / checksub \
	/ attributes :			/ LEX(2) PUSH(do_name) PUSH(assign_attr)	/ attsub \
	/ answerback : <any-token> ;		/ LEX(2) [cdte.answerback = token_value] LEX(2)	/ do_name \
	/ line_type : <legal_line_type>	/ LEX(2) [cdte.line_type = line_type_value] LEX(1) / line_type \
	/ line_type :			/ LEX(2) ERROR(11) NEXT_STMT			/ do_name \
	/ dataset : <legal_dataset>		/ LEX(2) [cdte.modem_type = dataset_value] LEX(1) / dataset \
	/ dataset :			/ LEX(2) ERROR (38) NEXT_STMT			/ do_name \
	/ terminal_type : <any-token> ;		/ LEX(2) check_terminal_type
					 [cdte.initial_terminal_type = terminal_type_value] LEX(2)
										/ do_name \
	/ terminal_type :			/ LEX(2) ERROR(8) NEXT_STMT			/ do_name \
	/ comment : <any-token> ;		/ LEX(2) [cdte.comment = token_value] LEX(2)	/ do_name \
	/ initial_command : <any-token> ;	/ LEX(2) [cdte.initial_command = token_value; cdte.execute_initial_command = token_value ^= ""] LEX(2) / do_name \
	/ generic_destination : <any-token> ;	/ LEX(2) [addr (cdte.initial_command) -> generic_destination = token_value; cdte.generic_destination_present = token_value ^= ""] LEX(2) / do_name \
	/ charge : <legal_charge> ;		/ LEX(2) [cdte.charge_type = charge_value] LEX(2)	/ do_name \
	/ charge :			/ LEX(2) ERROR(12) NEXT_STMT			/ do_name \
	/ service : <legal_service> ;		/ LEX(2) [cdte.service_type = service_value] LEX(2)
										/ do_name \
	/ service :			/ LEX(2) ERROR(16) NEXT_STMT			/ do_name \
	/ multiplexer_type : <legal_mpx_type> , <legal_fnp_service> ;
					/ LEX(2) [cdte.mpx_type = mpx_type_value]
					  LEX(2) [cdte.mpx_service = service_value] LEX(2)
										/ do_name \
	/ multiplexer_type : <legal_mpx_type> ,	/ LEX(4) ERROR(16) NEXT_STMT			/ do_name\
	/ multiplexer_type : <legal_mpx_type> ;	/ LEX(2) [cdte.mpx_type = mpx_type_value] LEX(2)	/ do_name \
	/ multiplexer_type :		/ LEX(2) ERROR(51) NEXT_STMT			/ do_name \
	/ <any-token>			/ close_chn				/ STACK_POP \
	/ <no-token>			/ close_chn				/ STACK_POP \

	\" 

	\" a couple of routines to handle line_type and dataset options

dataset	/ ,				/ LEX					/ ds_opt \
	/ ;				/ LEX					/ do_name \
	/ <any-token>			/ ERROR(4) NEXT_STMT			/ do_name \
	/ <no-token>			/ ERROR(5)				/ RETURN \

ds_opt	/ private_line			/ LEX [cdte.flags.private_line = "1"b]		/ dataset \
	/ <any-token>			/ ERROR(40) NEXT_STMT			/ do_name \
	/ <no-token>			/ ERROR(5)				/ RETURN \

line_type	/ ,				/ LEX					/ lt_opt \
	/ ;				/ LEX					/ do_name \
	/ <any-token>			/ ERROR(4) NEXT_STMT			/ do_name \
	/ <no-token>			/ ERROR(5)				/ RETURN \

lt_opt	/ ebcdic				/ LEX [cdte.flags.bsc_ebcdic = "1"b]		/ line_type \
	/ ascii				/ LEX [cdte.flags.bsc_ebcdic = "0"b]		/ line_type \
	/ transparent			/ LEX [cdte.flags.bsc_transparent = "1"b]	/ line_type \
	/ nontransparent			/ LEX [cdte.flags.bsc_transparent = "0"b]	/ line_type \
	/ <any-token>			/ ERROR(41) NEXT_STMT			/ do_name \
	/ <no-token>			/ ERROR(5)				/ RETURN \

	\" do_fnp subroutine - handles FNP sub-keywords

do_fnp	/ type : <legal_fnp_type> ;		/ LEX(2) [fnpe.type = fnp_type_value] LEX(2)	/ do_fnp \
	/ type :				/ LEX(2) ERROR(19) NEXT_STMT			/ do_fnp \
	/ memory : <decimal-integer> ;	/ LEX(2) [fnpe.memory = token.Nvalue] LEX(2)	/ do_fnp \
	/ memory :			/ LEX(2) ERROR(20) NEXT_STMT			/ do_fnp \
	/ lsla : <decimal-integer> ; 		/ LEX(2) [fnpe.nlslas = token.Nvalue] LEX(2)	/ do_fnp \
	/ lsla :				/ LEX(2) ERROR(21) NEXT_STMT			/ do_fnp \
	/ hsla : <decimal-integer> ;		/ LEX(2) [fnpe.nhslas = token.Nvalue] LEX(2)	/ do_fnp \
	/ hsla :				/ LEX(2) ERROR(21) NEXT_STMT			/ do_fnp \
	/ image : <any-token> ;		/ LEX(2) [fnpe.coreimage = token_value] LEX(2)	/ do_fnp \
	/ image :				/ LEX(2) ERROR(22) NEXT_STMT			/ do_fnp \
	/ additional_info : <any-token> ;	/ LEX(2) [fnpe.coreimage = token_value] LEX(2)	/ do_fnp\
	/ additional_info :			/ [fnpe.coreimage = ""] NEXT_STMT		/ do_fnp \
	/ service : <legal_fnp_service> ;	/ LEX(2) [fnpe.service_type = service_value] LEX(2) / do_fnp \
	/ service :			/ LEX(2) ERROR(16) NEXT_STMT			/ do_fnp \
	/ multiplexer_type : <legal_mpx_type> ;	/ LEX(2) [fnpe.mpx_type = mpx_type_value] LEX(2)	/do_fnp\
	/ multiplexer_type :		/ LEX(2) ERROR(51) NEXT_STMT			/do_fnp\
	/ <any-token>			/ close_fnp				/ STACK_POP \
	/ <no-token>			/ close_fnp				/ STACK_POP \

	\" 

	\" attsub subroutine - handles attributes lists

attsub	/				/ [sx=ON; ats=dft.attributes] / \

attloop	/ ;				/ LEX					/ STACK_POP \
	/ none				/ LEX [string(ats)=""b]					/ atts \
	/ ^				/ LEX [sx=OFF]				/ \
	/ set_modes			/ LEX [ats.set_modes=sx]		/ atts \
	/ audit				/ LEX [ats.audit_access_error=sx]		/ atts \
	/ hardwired			/ LEX [ats.hardwired=sx]		/ atts \
	/ check_answerback			/ LEX [ats.ck_answerback=sx]		/ atts \
	/ dont_read_answerback		/ LEX [ats.dont_read_answerback=sx]	/ atts \
	/ <any-token>			/ ERROR(14) NEXT_STMT			/ STACK_POP \
	/ <no-token>			/ ERROR(7)				/ RETURN \

atts	/ ,				/ LEX [sx = ON]				/ attloop \
	/ ;				/ LEX					/ STACK_POP \

	/ <any-token>			/ ERROR(15) NEXT_STMT			/ STACK_POP \
	/ <no-token>			/ ERROR(7)				/ RETURN \

assign_attr /				/ [cdte.attributes = ats]
										/ STACK_POP \
assign_dft /				/ [dft.attributes=ats]
										/ STACK_POP \


checksub  /                                       / [sx=ON;access=dft.access_control]                     / \

checkloop / ;                                     / LEX				         / STACK_POP \
	/ none				/ LEX [string(access)=""b]		         / checks \
          / all				/ LEX [string(access)=ALL_ACCESS_CHECKS]         / checks \
	/ ^				/ LEX [sx=OFF]			         / \
	/ login				/ LEX [access.login=sx]		         / checks \
	/ slave_dial			/ LEX [access.slave_dial=sx]		         / checks \
	/ dial_server			/ LEX [access.dial_server=sx]		         / checks \
	/ dial_out  			/ LEX [access.dial_out=sx]		         / checks \
	/ priv_attach			/ LEX [access.priv_attach=sx]		         / checks \
	/ <any-token>			/ ERROR(27) NEXT_STMT		         / STACK_POP \
	/ <no-token>			/ ERROR(26)			         / RETURN \

checks	/ ,				/ LEX [sx=ON]			         / checkloop \
	/ ;				/ LEX				         / STACK_POP \
	/ <any-token>			/ ERROR(27) NEXT_STMT		         / STACK_POP \
	/ <no-token>			/ ERROR(26)			         / RETURN \

assign_dft_access
          /                                       / [dft.access_control=access]                    / STACK_POP \
assign_access
         /				/ [cdte.access_control=access]	         / STACK_POP \

   ++*/


cv_cmf:
     procedure;

/* automatic */

	dcl     (APstmt, APtoken, areap, cmfp)
				 ptr;

	dcl     1 dft		 aligned like cdte;
	dcl     1 ats		 aligned like cdte.attributes;
	dcl     1 access		 aligned like cdte.access_control;
	dcl     ALL_ACCESS_CHECKS	 bit (5) init ("11111"b) int static options (constant);

	dcl     access_class_value	 (2) bit (72) aligned;
	dcl     charge_value	 fixed bin;
	dcl     service_value	 fixed bin;
	dcl     line_type_value	 fixed bin;
	dcl     terminal_type_value	 char (32);
	dcl     fnp_type_value	 fixed bin;
	dcl     dataset_value	 fixed bin;
	dcl     baud_rate_value	 fixed bin;
	dcl     mpx_type_value	 fixed bin;

	dcl     mpx_error_printedp	 ptr init (null ());
	dcl     system_areap	 ptr;

	dcl     dn		 char (168);
	dcl     (supplied_en, cmf_en, cdt_en)
				 char (32);
	dcl     (i, n)		 fixed bin;
	dcl     fnpno		 fixed bin;
	dcl     ndev		 fixed bin;
	dcl     bitc		 fixed bin (24);
	dcl     (argc, argx)	 fixed bin;
	dcl     ap		 ptr;
	dcl     al		 fixed bin (21);
	dcl     ec		 fixed bin (35);
	dcl     code		 fixed bin (35);
	dcl     created_table_segment	 bit (1) aligned;
	dcl     sx		 bit (1) aligned;
	dcl     fb35		 fixed bin (35);

	dcl     1 dvt		 (16) aligned,
		2 device_id	 char (8),
		2 device_prices	 (0:7) float;

/* based */

	dcl     bchr		 char (al) unal based (ap);
	dcl     system_area		 area based (system_areap);
	dcl     mpx_error_printed	 (hbound (mpx_types, 1), 99) bit (1) unal based (mpx_error_printedp);

/* builtin */

	declare (addr, bin, character, collate, dimension, divide, hbound, index, lbound, length, ltrim, max, null,
	        rank, rel, rtrim, size, string, substr, translate, unspec, verify, wordno)
				 builtin;

/* conditions */

	declare cleanup		 condition;
	declare sub_error_		 condition;

/* entries */

	dcl     convert_authorization_$from_string_range
				 entry ((2) bit (72) aligned, character (*), fixed binary (35));
	dcl     convert_status_code_	 entry (fixed bin (35), char (8) aligned, char (100) aligned);
	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     cdt_mgr_$thread	 entry (ptr, fixed bin (35));
	dcl     cv_dec_check_	 entry (char (*), fixed bin (35)) returns (fixed bin);
	dcl     find_condition_info_	 entry (ptr, ptr, fixed bin (35));
	dcl     get_wdir_		 entry () returns (char (168));
	dcl     get_group_id_	 entry () returns (char (32) aligned);
	dcl     get_shortest_path_	 entry (char (*)) returns (char (168));
	dcl     get_system_free_area_	 entry () returns (ptr);
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     expand_pathname_$add_suffix
				 entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     com_err_		 entry options (variable);
	dcl     system_info_$device_prices
				 entry (fixed bin, ptr);
	dcl     lex_error_		 entry options (variable);
	dcl     lex_string_$init_lex_delims
				 entry (char (*), char (*), char (*), char (*), char (*), bit (*), char (*) var,
				 char (*) var, char (*) var, char (*) var);
	dcl     lex_string_$lex	 entry (ptr, fixed bin, fixed bin, ptr, bit (*), char (*), char (*), char (*),
				 char (*), char (*), char (*) var, char (*) var, char (*) var, char (*) var, ptr,
				 ptr, fixed bin (35));
	dcl     translator_temp_$get_segment
				 entry (char (*), ptr, fixed bin (35));
	dcl     translator_temp_$release_all_segments
				 entry (ptr, fixed bin (35));

	dcl     com_err_$suppress_name entry () options (variable);
	dcl     initiate_file_	 entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
	dcl     hcs_$make_seg	 entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
	dcl     hcs_$truncate_seg	 entry (ptr, fixed bin, fixed bin (35));
	dcl     ttt_info_$terminal_data
				 entry (char (*), fixed bin, fixed bin, ptr, fixed bin (35));
	dcl     match_star_name_	 entry (char (*), char (*), fixed bin (35));
	dcl     sort_items_$general	 entry (ptr, entry);
	dcl     hcs_$make_entry	 entry (ptr, char (*), char (*), entry, fixed bin (35));
	dcl     parse_tty_name_	 entry (char (*), fixed bin, bit (1), fixed bin, fixed bin);
	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));
	dcl     suffixed_name_$new_suffix
				 entry (char (*), char (*), char (*), char (32), fixed bin (35));
	dcl     terminate_file_	 entry (ptr, fixed bin (24), bit (*), fixed bin (35));

/* internal static */

	dcl     (
	        (
	        ON		 bit (1) initial ("1"b),
	        OFF		 bit (1) initial ("0"b),
	        my_name		 char (6) initial ("cv_cmf")
	        )			 options (constant),
	        first		 bit (1) initial ("1"b),
	        (LEXDLM, LEXCTL)	 char (128) var,
	        BREAKS		 char (128) var,
	        IGBREAKS		 char (128) var
	        )			 internal static;

	dcl     services		 (8) char (12) static options (constant)
				 init ("login", "FTP", "MC", "slave", "", "autocall", "inactive", "multiplexer");

/* external static */

	dcl     (
	        error_table_$translation_failed,
	        error_table_$noentry,
	        error_table_$too_many_args,
	        error_table_$badopt,
	        error_table_$zero_length_seg,
	        error_table_$noarg,
	        error_table_$bad_conversion
	        )			 fixed bin (35) external static;
	dcl     sys_info$max_seg_size	 ext fixed bin (18);

	dcl     cv_cmf_severity_	 fixed bin (35) external init (0);

/* include files */
/* format: off */
%page; %include cdt;
%page; %include author_dcl;
%page; %include line_types;
%page; %include baud_rates;
%page; %include dataset_names;
%page; %include multiplexer_types;
%page; %include dialup_values;
%page; %include sub_error_info;
%include condition_info_header;
%include condition_info;
	declare 1 auto_condition_info	 aligned like condition_info;
%page; %include terminate_file;
%page; %include access_mode_values;
/* format: on */

/* program */

	cmfp = null;				/* Initialize for cleanup handler */
	cdtp = null;				/* .. */
	areap = null;				/* .. */
	dn, supplied_en = "";
	created_table_segment = ""b;

	on cleanup
	     begin;
		call clean_up;			/* do any tidying up of address space */
		cv_cmf_severity_ = 5;		/* fie on you */
	     end;

	call cu_$arg_count (argc, ec);		/* Note AF calls */
	if ec ^= 0
	then do;
		call com_err_ (ec, my_name);
		go to severity_5_failure;
	     end;

	if argc = 0
	then do;
give_usage:
		call com_err_$suppress_name (0, my_name, "Usage: cv_cmf CMF (-brief|-bf|-long|-lg)");
		go to severity_5_failure;
	     end;

	do argx = 1 to argc;
	     call cu_$arg_ptr (argx, ap, al, (0));
	     if character (bchr, 1) ^= "-"
	     then do;
		     if supplied_en ^= ""
		     then do;
			     call com_err_ (error_table_$too_many_args, my_name,
				"Only one pathname may be given. ^a was the second.", bchr);
			     go to severity_5_failure;
			end;

		     call expand_pathname_ (bchr, dn, supplied_en, ec);
		     if ec ^= 0
		     then do;
path_error:
			     call com_err_ (ec, my_name, "^a", bchr);
			     go to severity_5_failure;
			end;
		     call expand_pathname_$add_suffix (bchr, "cmf", dn, cmf_en, ec);
		     if ec ^= 0
		     then go to path_error;

		     call suffixed_name_$new_suffix (supplied_en, "cmf", "cdt", cdt_en, ec);
						/* if we get this far, how can we fail? */
		     if ec ^= 0			/* still, let's have a look */
		     then go to path_error;

		end;				/* Pathname case */

	     else if bchr = "-bf"
	     then SERROR_CONTROL = "01"b;
	     else if bchr = "-brief"
	     then SERROR_CONTROL = "01"b;
	     else if bchr = "-long" | bchr = "-lg"
	     then SERROR_CONTROL = "10"b;
	     else if bchr = "-severity" | bchr = "-sv"
	     then do;
		     if argx >= argc
		     then do;
			     call com_err_ (error_table_$noarg, my_name, "After ""^a"".", bchr);
			     go to severity_5_failure;
			end;
		     argx = argx + 1;
		     call cu_$arg_ptr (argx, ap, al, ec);
		     fb35 = cv_dec_check_ (bchr, ec);
		     if ec ^= 0 | fb35 < 0 | fb35 > 5
		     then do;
			     call com_err_ (error_table_$bad_conversion, my_name,
				"Severity must be an integer in the range 0 - 5, not ""^a"".", bchr);
			     go to severity_5_failure;
			end;
		     MIN_PRINT_SEVERITY = fb35;
		end;
	     else do;
		     call com_err_ (error_table_$badopt, my_name, "^a", bchr);
		     go to severity_5_failure;
		end;
	end;					/* Arg Loop */

	if supplied_en = ""
	then go to give_usage;
	call system_info_$device_prices (ndev, addr (dvt));

	call initiate_file_ (dn, cmf_en, R_ACCESS, cmfp, bitc, ec);
	if ec = error_table_$noentry
	then if cmf_en ^= supplied_en
	     then do;
		     call initiate_file_ (dn, supplied_en, R_ACCESS, cmfp, bitc, ec);
		     if ec = 0
		     then do;
			     call com_err_ (0, my_name, "Warning: converting ^a. The segment should be named ^a.",
				pathname_ (dn, supplied_en), cmf_en);
			     cmf_en = supplied_en;
			end;
		end;
	if ec ^= 0
	then do;
cmf_error:
		call com_err_ (ec, my_name, "^a.", pathname_ (dn, cmf_en));
		go to severity_5_failure;
	     end;

	n = divide (bitc + 8, 9, 24, 0);
	if n = 0
	then do;
		ec = error_table_$zero_length_seg;
		go to cmf_error;
	     end;

	dn = get_wdir_ ();
	call hcs_$make_seg (dn, cdt_en, "", 1010b, cdtp, ec);
	created_table_segment = (ec = 0);
	if cdtp = null
	then do;
cdt_error:
		call com_err_ (ec, my_name, "^a.", pathname_ (dn, cdt_en));
		go to severity_5_failure;
	     end;

	call hcs_$truncate_seg (cdtp, 0, ec);		/* if we set it all to ""b, it would take all the page faults */
	if ec ^= 0
	then go to cdt_error;

	cdtep = addr (cdt.cdt_entry (1));

	cdt.author.proc_group_id = get_group_id_ ();	/* Initialize the header of the new cdt */
	cdt.author.table = "CDT";
	dn = get_shortest_path_ (dn);
	cdt.author.w_dir = substr (dn, 1, length (cdt.author.w_dir));
	cdt.author.last_install_time = 0;
	cdt.version = CDT_version;
	cdt.max_size = divide (sys_info$max_seg_size - bin (rel (cdtep), 18), size (cdte), 17, 0);
	cdt.acceptable_fnp_tbf = 5;
	cdt.spare_channel_count = 10;

	unspec (dft) = "0"b;			/* Zero the defaults .. the lazy way */
	cdtep = addr (dft);				/* Set up cdtep to point at the dfts. */
	dft.name = "";				/* Initialize defaults */
	dft.comment = "";
	dft.charge_type = 0;
	dft.line_type = LINE_UNKNOWN;
	dft.initial_terminal_type = "";		/* nothing special */
	dft.current_terminal_type = "";
	dft.tty_id_code = "";
	string (dft.user_name) = "";
	dft.baud_rate = 300;
	dft.modem_type = 0;
	string (dft.flags) = "0"b;
	dft.service_type = ANS_SERVICE;		/* dialup line */
	dft.answerback = "";
	dft.initial_command = "";
	call convert_authorization_$from_string_range (dft.access_class, "system_low", code);

	call translator_temp_$get_segment (my_name, areap, code);
	if areap = null
	then do;
		call com_err_ (code, my_name, "While making a temporary segment in the process directory.");
		go to severity_5_failure;
	     end;

	if first
	then do;
		BREAKS = substr (collate (), 1, 8) || substr (collate (), 10, 24) || "()*,:;^";
		IGBREAKS = substr (collate (), 1, 8) || substr (collate (), 10, 24);
		call lex_string_$init_lex_delims ("""", """", "/*", "*/", ";", "10"b, BREAKS, IGBREAKS, LEXDLM,
		     LEXCTL);
		first = "0"b;
	     end;

	call lex_string_$lex (cmfp, n, 0, areap, "100"b, """", """", "/*", "*/", ";", BREAKS, IGBREAKS, LEXDLM, LEXCTL,
	     APstmt, APtoken, ec);

	Pthis_token = APtoken;
	call SEMANTIC_ANALYSIS ();

/* now let individual sub-channels judge on their channels */

	system_areap = get_system_free_area_ ();
	allocate mpx_error_printed in (system_area);
	string (mpx_error_printed) = "0"b;

	do i = 1 to hbound (cdt.fnp_entry, 1);
	     fnpep = addr (cdt.fnp_entry (i));
	     if fnpe.state ^= FNP_FREE
	     then call process_subchans (fnpep, substr (collate (), rank ("a") + i, 1), fnpe.mpx_type);
	end;

	do i = 1 to cdt.current_size;
	     cdtep = addr (cdt.cdt_entry (i));
	     if cdte.service_type = MPX_SERVICE
	     then call process_subchans (cdtep, (cdte.name), (cdte.mpx_type));
	end;

/* thread proc will detect missing parents and the like */

	on sub_error_
	     begin;
		declare almsg		 char (100) aligned;
		call find_condition_info_ (null, addr (auto_condition_info), (0));
		sub_error_info_ptr = auto_condition_info.info_ptr;
		call convert_status_code_ (sub_error_info.status_code, "", almsg);
		if ^sub_error_info.default_restart	/* not warning */
		then do;
			call semant_error (6, (almsg), (sub_error_info.info_string));
			go to abort;
		     end;
		call semant_error (25, (almsg), (sub_error_info.info_string));
						/* Warning */
	     end;

	call cdt_mgr_$thread (cdtp, (0));		/* we look at condition, not code */
	revert sub_error_;

abort:
	if MERROR_SEVERITY > 2
	then do;
		call com_err_ (error_table_$translation_failed, my_name, cmf_en);
		if created_table_segment
		then bitc = -1;
		else bitc = 0;
	     end;
	else bitc = (wordno (addr (cdt.cdt_entry (1))) + size (cdte) * cdt.current_size) * 36;
	if bitc >= 0
	then do;
		call terminate_file_ (cdtp, bitc, TERM_FILE_TRUNC_BC_TERM, ec);
		if ec ^= 0
		then do;
			call com_err_ (ec, my_name, "Unable to set bitcount on ^a to ^d.", pathname_ (dn, cdt_en),
			     bitc);
			go to severity_5_failure;
		     end;
	     end;

	call clean_up;
	cv_cmf_severity_ = MERROR_SEVERITY;
	return;

severity_5_failure:
	call clean_up;
	cv_cmf_severity_ = 5;
	return;


clean_up:
     procedure;

	if cmfp ^= null
	then call terminate_file_ (cmfp, (0), TERM_FILE_TERM, (0));

	if cdtp ^= null
	then if created_table_segment
	     then do;
		     call terminate_file_ (cdtp, (0), TERM_FILE_DELETE, (0));
		     cdtp = null;
		end;
	     else call terminate_file_ (cdtp, (0), TERM_FILE_TRUNC_BC_TERM, (0));

	if areap ^= null
	then call translator_temp_$release_all_segments (areap, (0));

     end clean_up;

/* SYNTAX FUNCTIONS */

access_class:
     procedure () returns (bit (1) aligned);

	call convert_authorization_$from_string_range (access_class_value, token_value, code);
	return (code = 0);

     end access_class;




legal_line_type:
     proc returns (bit (1));

	dcl     temp_line_type	 character (16);	/* because we want to make changes to names, we need auto version */

	temp_line_type = token_value;

	if temp_line_type = "Network"
	then temp_line_type = "TELNET";

	do line_type_value = lbound (line_types, 1) to hbound (line_types, 1)
	     while (temp_line_type ^= line_types (line_type_value));
	end;
	if line_type_value > hbound (line_types, 1)
	then return ("0"b);				/* The 1050, 2741, ETX and ARDS line types are no longer valid. */
	if line_type_value = LINE_1050 | line_type_value = LINE_2741 | line_type_value = LINE_ARDS
	     | line_type_value = LINE_ETX
	then return ("0"b);
	return ("1"b);

     end legal_line_type;




legal_charge:
     proc returns (bit (1) aligned);

	if token_value = "none"
	then do;
		charge_value = 0;
		return ("1"b);
	     end;

	do charge_value = 1 to ndev while (token_value ^= dvt.device_id (charge_value));
	end;
	if charge_value > ndev
	then return ("0"b);
	return ("1"b);

     end legal_charge;

legal_service:
     proc returns (bit (1) aligned);

	dcl     temp_service_type	 character (12);	/* because we want to make changes, we need auto variable */

	temp_service_type = token_value;

	if temp_service_type = "mc"
	then temp_service_type = "MC";
	else if temp_service_type = "ftp"
	then temp_service_type = "FTP";

	do service_value = lbound (services, 1) to hbound (services, 1)
	     while (temp_service_type ^= services (service_value));
	end;
	if service_value > hbound (services, 1)
	then return ("0"b);
	return ("1"b);

     end legal_service;




legal_fnp_type:
     proc returns (bit (1) aligned);

	do fnp_type_value = 1 to hbound (fnp_types, 1) while (token_value ^= fnp_types (fnp_type_value));
	end;
	if fnp_type_value > hbound (fnp_types, 1)
	then do;
		if token_value ^= "HNP"
		then return ("0"b);
		fnp_type_value = 3;
	     end;
	return ("1"b);

     end legal_fnp_type;




legal_baud:
     proc returns (bit (1) aligned);

	baud_rate_value = cv_dec_check_ (token_value, code);
	if code ^= 0
	then return ("0"b);

	if baud_rate_value = 0
	then return ("1"b);
	if baud_rate_value = 133			/* no longer valid */
	then return ("0"b);
	do i = 1 to hbound (baud_table, 1) while (baud_table (i) ^= baud_rate_value);
	end;
	if i > hbound (baud_table, 1)
	then return ("0"b);
	return ("1"b);

     end legal_baud;

legal_fnp_service:
     proc returns (bit (1) aligned);

	if token_value = "active"
	then service_value = ACTIVE;
	else if token_value = "inactive"
	then service_value = INACTIVE;
	else return ("0"b);
	return ("1"b);

     end legal_fnp_service;




legal_dataset:
     proc returns (bit (1) aligned);

	do dataset_value = 1 to hbound (dataset_names, 1) while (token_value ^= dataset_names (dataset_value));
	end;
	if dataset_value > hbound (dataset_names, 1)
	then return ("0"b);
	return ("1"b);

     end legal_dataset;




legal_mpx_type:
     proc returns (bit (1) aligned);

	do mpx_type_value = 1 to hbound (mpx_types, 1) while (token_value ^= mpx_types (mpx_type_value));
	end;
	if mpx_type_value > hbound (mpx_types, 1)
	then return ("0"b);
	else return ("1"b);

     end legal_mpx_type;

/* SEMANTIC FUNCTIONS */

open_chn:
     proc;

	dcl     i			 fixed bin;
	dcl     fnp_no		 fixed bin;
	dcl     (name1, name2)	 char (64) var;
	dcl     (chan1, chan2)	 fixed bin;
	dcl     pic9		 picture "999999";

	if cdt.current_size = cdt.max_size
	then do;
		pic9 = cdt.max_size;
		call semant_error (9, ltrim (pic9, "0"), "");
		go to abort;
	     end;

	channels_open = 0;
	i = index (token_value, "-");			/* check for range of channels */
	if i = 0
	then do;					/* one channel */
		name1 = token_value;
		channels_open = 1;
	     end;
	else do;
		if i = 1 | i = token.Lvalue
		then do;				/* bad range syntax */
bad_pair:
			call ERROR (45);
			name1 = "dummy";
			channels_open = 1;
			go to make_cdt_entry;
		     end;
		name1 = substr (token_value, 1, i - 1);
		name2 = substr (token_value, i + 1);
		if length (name1) ^= length (name2)
		then go to bad_pair;
		if name1 = name2
		then go to bad_pair;
		do i = 1 to length (name1) while (substr (name1, i, 1) = substr (name2, i, 1));
		end;				/* count equal characters */
		channel_digits = length (name1) - i + 1;/* number of digits that will vary */
		if verify (substr (name1, i), "0123456789") ^= 0
		then go to bad_pair;
		if verify (substr (name2, i), "0123456789") ^= 0
		then go to bad_pair;
		chan1 = bin (substr (name1, i));	/* starting channel */
		chan2 = bin (substr (name2, i));	/* ending channel */
		if chan1 >= chan2
		then go to bad_pair;
		channels_open = chan2 - chan1 + 1;	/* number of channels to generate */
	     end;

	call check_chan_name ((name1), fnp_no, code);
	if code ^= 0
	then do;
		name1 = "dummy";
		channels_open = 1;
	     end;

make_cdt_entry:
	cdt.current_size, cdt.n_cdtes = cdt.n_cdtes + 1;
	cdtep = addr (cdt.cdt_entry (cdt.n_cdtes));
	cdte = dft;
	cdte.in_use = NOW_HUNG_UP;
	cdte.name = name1;

     end open_chn;

/* declare these variables in the external procedure, so open_chn and close_chn can share them */

	dcl     channels_open	 fixed bin;
	dcl     channel_digits	 fixed bin;




close_chn:
     proc;

	dcl     p			 ptr;
	dcl     new_name		 char (64) var;
	dcl     i			 fixed bin;
	dcl     pic9		 picture "99999999";
	dcl     fnp_no		 fixed bin;

	if cdt.current_size = 0
	then return;
	if cdte.answerback ^= ""
	then cdte.flags.ck_answerback = "1"b;

	if verify (cdte.comment, substr (collate (), 8, 9) || substr (collate (), 33)) ^= 0
	then call semant_error (18, (cdte.name), "");

	if cdte.flags.execute_initial_command & cdte.flags.generic_destination_present
	then do;
		call semant_error (55, (cdte.name), "");
		cdte.flags.execute_initial_command, cdte.flags.generic_destination_present = "0"b;
	     end;					/* can't allow since these fields overlay */

	if cdte.service_type = MPX_SERVICE
	then do;					/* check for consistency of multiplexer stuff */
		if cdte.mpx_type = 0
		then /* must be specified */
		     call semant_error (48, (cdte.name), "");
		if cdte.flags.execute_initial_command | cdte.flags.generic_destination_present
		then /* cant allow this, as field is redefined */
		     call semant_error (49, (cdte.name), "");
		unspec (cdte.initial_command) = "0"b;	/* reset for mpx use */
		cdte.flags.execute_initial_command, cdte.flags.generic_destination_present = "0"b;
		if cdte.mpx_service = 0
		then cdte.mpx_service = ACTIVE;
	     end;
	else if cdte.mpx_type ^= 0
	then /* cant have multiplexer type for non-mpx chan */
	     call semant_error (50, (cdte.name), "");


	do i = 2 to channels_open;
	     if cdt.current_size = cdt.max_size
	     then do;
		     pic9 = cdt.max_size;
		     call semant_error (9, ltrim (pic9, "0"), "");
		     go to abort;
		end;
	     new_name = rtrim (cdte.name);
	     pic9 = bin (substr (new_name, length (new_name) - channel_digits + 1)) + 1;
	     substr (new_name, length (new_name) - channel_digits + 1) =
		substr (pic9, length (pic9) - channel_digits + 1);
	     call check_chan_name ((new_name), fnp_no, code);

	     cdt.current_size, cdt.n_cdtes = cdt.current_size + 1;
						/* one more channel entry */
	     p = addr (cdt.cdt_entry (cdt.n_cdtes));	/* get ptr to new entry */
	     p -> cdte = cdte;			/* copy previous entry into this one */
	     cdtep = p;				/* move cdtep to latest entry */
	     cdte.name = new_name;			/* put in the new name */

	end;


	return;

     end close_chn;




/* Procedure to check syntax of a channel name */

check_chan_name:
     proc (name, fnp_no, code);

	dcl     name		 char (*);
	dcl     fnp_no		 fixed bin;
	dcl     code		 fixed bin (35);
	dcl     i			 fixed bin;
	dcl     p			 ptr;
	dcl     hsla		 bit (1);
	dcl     la_no		 fixed bin;
	dcl     subchan		 fixed bin;

	fnp_no = 0;
	code = 0;
	if name = "" | length (name) > length (cdte.name)
	then do;
bad_chan_name:
		call semant_error (28, name, "");
		code = 1;				/* error return */
		return;
	     end;
	if (substr (name, 1, 3) = "net" | substr (name, 1, 3) = "ftp") & length (name) = 6
	     & verify (substr (name, 4), "0123456789") = 0
	then ;
	else do;
		if substr (name, 2, 1) = "."
		then do;
			call parse_tty_name_ (name, fnp_no, hsla, la_no, subchan);
			if fnp_no < 0
			then fnp_no = 0;
		     end;
		if index (name, "..") ^= 0
		then go to bad_chan_name;
		if substr (name, length (name), 1) = "."
		then go to bad_chan_name;
		if substr (name, 1, 1) = "."
		then goto bad_chan_name;
	     end;

	do i = 1 to cdt.current_size;
	     p = addr (cdt.cdt_entry (i));
	     if p -> cdte.name = name
	     then call semant_error (13, name, "");
	end;

	return;

     end check_chan_name;

/* let the multiplexer rule on the validity of any of its sub-channels */

process_subchans:
     proc (cdt_entryp, mpx_name, mpx_type);

	dcl     cdt_entryp		 ptr;		/* cdtep or fnpep */
	dcl     mpx_name		 char (*);
	dcl     mpx_type		 fixed bin;

	dcl     (star_name, segname, entryname)
				 char (32);
	dcl     i			 fixed bin;
	dcl     p			 ptr;
	dcl     entvar		 entry (ptr, ptr, char (*), ptr, entry) variable;

	dcl     1 cdt_list		 aligned,
		2 count		 fixed bin,
		2 cdte_ptr	 (cdt.current_size) ptr unal;

	star_name = rtrim (mpx_name) || ".*";
	cdt_list.count = 0;
	do i = 1 to cdt.current_size;
	     p = addr (cdt.cdt_entry (i));
	     call match_star_name_ ((p -> cdte.name), star_name, code);
	     if code = 0
	     then do;
		     cdt_list.count = cdt_list.count + 1;
		     cdt_list.cdte_ptr (cdt_list.count) = p;
		end;
	end;

	if cdt_list.count > 1
	then call sort_items_$general (addr (cdt_list), chan_name_compare);

	segname = "as_" || rtrim (mpx_types (mpx_type)) || "_mpx_";
	entryname = rtrim (mpx_types (mpx_type)) || "_cv_cmf";
	call hcs_$make_entry (null (), segname, entryname, entvar, code);
	if code ^= 0
	then call semant_error (54, rtrim (segname) || "$" || rtrim (entryname), mpx_name);
	else do;
		mpx_type_value = mpx_type;
		call entvar (cdtp, cdt_entryp, mpx_name, addr (cdt_list), mpx_error);
	     end;

     end process_subchans;




chan_name_compare:
     proc (p, q) returns (fixed bin (1));

	dcl     (p, q)		 ptr unal;

	if p -> cdte.name < q -> cdte.name
	then return (-1);
	if p -> cdte.name > q -> cdte.name
	then return (+1);
	return (0);

     end chan_name_compare;

open_fnp:
     proc;

	if length (token_value) > 1
	then call ERROR (23);
	fnpno = index ("ABCDEFGH", token_value);
	if fnpno = 0
	then fnpno = index ("abcdefgh", token_value);
	if fnpno = 0
	then do;
		call ERROR (23);
		fnpno = 1;			/* to avoid blowing up later */
	     end;

	fnpep = addr (cdt.fnp_entry (fnpno));
	if fnpe.state > 0
	then call ERROR (24);

	fnpe.state = FNP_DOWN;			/* configured, not loaded */
	fnpe.service_type = ACTIVE;			/* defaults */
	fnpe.mpx_type = MCS_MPX;
	return;

     end open_fnp;




close_fnp:
     proc;

	return;

     end close_fnp;




check_terminal_type:
     proc;

	terminal_type_value = translate (token_value, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "abcdefghijklmnopqrstuvwxyz");
	if terminal_type_value = "NONE"
	then terminal_type_value = "";

	else do;
		call ttt_info_$terminal_data (terminal_type_value, -1, 0, null, code);
		if code ^= 0
		then call statement_error (46, token_value, "");
						/* warn them about this */
	     end;

     end check_terminal_type;

semant_error:
     proc (error_num, parm1, parm2);

	dcl     error_num		 fixed bin,
	        (parm1, parm2)	 char (*);
	dcl     (stmt_ptr, token_ptr)	 ptr init (null);

	goto call_error;

statement_error:
     entry (error_num, parm1, parm2);

	stmt_ptr = token.Pstmt;			/* print the source statement */
	token_ptr = Pthis_token;

call_error:
	if error_control_table (error_num).severity >= MIN_PRINT_SEVERITY
	then call lex_error_ (error_num, SERROR_PRINTED (error_num), (error_control_table.severity (error_num)),
		MERROR_SEVERITY, stmt_ptr, token_ptr, SERROR_CONTROL, (error_control_table.message (error_num)),
		(error_control_table.brief_message (error_num)), parm1, parm2);
	else do;
		MERROR_SEVERITY = max (MERROR_SEVERITY, error_control_table (error_num).severity);
		SERROR_PRINTED (error_num) = "1"b;
	     end;
	return;

     end;




/* this error routine is the interface to rdc errors for multiplexer parsers */

mpx_error:
     proc (error_num, severity, long_text, short_text, parm1, parm2);

	dcl     error_num		 fixed bin;
	dcl     severity		 fixed bin;
	dcl     (long_text, short_text)
				 char (*);
	dcl     (parm1, parm2)	 char (*);

	dcl     (i, j)		 fixed bin;

	i = error_num;
	if i < 1 | i > 99
	then i = 99;
	j = 100 * mpx_type_value + i;
	if severity >= MIN_PRINT_SEVERITY
	then call lex_error_ (j, mpx_error_printed (mpx_type_value, i), severity, MERROR_SEVERITY, null (), null (),
		SERROR_CONTROL, long_text, short_text, parm1, parm2);
	else do;
		MERROR_SEVERITY = max (MERROR_SEVERITY, severity);
		mpx_error_printed (mpx_type_value, i) = "1"b;
	     end;
	return;

     end mpx_error;

	dcl     1 error_control_table	 (55) aligned int static,
		2 severity	 fixed bin (17) unal init ((5) 3,
						/* 1-5 */
				 1,		/* 6 */
				 (2) 3,		/* 7 - 8 */
				 3,		/* 9 */
				 (7) 3,		/* 10-16 */
				 (2) 1,		/* 17-18 */
				 (6) 3,		/* 19-24 */
				 3,		/* 25 */
				 (20) 3,		/* 26-45 */
				 1,		/* 46 */
				 (7) 3,		/* 47-53 */
				 1,		/* 54 */
				 3),		/* 55 */
		2 Soutput_stmt	 bit (1) unaligned initial ("1"b,
						/* 1 */
				 "0"b,		/* 2 */
				 (2) (1)"1"b,	/* 3-4 */
				 "0"b,		/* 5 */
				 "0"b,		/* 6 */
				 "0"b,		/* 7 */
				 (9) (1)"1"b,	/* 8-16 */
				 (2) (1)"0"b,	/* 17-18 */
				 (6) (1)"1"b,	/* 19-24 */
				 "0"b,		/* 25 */
				 "0"b,		/* 26 */
				 "1"b,		/* 27 */
				 (2) (1)"1"b,	/* 28-29 */
				 (8) (1)"0"b,	/* 30-37 */
				 "1"b,		/* 38 */
				 "0"b,		/* 39 */
				 (2) (1)"1"b,	/* 40-41 */
				 (2) (1)"0"b,	/* 42-43 */
				 (2) (1)"1"b,	/* 44-45 */
				 "0"b,		/* 46 */
				 "1"b,		/* 47 */
				 (3) (1)"0"b,	/* 48-50 */
				 "1"b,		/* 51 */
				 (4) (1)"0"b),	/* 52-55 */
		2 message		 char (100) var init ("",
						/* 1 */
				 "CMF is empty.",	/* 2 */
				 "Unrecognizable statement.",
						/* 3 */
				 "Syntax error.",	/* 4 */
				 "Premature end of CMF encountered. Check for a missing end statement.",
						/* 5 */
				 "^a ^a",		/* MSG is from cdt_mgr_ */
						/* 6 */
				 "Premature end of CMF during attribute statement.",
						/* 7 */
				 "Invalid terminal type ""^a"".",
						/* 8 */
				 "Too many channels declared in CMF. Maximum is ^a.",
						/* 9 */
				 "Invalid access class ""^a"".",
						/* 10 */
				 "Invalid line type ""^a"".",
						/* 11 */
				 "Invalid charge ""^a""",
						/* 12 */
				 "Channel ^a is specified more than once in the CMF.",
						/* 13 */
				 "Invalid attribute ""^a"".",
						/* 14 */
				 "Syntax error. The ""none"" attribute must be followed by a semi-colon.",
						/* 15 */
				 "Invalid service type ""^a"".",
						/* 16 */
				 """^a"" appears to have the wrong line type. ARPANET channels must specify 'line_type: ^a;'",
						/* 17 */
				 "The comment for ""^a"" contains non-printing ASCII characters.",
						/* 18 */
				 "Invalid FNP type ""^a"".",
						/* 19 */
				 "Invalid FNP memory size ""^a"".",
						/* 20 */
				 """^a"" is not a valid lsla/hsla count.",
						/* 21 */
				 "Syntax error. No image specified.",
						/* 22 */
				 "Invalid FNP identifier ""^a"".",
						/* 23 */
				 "FNP ^a is specified more than once.",
						/* 24 */
				 "Fatal error while threading CDT tree. ^a ^a.",
						/* 25 */
				 "Premature of CMF while in check_acs statement.",
						/* 26 */
				 "Unrecognized check acs flag ""^a"".",
						/* 27 */
				 """^a"" is not a valid channel name.",
						/* 28 */
				 """^a"" is not a valid baud rate.",
						/* 29 */
				 "NOT USED",	/* 30 */
				 "NOT USED",	/* 31 */
				 "NOT USED",	/* 32 */
				 "NOT USED",	/* 33 */
				 "NOT USED",	/* 34 */
				 "NOT USED",	/* 35 */
				 "NOT USED",	/* 36 */
				 "NOT USED",	/* 37 */
				 "Invalid dataset type ""^a"".",
						/* 38 */
				 "NOT USED",	/* 39 */
				 "Unrecognized dataset option. ""^a""",
						/* 40 */
				 "Unrecognized line_type option. ""^a""",
						/* 41 */
				 "NOT USED",	/* 42 */
				 "NOT USED",	/* 43 */
				 "Invalid FNP required up time ""^a"".",
						/* 44 */
				 "Invalid channel name pair ""^a"".",
						/* 45 */
				 "Terminal type ""^a"" not found in TTT.",
						/* 46 */
				 "Invalid spare channel count ""^a"".",
						/* 47 */
				 "Multiplexer type not specified for multiplexer ""^a"".",
						/* 48 */
				 "Neither initial command nor generic destination can be specified for multiplexer: ""^a"".",
						/* 49 */
				 "Multiplexer type specified for non-multiplexer channel ""^a"".",
						/* 50 */
				 "Illegal multiplexer type: ""^a"".",
						/* 51 */
				 "Channel ""^a"" configured, but its parent, ""^a"", is not configured as a multiplexer.",
						/* 52 */
				 "Channel ""^a"" configured, but its parent, ""^a"", is not.",
						/* 53 */
				 "Cannot find ""^a"" to check configuration of ""^a"".",
						/* 54 */
				 "Only one of initial command and generic destination may be specified: ""^a""."),
						/* 55 */
		2 brief_message	 char (20) var init ((7) (1)"",
						/* 1-7 */
				 "^a",		/* 8 */
				 "",		/* 9 */
				 (5) (1)"^a",	/* 10-14  */
				 "",		/* 15 */
				 (6) (1)"^a",	/* 16-21 */
				 "",		/* 22 */
				 (3) (1)"^a",	/* 23-25 */
				 (2) (1)"FNP ^a ^a",/* 26-27 */
				 (24) (1)"^a",	/* 28-51 */
				 (2) (1)"^a on ^a", /* 52-53 */
				 "^a for ^a",	/* 54 */
				 "^a");		/* 55 */

/* ======================================================== */




		    cv_rtmf.rd                      03/17/86  1521.0rew 03/17/86  1432.9      286110



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


/* CV_RTMF - Compile a Resource Type Master File into a Resource Type Description Table. */
/* Ripp'd untimely from the womb of cv_pmf on 03/10/78 by C. D. Tavares */
/* Modified 04/12/79 by CDT for precanonicalization of resource names */
/* Modified 8/81 by M.R. Jordan for Time: open; and change error 19 severity */
/* Modified January 1982 BIM for author changes. */
/* Modified July 1982 by E. N. Kittlitz for [severity] and rtmf suffix. */

/*++

BEGIN
 /Device : <name> ;
   /LEX (2) open [auto_rtde.name = token_value] LEX (2)
     / stmt \
 /Volume : <name> ;
   /LEX (2) open [auto_rtde.name = token_value;
   		auto_rtde.is_volume = "1"b] LEX (2)
     / stmt \
 /<any-token>
   /ERROR (19)
     / RETURN \
 /<no-token>
   /ERROR (19)
     / RETURN \

stmt
 /end ;
   /close LEX (2)
     / RETURN \
 /Device : <name> ;
   /LEX (2) close open [auto_rtde.name = token_value] LEX (2)
     / stmt \
 /Volume : <name> ;
   /LEX (2) close open [auto_rtde.name = token_value;
		    auto_rtde.is_volume = "1"b] LEX (2)
     / stmt \
 /Attribute_domain : ;
   / LEX (3) [auto_rtde.n_defined_attributes = 0]
     / stmt \
 /Attribute_domain :
   /LEX (2) [attr_type = Defined] PUSH (stmt)
     / atts \
 /Limit : open ;
   /LEX (4)
     / stmt \
 /Limit : <decimal-integer> ;
   /LEX (2) [auto_rtde.process_limit = token.Nvalue] LEX (2)
     / stmt \
 /Time : <decimal-integer> , <decimal-integer> ;
   /LEX (2) [auto_rtde.default_time = token.Nvalue] LEX (2)
	  [auto_rtde.max_time = token.Nvalue] LEX (2)
     / stmt \
 /Time : <decimal-integer> ;
   /LEX (2) [auto_rtde.default_time = token.Nvalue] LEX (2)
     / stmt \
/Time : open ;
   /LEX (4) [auto_rtde.default_time = FOREVER]
     / stmt \
 /Advance_notice : none ;
   /LEX (4) [auto_rtde.advance_notice_time = -1]
     / stmt \
 /Advance_notice : <decimal-integer> ;
   /LEX (2) [auto_rtde.advance_notice_time = token.Nvalue] LEX (2)
     / stmt \
 /Manual_clear : <yes_no> ;
   /LEX (2) [auto_rtde.manual_clear = (token_value = "yes")] LEX (2)
     / stmt \
 /Implies : <name> ;
   /LEX (2) [auto_rtde.n_mates = 1;
	   auto_rtde.mates (1) = token_value] LEX (2)
     / stmt \
 /Accepts : ;
   /LEX (3) [auto_rtde.n_mates = 0]
     / stmt \
 /Accepts :
   /LEX (2) [matei = 0]
     / mates \
 /Like : <name> ;
   /LEX (2) [auto_rtde.is_synonym = "1"b;
	   auto_rtde.n_mates = 0;
	   auto_rtde.syn_to = token_value;] LEX (2)
     / stmt \
 /Canonicalizer : ;
   /LEX (3)
     / stmt \
 /Canonicalizer : <canon_virtual_entry> ;
   /LEX (2) [auto_rtde.precanon_proc = token_value;] LEX (2)
     / stmt \
 /Canonicalizer : <any-token>
   /LEX (2)  ERROR (4)  NEXT_STMT
     / stmt \
 /charge_type : <name> ;
   /LEX (2) [auto_rtde.registration_defaults.charge_type = find_charge_type ();
	   auto_rtde.registration_defaults.charge_type_given = "1"b] LEX (2)
     / stmt \
 /potential_attributes : ;
   /LEX (3) [auto_rtde.registration_defaults.potential_attributes_given = "1"b]
     / stmt \
 /potential_attributes :
   /LEX (2) [attr_type = Main_potential_defaults] PUSH (stmt)
	  [auto_rtde.registration_defaults.potential_attributes_given = "1"b]
     / atts \
 /attributes : ;
   /LEX (3) [auto_rtde.registration_defaults.attributes_given = "1"b]
     / stmt \
 /attributes :
   /LEX (2) [attr_type = Main_defaults] PUSH (stmt)
	  [auto_rtde.registration_defaults.attributes_given = "1"b]
     / atts \
 /access_range : <authorization_range> ;
   /LEX (2) [auto_rtde.registration_defaults.aim_range (*) = authorization_values (*);
	   auto_rtde.registration_defaults.aim_range_given = "1"b] LEX (2)
     / stmt \
 /access_range : <any-token>
   /LEX (2) ERROR (17) NEXT_STMT
     / stmt \
 /type : <name> ;
   /LEX (2) [subi, auto_rtde.n_subtypes = auto_rtde.n_subtypes + 1;
	   auto_rtde.subtype_name (subi) = token_value;] LEX (2)
     / subtype \
 /<any-token>
   /ERROR (2)  NEXT_STMT
     / stmt \
 /<no-token>
   /ERROR (1)
     / RETURN \

subtype
 /charge_type : <name> ;
   /LEX (2) [auto_rtde.subtype_defaults (subi).charge_type = find_charge_type ();
   	auto_rtde.subtype_defaults (subi).charge_type_given = "1"b] LEX (2)
     / subtype \
 /potential_attributes : ;
   /LEX (3) [auto_rtde.subtype_defaults (subi).potential_attributes_given = "1"b]
     / subtype \
 /potential_attributes :
   /LEX (2) [attr_type = Subtype_potential_defaults] PUSH (subtype)
	[auto_rtde.subtype_defaults (subi).potential_attributes_given = "1"b]
     / atts \
 /attributes : ;
   /LEX (3) [auto_rtde.subtype_defaults (subi).attributes_given = "1"b]
     / subtype \
 /attributes :
   /LEX (2) [attr_type = Subtype_defaults] PUSH (subtype)
	[auto_rtde.subtype_defaults (subi).attributes_given = "1"b]
     / atts \
 /access_range : <authorization_range> ;
   /LEX (2) [auto_rtde.subtype_defaults (subi).aim_range (*) = authorization_values (*);
   	auto_rtde.subtype_defaults (subi).aim_range_given = "1"b] LEX (2)
     / subtype \
 /access_range : <any-token>
   /LEX (2) ERROR (17) NEXT_STMT
     / stmt \
 /<any-token>
   /
     / stmt \
 /<no-token>
   /ERROR (1)
     / RETURN \

atts
 /<any-token> ,
   /add_attribute LEX (2)
     / atts \
 /<any-token> ;
   /add_attribute LEX (2)
     / STACK_POP \
 /<any-token>
   /ERROR (3) NEXT_STMT
     / STACK_POP \
 /<no-token>
   /ERROR (1)
     / RETURN \

mates
 /<name>
   /[matei, auto_rtde.n_mates = matei + 1;
	auto_rtde.mates (matei) = token_value] LEX
     / matepunct \
 /<any-token>
   /ERROR (4)  NEXT_STMT
     / stmt \
 /<no-token>
   /ERROR (1)
     / RETURN \
matepunct
 /,
   /LEX
     / mates \
 /;
   /LEX
     / stmt \
 /<any-token>
   /ERROR (5) NEXT_STMT
     / stmt \
 /<no-token>
   /ERROR (1)
     / RETURN \

   ++*/

/* format: style4 */
cv_rtmf: procedure;

/* automatic */

dcl  (APstmt, APtoken, areap, rtmfp) ptr;

dcl  1 auto_rtde aligned automatic,
       2 fixed_info like rtde.fixed_info aligned,
       2 mates (6) char (32) aligned,
       2 subtypes (32) like rtde.subtypes aligned;

dcl  1 auto_ctt aligned,
       2 n_charge_types fixed bin,
       2 charge_types (100) char (32);

dcl  authorization_values (2) bit (72) aligned,
     access_ceiling bit (72) aligned;

dcl  attr_type fixed bin,
     (matei, subi) fixed bin,
     dn char (168),
     (supplied_en, rtmf_en, rtdt_en) char (32),
     entry_active bit (1) aligned,
     (i, j, k, n) fixed bin,
     time_now fixed bin (71),
     bitc fixed bin (24),
     target_name char (32),
     volume_ind bit (1),
     ap ptr,
     al fixed bin,
     arg based (ap) char (al),
     (ec, code) fixed bin (35);
dcl  created_table_segment bit (1) aligned;
dcl  (SYSTEM_LOW, SYSTEM_HIGH) bit (72) aligned,
     last_block_ptr pointer;

dcl  got_mandatory (100) bit (1) unaligned,
     mytoken char (256),
     temp_ptr pointer,
     loop_ptr pointer,
     found bit (1) aligned;
dcl  argc fixed bin;
dcl  argx fixed bin;
dcl  fb35 fixed bin (35);

dcl  1 auto_token aligned automatic like token;

/* based */

dcl  bchr char (al) unal based (ap);

/* builtin */

declare  (addr, binary, collate, clock, dimension, divide, index, length,
         null, nullo, offset, pointer, rel, reverse, rtrim,
         size, string, substr, unspec, verify) builtin;

/* conditions */

declare  cleanup condition;

/* entries */

dcl  translator_temp_$get_segment entry (char (*) aligned, ptr, fixed bin (35));
dcl  translator_temp_$release_all_segments entry (ptr, fixed bin (35));

dcl  define_area_ ext entry (pointer, fixed bin (35)),
     ioa_$rsnnl ext entry options (variable),
     convert_authorization_$from_string entry (bit (72) aligned, char (*), fixed bin (35)),
     convert_authorization_$from_string_range entry ((2) bit (72) aligned, char (*), fixed bin (35)),
     system_info_$access_ceiling entry (bit (72) aligned),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     cv_entry_ ext entry (char (*), pointer, fixed bin (35)) returns (entry),
     get_wdir_ entry () returns (char (168) aligned),
     get_group_id_ entry () returns (char (32) aligned),
     expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)),
     com_err_ entry options (variable),
     lex_string_$init_lex_delims entry (char (*), char (*), char (*), char (*), char (*), bit (*),
	char (*) var, char (*) var, char (*) var, char (*) var),
     lex_string_$lex entry (ptr, fixed bin, fixed bin, ptr, bit (*), char (*), char (*), char (*), char (*), char (*),
	char (*) var, char (*) var, char (*) var, char (*) var, ptr, ptr, fixed bin (35));

dcl  com_err_$suppress_name entry () options (variable);
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  hcs_$delentry_seg entry (ptr, fixed bin (35));
dcl  hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));
dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));
dcl  hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35));
dcl  expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  pathname_ entry (char (*), char (*)) returns (char (168));
dcl  suffixed_name_$new_suffix entry (char (*), char (*), char (*), char (32), fixed bin (35));
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));

/* internal static */

dcl  (first bit (1) initial ("1"b),
     (Defined initial (0),
     Main_potential_defaults initial (1),
     Main_defaults initial (2),
     Subtype_potential_defaults initial (3),
     Subtype_defaults initial (4)) fixed bin,
     my_name char (8) aligned initial ("cv_rtmf"),
     (LEXDLM, LEXCTL) char (128) var,
     BREAKS char (128) var,
     IGBREAKS char (128) var) internal static;

dcl  FOREVER fixed bin initial (4880) static options (constant);

/* external static */

dcl  (error_table_$translation_failed,
     error_table_$badopt,
     error_table_$too_many_args,
     error_table_$seg_not_found,
     error_table_$no_ext_sym,
     error_table_$noentry,
     error_table_$noarg,
     error_table_$bad_conversion,
     error_table_$zero_length_seg) fixed bin (35) external static;
dcl  sys_info$max_seg_size fixed bin (18) external static;
dcl  cv_rtmf_severity_ fixed bin (35) external static init (0);

/* include files */

%include rtdt;
%include rcp_mandatories;
%include area_info;
%include access_mode_values;
%include terminate_file;
dcl  1 auto_area_info automatic like area_info aligned;

/* program */

	rtmfp = null;				/* Initialize for cleanup handler */
	rtdtp = null;				/* .. */
	areap = null;				/* .. */
	rtdep = null;
	dn, supplied_en, rtmf_en, rtdt_en = "";
	created_table_segment = ""b;

	on cleanup begin;
		call clean_up;
		cv_rtmf_severity_ = 5;
	     end;

	call cu_$arg_count (argc, ec);
	if ec ^= 0 then do;
	     call com_err_ (ec, my_name);
	     go to severity_5_failure;
	end;

	if argc = 0 then do;
give_usage:    call com_err_$suppress_name (ec, my_name, "Usage: cv_rtmf RTMF (-brief|-bf|-long|-lg)");
	     go to severity_5_failure;
	end;

	do argx = 1 to argc;
	     call cu_$arg_ptr (argx, ap, al, ec);
	     if character (bchr, 1) ^= "-"
	     then do;
		if supplied_en ^= ""
		then do;
		     call com_err_ (error_table_$too_many_args, my_name, "Only one pathname may be given. ^a was the second.", bchr);
		     go to severity_5_failure;
		end;

		call expand_pathname_ (bchr, dn, supplied_en, ec);
		if ec ^= 0 then do;
path_error:
		     call com_err_ (ec, my_name, "^a", bchr);
		     go to severity_5_failure;
		end;
		call expand_pathname_$add_suffix (bchr, "rtmf", dn, rtmf_en, ec);
		if ec ^= 0 then go to path_error;

		call suffixed_name_$new_suffix (supplied_en, "rtmf", "rtdt", rtdt_en, ec); /* if we get this far, how can we fail? */
		if ec ^= 0			/* still, let's have a look */
		then go to path_error;

	     end;					/* Pathname case */
	     else if bchr = "-bf" then SERROR_CONTROL = "01"b;
	     else if bchr = "-brief" then SERROR_CONTROL = "01"b;
	     else if bchr = "-long" | bchr = "-lg" then SERROR_CONTROL = "10"b;
	     else if bchr = "-severity" | bchr = "-sv" then do;
		if argx >= argc then do;
		     call com_err_ (error_table_$noarg, my_name, "After ""^a"".", bchr);
		     go to severity_5_failure;
		end;
		argx = argx + 1;
		call cu_$arg_ptr (argx, ap, al, ec);
		fb35 = cv_dec_check_ (bchr, ec);
		if ec ^= 0 | fb35 < 0 | fb35 > 5 then do;
		     call com_err_ (error_table_$bad_conversion, my_name,
			"Severity must be an integer in the range 0 - 5, not ""^a"".", bchr);
		     go to severity_5_failure;
		end;
		MIN_PRINT_SEVERITY = fb35;
	     end;
	     else do;
		call com_err_ (error_table_$badopt, my_name, "^a", bchr);
		go to severity_5_failure;
	     end;
	end;					/* argument loop */

	if supplied_en = "" then go to give_usage;

	call system_info_$access_ceiling (access_ceiling);
	time_now = clock;
	call initiate_file_ (dn, rtmf_en, R_ACCESS, rtmfp, bitc, ec);
	if ec = error_table_$noentry
	then if rtmf_en ^= supplied_en
	     then do;
		call initiate_file_ (dn, supplied_en, R_ACCESS, rtmfp, bitc, ec);
		if ec = 0
		then do;
		     call com_err_ (0, my_name, "Warning: converting ^a. The segment should be named ^a.",
			pathname_ (dn, supplied_en), rtmf_en);
		     rtmf_en = supplied_en;
		end;
	     end;
	if ec ^= 0
	then do;
rtmf_error:
	     call com_err_ (ec, my_name, "^a.", pathname_ (dn, rtmf_en));
	     go to severity_5_failure;
	end;

	n = divide (bitc + 8, 9, 24, 0);
	if n = 0 then do;
	     ec = error_table_$zero_length_seg;
	     go to rtmf_error;
	end;

	dn = get_wdir_ ();
	call hcs_$make_seg (dn, rtdt_en, "", 1010b, rtdtp, ec);
	created_table_segment = (ec = 0);
	if rtdtp = null then do;
rtdt_error:
	     call com_err_ (ec, my_name, "^a", pathname_ (dn, rtdt_en));
	     go to severity_5_failure;
	end;

	call hcs_$truncate_seg (rtdtp, 0, ec);
	if ec ^= 0 then go to rtdt_error;

	rtdt.author.proc_group_id = get_group_id_ ();	/* Initialize the header of the new rtdt */
	rtdt.author.table = "RTDT";
	rtdt.author.w_dir = dn;
	rtdt.author.lock = ""b;
	rtdt.author.last_install_time = 0;

	rtdt.version = RTDT_version_3;
	rtdt.charge_type_table_ptr, rtdt.first_resource = nullo;

	last_block_ptr = null;

	RTDT_area_len = 0;
	RTDT_area_len = sys_info$max_seg_size - size (rtdt); /* "clever" in the worst sense of the word */

	unspec (auto_area_info) = ""b;
	auto_area_info.version = area_info_version_1;
	auto_area_info.no_freeing, auto_area_info.dont_free = "1"b;
	auto_area_info.owner = my_name;
	auto_area_info.size = RTDT_area_len;
	auto_area_info.areap = addr (rtdt.rtdt_area);

	call define_area_ (addr (auto_area_info), ec);
	if ec ^= 0 then goto rtdt_error;

	auto_ctt.n_charge_types = 0;

	call convert_authorization_$from_string (SYSTEM_LOW, "system_low", code);
	if code ^= 0 then goto badacc;
	call convert_authorization_$from_string (SYSTEM_HIGH, "system_high", code);
	if code ^= 0 then do;
badacc:	     call com_err_ (code, "cv_rtmf", "While converting canned access classes.");
	     go to severity_5_failure;
	end;

	call translator_temp_$get_segment (my_name, areap, ec);
	if ec ^= 0 then do;
	     call com_err_ (ec, my_name, "Getting temporary segment.");
	     go to severity_5_failure;
	end;

	if first then do;
	     BREAKS = substr (collate (), 1, 8) || substr (collate (), 10, 24) || "(),.:;";
	     IGBREAKS = substr (collate (), 1, 8) || substr (collate (), 10, 24);
	     call lex_string_$init_lex_delims ("""", """", "/*", "*/", ";", "10"b, BREAKS, IGBREAKS, LEXDLM, LEXCTL);
	     first = "0"b;
	end;

	entry_active = ""b;

	call lex_string_$lex (rtmfp, n, 0, areap, "100"b,
	     """", """", "/*", "*/", ";", BREAKS, IGBREAKS,
	     LEXDLM, LEXCTL, APstmt, APtoken, ec);

	Pthis_token = APtoken;
	call SEMANTIC_ANALYSIS ();

abort:	if MERROR_SEVERITY > 2 then do;
	     call com_err_ (error_table_$translation_failed, my_name, rtmf_en);
	     if created_table_segment then bitc = -1;	/* delete it it we made the branch */
	     bitc = 0;				/* otherwise just zap it */
	end;
	else do;
	     N_CHARGE_TYPES = auto_ctt.n_charge_types;
	     allocate charge_type_table in (rtdt_area);

	     unspec (charge_type_table) = unspec (auto_ctt);
	     rtdt.charge_type_table_ptr = offset (cttp, rtdt.rtdt_area);

/* Now perform a number of "gullibility checks" on each RTDE. */

	     Ptoken = addr (auto_token);		/* hate to diddle with RDC databases, but... */
	     Pthis_token = Ptoken;
	     Pstmt, token.Pstmt = null;
	     token.line_no = 0;
	     token.Pvalue = addr (mytoken);

	     got_mandatory (*) = ""b;

	     do loop_ptr = pointer (rtdt.first_resource, rtdt.rtdt_area)
		repeat (pointer (loop_ptr -> rtde.next_resource, rtdt.rtdt_area))
		while (loop_ptr ^= null);

		rtdep = loop_ptr;
		if rtde.is_synonym then do;
		     mytoken = rtde.name;
		     target_name = rtde.syn_to;
		     volume_ind = rtde.is_volume;
		     found = ""b;

		     do rtdep = pointer (rtdt.first_resource, rtdt.rtdt_area)
			repeat (pointer (rtde.next_resource, rtdt.rtdt_area))
			while (rtdep ^= null & ^found);
			if rtde.name = target_name then do;
			     found = "1"b;
			     if rtde.is_synonym then call ERROR (Syn_chain);
			     if rtde.is_volume ^= volume_ind then
				call ERROR (Device_syn_volume);
			end;
		     end;

		     if ^found then call ERROR (Syn_undefined); /* fell thru loop, lose. */
		end;

		else do;

/* Check to see if this is a mandatory resource name */

		     do i = 1 to dimension (rcp_mandatories.resource_name, 1)
			while (rtde.name ^= rcp_mandatories.resource_name (i));
		     end;

		     if i <= dimension (rcp_mandatories.resource_name, 1) then do;

			got_mandatory (i) = "1"b;

/* Make sure all mandatory attributes for this resource name are defined. */

			do j = 1 to dimension (rcp_mandatories.attributes, 2)
			     while (rcp_mandatories.attributes (i, j) ^= "");

			     do k = 1 to rtde.n_defined_attributes
				while (rtde.attribute_names (k) ^= rcp_mandatories.attributes (i, j));
			     end;

			     if k > rtde.n_defined_attributes then do;
				call ioa_$rsnnl ("""^a"" for ""^a""", mytoken,
				     token.Lvalue, rcp_mandatories.attributes (i, j), rtde.name);
				call ERROR (Mandatory_attr_missing);
			     end;
			end;
		     end;

/* Now make sure the mates for this resource are "consenting". */

		     do i = 1 to rtde.n_mates;

			found = ""b;

			do temp_ptr = pointer (rtdt.first_resource, rtdt.rtdt_area)
			     repeat (pointer (temp_ptr -> rtde.next_resource, rtdt.rtdt_area))
			     while ((temp_ptr ^= null) & ^found);

			     if rtde.mates (i) = temp_ptr -> rtde.name then do;
				do j = 1 to temp_ptr -> rtde.n_mates
				     while (temp_ptr -> rtde.mates (j) ^= rtde.name);
				end;

				if j > temp_ptr -> rtde.n_mates then do;
				     call ioa_$rsnnl ("""^a"" and ""^a""", mytoken,
					token.Lvalue, temp_ptr -> rtde.name, rtde.name);
				     call ERROR (Unrequited_mating);
				end;

				else if rtde.is_volume = temp_ptr -> rtde.is_volume then do;
				     call ioa_$rsnnl ("""^a"" and ""^a""", mytoken,
					token.Lvalue, temp_ptr -> rtde.name, rtde.name);
				     call ERROR (Mates_same_type);
				end;

				else found = "1"b;
			     end;
			end;

			if ^found then do;
			     call ioa_$rsnnl ("""^a"" for ""^a""", mytoken,
				token.Lvalue, rtde.mates (i), rtde.name);
			     call ERROR (No_such_mate);
			end;
		     end;
		end;
	     end;

	     do i = 1 to dimension (rcp_mandatories.resource_name, 1);
		if ^got_mandatory (i) then do;
		     mytoken = rcp_mandatories.resource_name (i);
		     token.Lvalue = length (rtrim (mytoken, " "));
		     call ERROR (Mandatory_resource_missing);
		end;
	     end;

/* Well, it SEEMS kosher enough, close it out. */

	     bitc = (binary (rel (addr (charge_type_table.flagword))) + 1) * 36;
	end;

	if bitc >= 0 then do;
	     call terminate_file_ (rtdtp, bitc, TERM_FILE_TRUNC_BC_TERM, ec);
	     if ec ^= 0 then do;
		call com_err_ (ec, my_name, "Unable to set bitcount on ^a to ^d.", pathname_ (dn, rtdt_en), bitc);
		go to severity_5_failure;
	     end;
	end;

	call clean_up;
	cv_rtmf_severity_ = MERROR_SEVERITY;
	return;

severity_5_failure:
	call clean_up;
	cv_rtmf_severity_ = 5;
	return;
%page;
clean_up:
     procedure;

	if rtmfp ^= null
	then call terminate_file_ (rtmfp, (0), TERM_FILE_TERM, (0));

	if areap ^= null
	then call translator_temp_$release_all_segments (areap, (0));

	if rtdtp ^= null
	then if created_table_segment
	     then do;
		call hcs_$delentry_seg (rtdtp, (0));
		rtdtp = null;
	     end;
	call terminate_file_ (rtdtp, (0), TERM_FILE_TRUNC_BC_TERM, (0));

     end clean_up;

/* SYNTAX FUNCTIONS */

yes_no: proc returns (bit (1) aligned);

	return (token_value = "yes" | token_value = "no");
     end yes_no;


authorization_range:
     procedure () returns (bit (1) aligned);

	call convert_authorization_$from_string_range (authorization_values, token_value, code);
	return (code = 0);

     end authorization_range;


canon_virtual_entry: proc () returns (bit (1) aligned);

dcl  entryvar entry variable;

	entryvar = cv_entry_ (rtrim (token_value), null, code);
	if (code = error_table_$seg_not_found) | (code = error_table_$no_ext_sym) then do; /* not fatal err, but warn him */
	     call ERROR (Canonicalizer_nonexistent);
	     code = 0;
	end;

	return (code = 0);

     end canon_virtual_entry;

/* SEMANTIC FUNCTIONS */

open: proc;

	unspec (auto_rtde) = ""b;
	auto_rtde.name,
	     auto_rtde.precanon_proc,
	     auto_rtde.attribute_names,
	     auto_rtde.mates (*),
	     auto_rtde.subtype_name (*) = "";

	auto_rtde.n_defined_attributes,
	     auto_rtde.process_limit,
	     auto_rtde.n_mates,
	     auto_rtde.advance_notice_time = -1;

	auto_rtde.default_time,
	     auto_rtde.max_time = FOREVER;		/* if that's not enough, hang it up. */

	entry_active = "1"b;
	return;
     end open;


find_charge_type: proc returns (fixed bin);

dcl  i fixed bin;

	do i = 1 to auto_ctt.n_charge_types while (auto_ctt.charge_types (i) ^= token_value);
	end;

	if i > auto_ctt.n_charge_types then do;
	     auto_ctt.n_charge_types = i;
	     auto_ctt.charge_types (i) = token_value;
	end;

	return (i);

     end find_charge_type;

add_attribute: proc;

dcl  implies bit (1) aligned,
     i fixed bin,
     copy_token char (12) aligned;

	if substr (token_value, 1, 1) = "^" then do;
	     call ERROR (Negative_attr);
	     return;
	end;

	if substr (token_value, length (token_value), 1) = "*" then implies = "1"b;
	else implies = ""b;

	if length (token_value) > 12 + (binary (implies)) then call ERROR (Attr_too_long);

	if implies then copy_token = substr (token_value, 1, length (token_value) - 1);
	else copy_token = token_value;

	do i = 1 to auto_rtde.n_defined_attributes while (auto_rtde.attribute_names (i) ^= copy_token);
	end;

	if attr_type ^= Defined then
	     if i > auto_rtde.n_defined_attributes then call ERROR (Undefined_attr);
	     else ;
	else if i <= auto_rtde.n_defined_attributes then do;
	     call ERROR (Multiply_dcl_attr);
	     return;
	end;

	if attr_type = Defined then do;
	     auto_rtde.attribute_names (i) = copy_token;
	     if auto_rtde.is_volume then
		substr (auto_rtde.attributes_to_match, i, 1) = implies;
	     else if implies then call ERROR (Starred_attribute);
	     substr (auto_rtde.attributes_valid, i, 1) = "1"b;
	     auto_rtde.n_defined_attributes = i;
	     return;
	end;

	else if implies then call ERROR (Starred_attribute);

	if attr_type = Main_potential_defaults then
	     substr (auto_rtde.registration_defaults.potential_attributes, i, 1) = "1"b;
	else if attr_type = Main_defaults then
	     substr (auto_rtde.registration_defaults.attributes, i, 1) = "1"b;
	else if attr_type = Subtype_potential_defaults then
	     substr (auto_rtde.subtype_defaults (subi).potential_attributes, i, 1) = "1"b;
	else substr (auto_rtde.subtype_defaults (subi).attributes, i, 1) = "1"b;
	return;

     end add_attribute;

close: proc;

dcl  (j, prefidx) fixed bin;

dcl  save_Lvalue fixed bin (21),
     save_Pvalue pointer,
     fake_token_value char (128);

dcl  1 effective_flags like rtde.registration_defaults.default_flags aligned automatic;
dcl  error_table_$out_of_sequence fixed bin (35) external static,
     sub_err_ ext entry options (variable);


	if ^entry_active then			/* close called before open */
	     call sub_err_ (error_table_$out_of_sequence, "cv_rtmf", "s", null, 0,
		"Attempt to use an undefined RTDE.");
	if auto_rtde.name = "" then call ERROR (No_name);

	save_Lvalue = token.Lvalue;
	save_Pvalue = token.Pvalue;
	token.Pvalue = addr (auto_rtde.name);
	token.Lvalue = length (rtrim (auto_rtde.name, " "));
						/* so error messages make sense */

	if ^auto_rtde.is_synonym then do;		/* don't bother checking syns */
	     if auto_rtde.n_mates = -1 then do;
		call ERROR (No_mates);
		auto_rtde.n_mates = 0;
	     end;
	     if auto_rtde.n_defined_attributes = -1 then call ERROR (No_Domain_stmt);
	     if auto_rtde.n_defined_attributes = 0 then
		auto_rtde.registration_defaults.potential_attributes_given = "1"b;

	     effective_flags = auto_rtde.registration_defaults.default_flags;

	     if auto_rtde.n_subtypes = 0 then call validate_type (auto_rtde.registration_defaults, effective_flags);

	     else do i = 1 to auto_rtde.n_subtypes;

		call ioa_$rsnnl ("""^a"" in ""^a""", fake_token_value, 0,
		     auto_rtde.subtypes (i).subtype_name, auto_rtde.name);
		token.Pvalue = addr (fake_token_value);
		token.Lvalue = length (rtrim (fake_token_value, " "));

		call validate_type (auto_rtde.subtype_defaults (i), effective_flags);
	     end;

/* Now construct the exclusion specs for all attributes of the type "name=". */

	     auto_rtde.n_exclusion_specs = 0;

	     do i = 1 to auto_rtde.n_defined_attributes;

		prefidx = index (auto_rtde.attribute_names (i), "=");

		if prefidx > 0 then do;

		     do j = 1 to auto_rtde.n_exclusion_specs
			while (substr (auto_rtde.exclusion_specs (j), i, 1) = ""b);
		     end;

		     if j > auto_rtde.n_exclusion_specs then do;
			auto_rtde.n_exclusion_specs = auto_rtde.n_exclusion_specs + 1;

			do j = i to auto_rtde.n_defined_attributes;
			     if substr (auto_rtde.attribute_names (i), 1, prefidx)
				= substr (auto_rtde.attribute_names (j), 1, prefidx) then
				substr (auto_rtde.exclusion_specs (auto_rtde.n_exclusion_specs), j, 1) = "1"b;
			end;
		     end;
		end;
	     end;
	end;

	N_MATES = auto_rtde.n_mates;
	N_SUBTYPES = auto_rtde.n_subtypes;

	allocate rtde in (rtdt.rtdt_area);

	unspec (rtde.fixed_info) = unspec (auto_rtde.fixed_info);
	unspec (rtde.mates) = unspec (auto_rtde.mates);
	unspec (rtde.subtypes) = unspec (auto_rtde.subtypes);

	rtde.next_resource = nullo;
	rtde.valid = "1"b;

	if last_block_ptr = null then rtdt.first_resource = offset (rtdep, rtdt.rtdt_area);
	else last_block_ptr -> rtde.next_resource = offset (rtdep, rtdt.rtdt_area);

	last_block_ptr = rtdep;

	token.Pvalue = save_Pvalue;
	token.Lvalue = save_Lvalue;

	rtdep = null;				/* catches bugs */

	return;

validate_type: proc (arg_struc, flag_struc);

dcl  1 arg_struc parameter like rtde.registration_defaults aligned;

dcl  1 flag_struc parameter like rtde.registration_defaults.default_flags aligned;

dcl  1 temp_flags like rtde.registration_defaults.default_flags aligned automatic;

	     temp_flags = effective_flags | arg_struc.default_flags;

	     if ^string (temp_flags) = ""b then return;	/* all are given */

	     if auto_rtde.n_defined_attributes > 0 then do;
		if ^temp_flags.potential_attributes_given then
		     call ERROR (No_potential_attributes);
		if ^temp_flags.attributes_given then
		     call ERROR (No_attributes);
	     end;
	     if ^temp_flags.aim_range_given then do;
		call ERROR (No_aim_range);
		arg_struc.aim_range = SYSTEM_LOW;
	     end;
	     if ^temp_flags.charge_type_given then call ERROR (No_charge_type);

	end validate_type;
     end close;

dcl  (Premature_EOF initial (1),
     Unrecognized initial (2),
     Bad_attribute_syntax initial (3),
     Bad_identifier initial (4),
     Bad_syntax initial (5),
     No_name initial (6),
     No_potential_attributes initial (7),
     No_mates initial (8),
     No_attributes initial (9),
     No_aim_range initial (10),
     Canonicalizer_nonexistent initial (11),
     No_charge_type initial (12),
     Undefined_attr initial (13),
     Multiply_dcl_attr initial (14),
     Negative_attr initial (15),
     Attr_too_long initial (16),
     Bad_access_class initial (17),
     No_Domain_stmt initial (18),
     Bad_first_stmt initial (19),
     Starred_attribute initial (20),
     Mandatory_attr_missing initial (21),
     Mandatory_resource_missing initial (22),
     Unrequited_mating initial (23),
     Mates_same_type initial (24),
     No_such_mate initial (25),
     Syn_undefined initial (26),
     Syn_chain initial (27),
     Device_syn_volume initial (28)) fixed bin static options (constant);

dcl  1 error_control_table (28) aligned internal static options (constant),
       2 severity fixed bin (17) unal init (4, (5) 3, (3) 1, 3, 1, (2) 3, 1, 3, (3) 3, 4, 1, (8) 3),
       2 Soutput_stmt bit (1) unaligned initial
	  ("0"b, (5) (1)"1"b, (4) (1)"0"b, "1"b, "0"b, (5) (1)"1"b, "0"b, (2) (1)"1"b, (8) (1)"0"b),
       2 message char (100) var init
	  ("Premature end of RTMF encountered.",	/* 1 */
	  "Unrecognized keyword or invalid punctuation in recognized statement.", /* 2 */
	  "Improper syntax in attribute string.",	/* 3 */
	  "Improper identifier ""^a"" in statement.",	/* 4 */
	  "Improper syntax in statement.",		/* 5 */
	  "No resource name supplied.",		/* 6 */
	  "No potential attributes supplied for ^a.",	/* 7 */
	  "No Implies or Accepts statement for ^a.",	/* 8 */
	  "No attributes statement supplied for ^a; assuming null list.", /* 9 */
	  "No access range supplied for ^a-- assuming ""system_low : system_low"".", /* 10 */
	  "Specified canonicalization procedure does not seem to exist.", /* 11 */
	  "No charge type supplied for ^a.",		/* 12 */
	  "Default attribute ""^a"" not defined in ""Attributes"" statement.", /* 13 */
	  "Attribute ""^a"" has been multiply declared.", /* 14 */
	  "Negated attributes such as ""^a"" serve no useful purpose.", /* 15 */
	  "Attribute name ""^a"" is too long.",		/* 16 */
	  "Unrecognized access class ""^a"".",		/* 17 */
	  "No Attribute_domain statement for ^a.",	/* 18 */
	  "First statement is not Volume or Device statement.", /* 19 */
	  "Asterisk is only meaningful in volume potential attribute list.", /* 20 */
	  "Mandatory attribute ^a not defined.",	/* 21 */
	  "Mandatory resource ^a not defined.",		/* 22 */
	  "Resources ^a mate in one direction but not in the other.", /* 23 */
	  "Mating resources ^a are both devices or both volumes.", /* 24 */

	  "Undefined mate ^a.",			/* 25 */
	  "Synonym reference for ^a is undefined.",	/* 26 */
	  "Synonym ^a refers to another synonym.",	/* 27 */
	  "Device and volume cannot be synonymous-- ^a"), /* 28 */
       2 brief_message char (30) var init
	  ("Premature EOF.",			/* 1 */
	  "Unrecognizable.",			/* 2 */
	  "Syntax.",				/* 3 */
	  "",					/* 4 */
	  "Syntax.",				/* 5 */
	  "No resource name.",			/* 6 */
	  (12) (1)"^a.",				/* 7-18 */
	  "No Device/Volume stmt.",			/* 19 */
	  "Meaningless asterisk.",			/* 20 */
	  (8) (1)"^a.");				/* 21-28 */

/* ======================================================== */




		    cv_ttf.rd                       10/17/88  1108.5rew 10/17/88  1029.4     1037781



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

/* cv_ttf converts a terminal-type file (TTF) into a terminal-type table (TTT)
   which can then be installed using the install command.  The cv_ttf command
   is generated by the reduction_compiler.

   Usage:	cv_ttf TTF_NAME { -brief | -long }                               */


/* HISTORY COMMENTS:
  1) change(77-05-20,RCoren), approve(), audit(), install():
      Written
      Modified 04/25/78 by Robert S. Coren to add framing_chars
      Modified 05/03/78 by Robert S. Coren & David R. Vinograd to increase
         conversion/translation tables to 256 characters
      Modified May 1979 by Larry Johnson and Bernie Greenberg for extended
         tty-char support.
      Modified June 1979 by Bernie Greenberg for video features.
      Modified February/March 1980 by Larry Johnson to finish video features.
      Modified 5/29/81 by Suzanne Krupp to add function key information.
      Modified: 9 June 1981 by G. Palter to recognize can_type mode and
         replace X/Y with LINE/COLUMN in video sequences
      Modified January 1982 BIM for author changes.
      Modified April 1982 by Robert Coren for changes to baud_rates.incl.pl1.
      Modified July 1982 by E. N. Kittlitz for [severity], ttf suffix.
      Modified September 1984 by Robert Coren to reject var_tab_delays and
         horz_delays > 1.00.
  2) change(86-09-21,Beattie), approve(86-09-21,MCR7542),
     audit(86-10-31,Brunelle), install(86-11-12,MR12.0-1211):
      Remove references to the 963 and 029 preaccess commands and
      remove support for ARDS, 202_ETX, 2741 and 1050 in system
      interfaces.
  3) change(87-03-06,LJAdams), approve(87-04-03,MCR7646),
     audit(87-05-05,Gilcrease), install(87-05-08,MR12.1-1030):
      Added reduction to check the protocol field in the terminal type
      entry table.
  4) change(87-05-21,LJAdams), approve(87-05-21,MCR7699),
     audit(87-07-31,Gilcrease), install(87-08-04,MR12.1-1055):
      Added support for MOWSE_FANSI protocol.
      Changed name of include file from terminal_type_protocols.incl.pl1
      which was to long to term_type_protocols.incl.pl1
  5) change(87-07-02,LJAdams), approve(87-07-13,MCR7742),
     audit(87-07-31,Gilcrease), install(87-08-04,MR12.1-1055):
      Added support for the reductions required by DSA.
  6) change(88-01-25,Brunelle), approve(88-01-25,MCR7813),
     audit(88-10-13,Blair), install(88-10-17,MR12.2-1171):
      1. Correct for repetition factors > 256 in initial_strings or
      additional_info.
      2. Expand special chars to 15 chars from current limit of 3.
      3. Add additional Global statements (including Input_suspend/resume,
      Output_suspend/resume, Buffer_size, Output_end_of_block,
      Output_acknowledge and Line_delimiter).
      4. Remove Additional_info statement.
      5. Correct problem of LIKE terminal_type loop.
                                                   END HISTORY COMMENTS */

%page;
/*++

	\" REDUCTIONS FOR cv_ttf

BEGIN	/ <no-token>			/ ERROR (1)				/ RETURN \

\" Scan for main delimiting statements
mainloop	/ terminal_type : <new_type_name>	/ LEX (2) init_type LEX			/ type_entry \
	/ terminal_type :			/ LEX (2) NEXT_STMT				/ mainloop \

	/ conversion_table : <new_table_name> ;	/ LEX (2) define_ct_table (CONV_TYPE) LEX (2)	/ table_entries \
	/ conversion_table :		/ LEX (2) NEXT_STMT				/ mainloop \

	/ translation_table : <new_table_name> ; / LEX (2) define_ct_table (TRANS_TYPE) LEX (2)	/ table_entries \
	/ translation_table :		/ LEX (2) NEXT_STMT				/ mainloop \

	/ special_table : <new_table_name> ;	/ LEX (2) define_special LEX (2)		/ special_entries \
	/ special_table :			/ LEX (2) NEXT_STMT				/ mainloop \

          / function_key_table : <new_table_name> ;
                                                  / LEX (2) define_fkey_table LEX (2)               / fkey_entries \
          / function_key_table :                  / LEX (2) NEXT_STMT                               / mainloop \

	/ default_types :			/ LEX (2) [default_count = 1]			/ default_types \

	/ answerback :			/ LEX (2) set_up_answerback			/ answerback \

	/ preaccess_command :		/ LEX (2)					/ preaccess \
\" 

	\" global statements

	/ Modes :				/ LEX (2) PUSH (mainloop) PUSH (dft_modes)	/ check_modes \
	/ Bauds :				/ LEX (2) [baudx = 1]			/ default_bauds \
	/ Bps :				/ LEX (2) [baudx = 1]			/ default_bauds \
	/ BPS :				/ LEX (2) [baudx = 1]			/ default_bauds \
	/ Cps :				/ LEX (2) [baudx = 1]			/ default_cps \
	/ CPS :				/ LEX (2) [baudx = 1]			/ default_cps \
	/ Line_types :			/ LEX (2) PUSH (mainloop) PUSH (dft_line_types)	/ line_types \
	/ Erase : <valid_edit> ;		/ LEX (2) [dft.erase = make_char ()] LEX (2)	/ mainloop \
	/ Erase : <any-token>		/ LEX (2) ERROR (3) NEXT_STMT			/ mainloop \
	/ Kill : <valid_edit > ;		/ LEX (2) [dft.kill = make_char ()] LEX (2)	/ mainloop \
	/ Kill : <any-token>		/ LEX (2) ERROR (3) NEXT_STMT			/ mainloop \
	/ Framing_chars : <tty_char> <tty_char> ;
					/ LEX (2) [dft.frame_begin = make_char ()]
					  LEX [dft.frame_end = make_char ()]
					  LEX (2)					/ mainloop \
	/ Framing_chars : <any-token>		/ LEX (2) ERROR (6) NEXT_STMT			/ mainloop \
	/ Line_delimiter : <tty_char> ;	/ LEX (2) [dft.line_delimiter = make_char ()] LEX (2)
					  					 / mainloop \
	/ Line_delimiter : <any-token>	/ LEX (2) ERROR (6) NEXT_STMT			/ mainloop \
	/ Input_suspend : <tty_char> ;	/ LEX (2) [dft.input_suspend = make_char ()] LEX (2)
					  					 / mainloop \
	/ Input_suspend : <any-token>		/ LEX (2) ERROR (6) NEXT_STMT			/ mainloop \
	/ Input_resume : <tty_char> ;		/ LEX (2) [dft.input_resume = make_char ()] LEX (2)
					  					 / mainloop \
	/ Input_resume : <tty_char> , timeout ; / LEX (2) [dft.input_resume = make_char (); dft.input_timeout = "1"b] LEX (4)
					  					/ mainloop \
	/ Input_resume : <any-token>		/ LEX (2) ERROR (6) NEXT_STMT			/ mainloop \
	/ Output_suspend : <tty_char> ;	/ LEX (2) [if dft.output_block_acknowledge then call ERROR (42);
						 else do;
					  	   dft.output_suspend_etb = make_char ();
						   dft.output_block_acknowledge = "0"b;
						   out_sus_set = "1"b;
						 end]
					  LEX (2)					/ mainloop \
	/ Output_suspend : <any-token>		/ LEX (2) ERROR (6) LEX (2)		/ mainloop \
	/ Output_resume : <tty_char> ;	/ LEX (2) [if dft.output_block_acknowledge then call ERROR (42);
						 else do;
						   dft.output_resume_ack = make_char ();
						   dft.output_block_acknowledge = "0"b;
						   out_sus_set = "1"b;
						 end]
					  LEX (2)					/ mainloop \
	/ Output_resume : <any-token>		/ LEX (2) ERROR (6) NEXT_STMT			/ mainloop \
	/ Buffer_size : <decimal-integer> ;	/ LEX (2) [if out_sus_set then call ERROR (42);
						 else do;
					  	   dft.output_buffer_size = token.Nvalue;
						   dft.output_block_acknowledge = "1"b;
						   block_ack_set = "1"b;
						 end]
					  LEX (2)					/ mainloop \
	/ Buffer_size : <any-token>		/ LEX (2) ERROR (6) NEXT_STMT			/ mainloop \
	/ Output_end_of_block : <tty_char> ;	/ LEX (2) [if out_sus_set then call ERROR (42);
						 else do;
					  	   dft.output_suspend_etb = make_char ();
						   dft.output_block_acknowledge = "1"b;
						   block_ack_set = "1"b;
						 end]
					  LEX (2)					/ mainloop \
	/ Output_end_of_block : <any-token>	/ LEX (2) ERROR (6) NEXT_STMT			/ mainloop \
	/ Output_acknowledge : <tty_char> ;	/ LEX (2) [if out_sus_set then call ERROR (42);
						 else do;
					  	   dft.output_resume_ack = make_char ();
						   dft.output_block_acknowledge = "1"b;
						   block_ack_set = "1"b;
						 end]
					  LEX (2)					/ mainloop \
	/ Output_acknowledge : <any-token>	/ LEX (2) ERROR (6) NEXT_STMT			/ mainloop \
	/ Keyboard_addressing :		/ LEX (2) [bitp = addr (dft.keyboard_addressing)] PUSH (mainloop)
					  					/ yes_no \
	/ Print_preaccess_message :		/ LEX (2) [bitp = addr (dft.print_preaccess_message)] PUSH (mainloop)
					  					/ yes_no \
	/ Conditional_printer_off :		/ LEX (2) [bitp = addr (dft.conditional_printer_off)] PUSH (mainloop)
					  					/ yes_no \

	/ Input_conversion : ;		/ LEX (3) [dft.input_conversion_rp = 0]		/ mainloop \
	/ Input_conversion : <legal_name> ;	/ LEX (2) set_table (dft.input_conversion_rp, CONV_TYPE) LEX (2)
					  					/ mainloop \

	/ Output_conversion : ;		/ LEX (3) [dft.output_conversion_rp = 0]	/ mainloop \
	/ Output_conversion : <legal_name> ;	/ LEX (2) set_table (dft.output_conversion_rp, CONV_TYPE) LEX (2)
					  					/ mainloop \

	/ Input_translation : ;		/ LEX (3) [dft.input_translation_rp = 0]	/ mainloop \
	/ Input_translation : <legal_name> ;	/ LEX (2) set_table (dft.input_translation_rp, TRANS_TYPE) LEX (2)
					  					/ mainloop \

	/ Output_translation : ;		/ LEX (3) [dft.output_translation_rp = 0]	/ mainloop \
	/ Output_translation : <legal_name> ;	/ LEX (2) set_table (dft.output_translation_rp, TRANS_TYPE) LEX (2)
					  					/ mainloop \

	/ Special : ;			/ LEX (3) [dft.special_rp = 0]		/ mainloop \
	/ Special : <legal_name> ;	 	/ LEX (2) set_table (dft.special_rp, SPEC_TYPE) LEX (2)
					  					/ mainloop \

          / Function_keys : ;                     / LEX (3) [tte.fkey_rp = 0]			/ mainloop \
          / Function_keys : <legal_name> ;        / LEX (2) set_table (tte.fkey_rp, FKEY_TYPE) LEX (2)
					  					/ mainloop \

	/ Video_info : ;			/ LEX (3) [dft_extended_tablesp -> extended_tables.tables_rp (VIDEO_RP) = 0]
					  					/ mainloop \
	/ Video_info :			/ LEX (2) [extended_tablesp = dft_extended_tablesp]
						define_video
					          [dft_extended_tables_defined = "1"b] PUSH (mainloop)
					  					/ video_table \
          / Dsatm_device : ;                      / LEX (3) [dft_extended_tablesp -> extended_tables.tables_rp (DSATM_DEVICE_RP) = 0]
					  					/ mainloop \
          / Dsatm_device :                        / LEX (2) [extended_tablesp = dft_extended_tablesp]
                                                            define_dsatm_device
                                                            [dft_extended_tables_defined = "1"b] PUSH (mainloop)
					  		
                       / dsatm_device_table \
	/ Old_type : <decimal-integer> ;	/ LEX (2) [dft.old_type = token.Nvalue] LEX (2)	/ mainloop \

	/ end ;				/ LEX (2)					/ finish \
	/ <any-token> :			/ ERROR (5) NEXT_STMT			/ mainloop \
	/ <any-token>			/ ERROR (6) NEXT_STMT			/ mainloop \
	/ <no-token>			/ ERROR (7)				/ RETURN \

	\" terminal type entry statements

type_entry
	/ ;				/ LEX					/ type_statements \
	/ like <defined_type> ;		/ LEX copy_type LEX (2)			/ type_statements \
	/ <any-token>			/ ERROR (6) NEXT_STMT			/ type_statements \

type_statements
	/ modes :				/ LEX (2) PUSH (type_statements) PUSH (entry_modes) / check_modes \
	/ additional_info : 		/ LEX (2) PUSH (type_statements) [p = addr (tte.additional_info)]
										/ char_string \
	/ initial_string :			/ LEX (2) PUSH (type_statements) [p = addr (tte.initial_string)]
										/ char_string \
	/ comment :			/ LEX (2) PUSH (type_statements) [p = addr (tte.comment)]
										/ char_string \
	/ bauds :				/ LEX (2) [baudx = 1]			/ bauds \
	/ bps :				/ LEX (2) [baudx = 1]			/ bauds \
	/ cps :				/ LEX (2) [baudx = 1]			/ cps \

	/ vert_nl_delays :			/ LEX (2) [delayx = 1]			/ delays \
	/ horz_nl_delays :			/ LEX (2) [delayx = 2]			/ delays \
	/ const_tab_delays :		/ LEX (2) [delayx = 3]			/ delays \
	/ var_tab_delays :			/ LEX (2) [delayx = 4]			/ delays \
	/ backspace_delays :		/ LEX (2) [delayx = 5]			/ delays \
	/ vt_ff_delays :			/ LEX (2) [delayx = 6]			/ delays \

	/ line_types :			/ LEX (2) PUSH (type_statements) PUSH (entry_line_types)
										/ line_types \
	/ erase : <valid_edit> ;		/ LEX (2) [tte.erase = make_char ()] LEX (2)	/ type_statements \
	/ erase: <any-token>		/ LEX (2) ERROR (3) NEXT_STMT			/ type_statements \
	/ kill : <valid_edit> ;		/ LEX (2) [tte.kill = make_char ()] LEX (2)	/ type_statements \
	/ kill : <any-token>		/ LEX (2) ERROR (3) NEXT_STMT			/ type_statements \
	/ framing_chars : <tty_char> <tty_char> ;
					/ LEX (2) [tte.frame_begin = make_char ()]
					  LEX [tte.frame_end = make_char ()] LEX (2)
										/ type_statements \
	/ framing_chars : <any-token>		/ LEX (2) ERROR (6) NEXT_STMT			/ type_statements \

	/ line_delimiter : <tty_char> ;	/ LEX (2) [tte.line_delimiter = make_char ()] LEX (2) / type_statements \
	/ line_delimiter : <any-token>	/ LEX (2) ERROR (6) NEXT_STMT			/ type_statements \
	/ input_suspend : <tty_char> ;	/ LEX (2) [tte.input_suspend = make_char ()] LEX (2) / type_statements \
	/ input_suspend : <any-token>		/ LEX (2) ERROR (6) NEXT_STMT			/ type_statements \
	/ input_resume : <tty_char> ;		/ LEX (2) [tte.input_resume = make_char ()] LEX (2) / type_statements \
	/ input_resume : <tty_char> , timeout ; / LEX (2) [tte.input_resume = make_char (); tte.input_timeout = "1"b] LEX (4) / type_statements \
	/ input_resume : <any-token>		/ LEX (2) ERROR (6) NEXT_STMT			/ type_statements \
	/ output_suspend : <tty_char> ;	/ LEX (2) [if block_ack_set then call ERROR (42); else do;
					  tte.output_suspend_etb = make_char (); tte.output_block_acknowledge = "0"b; out_sus_set = "1"b; end]
					  LEX (2)					/ type_statements \
	/ output_suspend : <any-token>		/ LEX (2) ERROR (6) LEX (2)		/ type_statements \
	/ output_resume : <tty_char> ;	/ LEX (2) [if block_ack_set then call ERROR (42); else do;
					  tte.output_resume_ack = make_char (); tte.output_block_acknowledge = "0"b; out_sus_set = "1"b; end]
					  LEX (2)					/ type_statements \
	/ output_resume : <any-token>		/ LEX (2) ERROR (6) NEXT_STMT			/ type_statements \
	/ buffer_size : <decimal-integer> ;	/ LEX (2) [if out_sus_set then call ERROR (42); else do;
					  tte.output_buffer_size = token.Nvalue; tte.output_block_acknowledge = "1"b; block_ack_set = "1"b; end]
					  LEX (2)					/ type_statements \
	/ buffer_size : <any-token>		/ LEX (2) ERROR (6) NEXT_STMT			/ type_statements \
	/ output_end_of_block : <tty_char> ;	/ LEX (2) [if out_sus_set then call ERROR (42); else do;
					  tte.output_suspend_etb = make_char (); tte.output_block_acknowledge = "1"b; block_ack_set = "1"b; end]
					  LEX (2)					/ type_statements \
	/ output_end_of_block : <any-token>	/ LEX (2) ERROR (6) NEXT_STMT			/ type_statements \
	/ output_acknowledge : <tty_char> ;	/ LEX (2) [if out_sus_set then call ERROR (42); else do;
					  tte.output_resume_ack = make_char (); tte.output_block_acknowledge = "1"b; block_ack_set = "1"b; end]
					  LEX (2)					/ type_statements \
	/ output_acknowledge : <any-token>	/ LEX (2) ERROR (6) NEXT_STMT			/ type_statements \
	/ keyboard_addressing :		/ LEX (2) [bitp = addr (tte.keyboard_addressing)] PUSH (type_statements)
										/ yes_no \
	/ print_preaccess_message :		/ LEX (2) [bitp = addr (tte.print_preaccess_message)] PUSH (type_statements)
										/ yes_no \
	/ conditional_printer_off :	 	/ LEX (2) [bitp = addr (tte.conditional_printer_off)] PUSH (type_statements)
										/ yes_no \

	/ input_conversion : ;		/ LEX (3) [tte.input_conversion_rp = 0]		/ type_statements \
	/ input_conversion : <legal_name> ;	/ LEX (2) set_table (tte.input_conversion_rp, CONV_TYPE) LEX (2)
										/ type_statements \

	/ output_conversion : ;		/ LEX (3) [tte.output_conversion_rp = 0]	/ type_statements \
	/ output_conversion : <legal_name> ;	/ LEX (2) set_table (tte.output_conversion_rp, CONV_TYPE) LEX (2)
										/ type_statements \

	/ input_translation : ;		/ LEX (3) [tte.input_translation_rp = 0]	/ type_statements \
	/ input_translation : <legal_name> ;	/ LEX (2) set_table (tte.input_translation_rp, TRANS_TYPE) LEX (2)
										/ type_statements \

	/ output_translation : ;		/ LEX (3) [tte.output_translation_rp = 0]	/ type_statements \
	/ output_translation : <legal_name> ;	/ LEX (2) set_table (tte.output_translation_rp, TRANS_TYPE) LEX (2)
										/ type_statements \

	/ special : ;			/ LEX (3) [tte.special_rp = 0]		/ type_statements \
	/ special : <legal_name> ;	 	/ LEX (2) set_table (tte.special_rp, SPEC_TYPE) LEX (2)
										/ type_statements \


          / function_keys : ;                     / LEX (3) [tte.fkey_rp = 0]                       / type_statements \
          / function_keys : <legal_name> ;        / LEX (2) set_table(tte.fkey_rp, FKEY_TYPE) LEX(2)
                                                                                                    / type_statements \

          / protocol : ;                          / LEX (3) [tte.protocol = 0]
                       / type_statements \
          / protocol :                            / LEX (2) [tte.protocol = get_protocol()] LEX(2)
                       / type_statements \
                     
	/ video_info : ;			/ LEX (3) set_extended [extended_tables.tables_rp (VIDEO_RP) = 0]
										/ type_statements \
	/ video_info :			/ LEX (2) set_extended define_video PUSH (type_statements)
										/ video_table \


	/ dsatm_device : ;			/ LEX (3) set_extended [extended_tables.tables_rp (DSATM_DEVICE_RP) = 0]
										/ type_statements \
	/ dsatm_device :			/ LEX (2) set_extended define_dsatm_device PUSH (type_statements)
										/ dsatm_device_table \

	/ old_type : <decimal-integer> ;	/ LEX (2) [tte.old_type = token.Nvalue] LEX (2)
										/ type_statements \

	/ <any-token>			/ finish_type				/ mainloop \
	/ <no-token>			/ ERROR (7)				/ RETURN \


	\" yes_no subroutine

yes_no	/ yes ;		/ [bitp -> based_bit1 = "1"b]  LEX (2)	/ STACK_POP \
          / YES ;             / [bitp -> based_bit1 = "1"b]  LEX (2)  / STACK_POP \
	/ no ;		/ [bitp -> based_bit1 = "0"b]  LEX (2)	/ STACK_POP \
          / NO ;              / [bitp -> based_bit1 = "0"b]  LEX (2)  / STACK_POP \
	/ <any-token> ;	/ ERROR (4) NEXT_STMT		/ STACK_POP \
	/ <any-token>	/ ERROR (6) NEXT_STMT		/ STACK_POP \
	/ <no-token>	/ ERROR (7)			/ RETURN \


	\" default_bauds subroutine

default_bauds
	/ <valid_baud>	/ [dft_bauds (baudx) = token.Nvalue; baudx = baudx + 1] LEX
							/ default_bauds \
	/		/ PUSH (default_bauds)		/ general_dft_baud \

general_dft_baud
	/ other		/ [dft_bauds (baudx) = 0; baudx = baudx + 1] LEX
							/ STACK_POP \
	/ ;		/ [n_dft_bauds = baudx - 1] LEX POP	/ mainloop \

	/ <any-token>	/ ERROR (8) POP NEXT_STMT		/ mainloop \
	/ <no-token>	/ ERROR (7)			/ RETURN \

default_cps
	/ <valid_cps>	/ [dft_bauds (baudx) = cps_baud_value; baudx = baudx + 1] LEX
							/ default_cps \
	/		/ PUSH (default_cps)		/ general_dft_baud \


	\" bauds subroutine

bauds	/ <valid_baud>	/ make_delay_entry ((token.Nvalue)) [baudx = baudx + 1] LEX
							/ bauds \
	/		/ PUSH (bauds)			/ general_baud \

general_baud
	/ other		/ make_delay_entry (0) LEX		/ STACK_POP \
	/ ;		/ LEX  POP			/ type_statements \
	/ <any-token>	/ ERROR (8) POP  NEXT_STMT		/ type_statements \
	/ <no-token>	/ ERROR (7)			/ RETURN \

cps	/ <valid_cps>	/ make_delay_entry (cps_baud_value) [baudx = baudx + 1] LEX
							/ cps \
	/		/ PUSH (cps)			/ general_baud \


	\" subroutine for initial_string, comment or additional_info

char_string
	/ ;		/ [p -> based_two_words (*) = 0] LEX			/ STACK_POP \
	/ <quoted-string> ;	/ copy_string (p) LEX (2)				/ STACK_POP \
	/		/ [exp_char_index, unexp_char_index = 1; rep_depth, expanded(*), unexpanded(*) = 0; rep_error, rep_used = "0"b;]
								          / string_item \

string_item
	/ <rep_err_found>	/ NEXT_STMT					/ STACK_POP \
	/ <quoted-string>	/ insert_quoted_string LEX				/ string_item \
	/ <tty_char>	/ [ call insert_single_char ((token.Nvalue)) ] LEX	/ string_item \

	/ ( <decimal-integer> ) <_
			/ LEX push_rep LEX (3)				/ string_item \

	/ >_		/ pop_rep LEX					/ string_item \
	/ ;		/ store_string (p) LEX				/ STACK_POP \
	/ <any-token>	/ ERROR (6) NEXT_STMT				/ STACK_POP \
	/ <no-token>	/ ERROR (7)					/ RETURN \

	\" subroutine for delay statements

delays	/		/ [n_spec = 0; delay_error_printed = "0"b] / delay_token \

delay_token
	/ <delay_value>	/ set_delay  LEX			/ delay_token \
	/ ;		/ LEX				/ type_statements \
	/ <any-token>	/ ERROR (9) NEXT_STMT		/ type_statements \
	/ <no-token>	/ ERROR (7)			/ RETURN \


	\" line_types subroutine

line_types
	/ ;		/ LEX				/ STACK_POP \
	/		/ [line_type_str = ""b]		/ line_type_values \

line_type_values
	/ <valid_line_type>	/ [substr (line_type_str, token.Nvalue, 1) = "1"b] LEX
							/ next_line_type \
	/ <any-token>	/ ERROR (10) NEXT_STMT		/ STACK_POP \
	/ <no-token>	/ ERROR (7)			/ RETURN \

next_line_type
	/ ,		/ LEX				/ line_type_values \
	/ ;		/ LEX				/ STACK_POP \

entry_line_types
	/		/ [tte.line_types = line_type_str]	/ STACK_POP \

dft_line_types
	/		/ [dft.line_types = line_type_str]	/ STACK_POP \

	\" subroutine to construct conversion/translation tables

table_entries
	/ <no_table>	/ NEXT_STMT			/ mainloop \
	/		/ [entryx = 0]			/ table_entry \

table_entry
	/ <tty_char>	/ [if entryx > hbound (tablep -> cv_trans.value, 1) then call semant_error (11, cur_table_name, "");
			  else temp_table (entryx) = token.Nvalue; entryx = entryx + 1]  LEX
							/ table_entry \

	/ ;		/ [if entryx < 128 then call semant_error (12, cur_table_name, "")] LEX
							/ mainloop \

	/ <any-token>	/ semant_error (13, cur_table_name, token_value) NEXT_STMT / mainloop \
	/ <no-token>	/ ERROR (7)			/ RETURN \

	\" subroutine for constructing special_chars table

special_entries
	/ new_line :	/ LEX (2) [p = addr (temp_special_table.nl_seq)] PUSH (single_sequence) / sequence \
	/ carriage_return :	/ LEX (2) [p = addr (temp_special_table.cr_seq)] PUSH (single_sequence) / sequence \
	/ backspace :	/ LEX (2) [p = addr (temp_special_table.bs_seq)] PUSH (single_sequence) / sequence \
	/ tab :		/ LEX (2) [p = addr (temp_special_table.tab_seq)] PUSH (single_sequence) / sequence \
	/ vertical_tab :	/ LEX (2) [p = addr (temp_special_table.vt_seq)] PUSH (single_sequence) / sequence \
	/ form_feed :	/ LEX (2) [p = addr (temp_special_table.ff_seq)] PUSH (single_sequence) / sequence \
	/ printer_on :	/ LEX (2) [p = addr (temp_special_table.printer_on)] PUSH (single_sequence) / sequence \
	/ printer_off :	/ LEX (2) [p = addr (temp_special_table.printer_off)] PUSH (single_sequence) / sequence \
	/ red_shift :	/ LEX (2) [p = addr (temp_special_table.red_ribbon_shift)] PUSH (single_sequence) / sequence \
	/ black_shift :	/ LEX (2) [p = addr (temp_special_table.black_ribbon_shift)] PUSH (single_sequence) / sequence \
	/ end_of_page :	/ LEX (2) [p = addr (temp_special_table.end_of_page)] PUSH (single_sequence) / sequence \

	/ output_escapes :	/ LEX (2) [esc_p = addr (not_edited); not_edited (*) = 0]		/ output_escapes \
	/ edited_output_escapes :
			/ LEX (2) [esc_p = addr (edited); edited (*) = 0]			/ output_escapes \
	/ input_escapes :	/ LEX (2) [count = 0]					/ input_escapes \

	/ <any-token>	/ check_special						/ mainloop \
	/ <no-token>	/ ERROR (7)						/ RETURN \

output_escapes
	/		/ [max_output_escapes = 0]					/  \
output_indicator
	/ <indicator_value>	/ PUSH (escape_sequences) [p = addr (esc_p -> escapes (token.Nvalue - 16));
			max_output_escapes = max (max_output_escapes, token.Nvalue - 16)] LEX
										/ sequence \

	/ <any-token>	/ ERROR (14) NEXT_STMT					/ special_entries \
	/ <no-token>	/ ERROR (7)						/ RETURN \

sequence	/ <no_table>	/ NEXT_STMT [STACK_DEPTH = 0]					/ special_entries \
	/		/ [count = 0]						/ sequence_values \

sequence_values
	/ <tty_char>	/ [count = count + 1; if count > hbound (c_chars.chars, 1) then call ERROR (15);
			else addr (p -> c_chars.chars (count)) -> based_fb8 = token.Nvalue] LEX
										/ sequence_values \
	/ <any-token>	/							/ STACK_POP \
	/ <no-token>	/ ERROR (7)						/ RETURN \

escape_sequences
	/ ,		/ [p -> c_chars.count = count] LEX				/ output_indicator \
single_sequence
	/ ;		/ [p -> c_chars.count = count] LEX				/ special_entries \
	/ <any-token>	/ ERROR (16) NEXT_STMT					/ special_entries \
	/ <no-token>	/ ERROR (7)						/ RETURN \

input_escapes
	/ <no_table>	/ NEXT_STMT						/ special_entries \

	/ <tty_char>	/ [count = count + 1; addr (input_escapes.str) -> fb8_array (count) = token.Nvalue] LEX
										/ input_result \

input_esc_error
	/ <any-token>	/ ERROR (6) NEXT_STMT					/ special_entries \
	/ <no-token>	/ ERROR (7)						/ RETURN \

input_result
	/ <tty_char>	/ [addr (input_results.str) -> fb8_array (count) = token.Nvalue] LEX	/ next_esc \
	/		/							/ input_esc_error \

next_esc
	/ ,		/ LEX							/ input_escapes \
	/ ;		/ LEX [input_escapes.len = count]				/ special_entries \
	/		/							/ input_esc_error \

          \" function_key_data table

fkey_entries
fkey_loop
          / home :            / LEX (2) start_fkey_seq(addr(function_key_data.home(0)))   / fkey_entry \
          / left :            / LEX (2) start_fkey_seq(addr(function_key_data.left(0)))   / fkey_entry \
          / right :           / LEX (2) start_fkey_seq(addr(function_key_data.right(0)))  / fkey_entry \
          / up :              / LEX (2) start_fkey_seq(addr(function_key_data.up(0)))     / fkey_entry \
          / down :            / LEX (2) start_fkey_seq(addr(function_key_data.down(0)))   / fkey_entry \
          / key ( <decimal-integer> ) :
                              / LEX (2) [token.Nvalue = bin(token_value, 35, 0)]
                                init_fkey_area((token.Nvalue))
                                start_fkey_seq(addr(function_key_data.function_keys(token.Nvalue, 0))) LEX (3)
                                                                                          / fkey_entry \
          / <any-token>       / finish_fkey_table                                         / mainloop \
          / <no-token>        / ERROR (7)                                                 / RETURN \

fkey_entry
          / <fkey_entry_err>  / statement_error(52, cur_table_name, "") NEXT_STMT         / fkey_entries \

fkey_seq
          / <quoted-string>   / insert_quoted_string LEX                                  / fkey_seq \
          / <tty_char>        / insert_single_char((token.Nvalue)) LEX                    / fkey_seq \
          / ,                 / end_fkey_seq LEX                                          / fkey_entry \
          / ;                 / end_fkey_seq LEX                                          / fkey_entries \
          / <any-token>       / ERROR (50) NEXT_STMT                                      / fkey_entries \
          / <no-token>        / ERROR (7)                                                 / RETURN \

	\" default_types table

default_types
	/ <valid_baud>	/ [temp_dftte (default_count).baud = token.Nvalue] LEX	/ dftt_line_type \
	/ any		/ [temp_dftte (default_count).baud = 0]  LEX		/ dftt_line_type \
	/ <any-token>	/ ERROR (8) LEX					/ dftt_line_type \
	/ <no-token>	/ ERROR (7)					/ RETURN \

dftt_line_type
	/ <valid_dft_line_type>
			/ [temp_dftte (default_count).line_type = token.Nvalue] LEX	/ dft_term_type \
	/ any		/ [temp_dftte (default_count).line_type = 0]  LEX		/ dft_term_type \
	/ <any-token>	/ ERROR (10) LEX					/ dft_term_type \
	/ <no-token>	/ ERROR (7)					/ RETURN \

dft_term_type
	/ <defined_type>	/ [temp_dftte (default_count).term_type_index = token.Nvalue] LEX
									/ next_default \
	/ <legal_name>	/ [temp_dftte (default_count).type_name = token_value] LEX	/ next_default \
	/ <any-token>	/ LEX						/ next_default \

next_default
	/ ,		/ [default_count = default_count + 1] LEX		/ default_types \
	/ ;		/ LEX [temp_dftt.dft_count = default_count] check_for_any	/ mainloop \
	/ <any-token>	/ ERROR (6) NEXT_STMT				/ mainloop \
	/ <no-token>	/ ERROR (7)					/ RETURN \

	\" answerback table

answerback
	/ match		/ [answerback_entry.def_string.chars (ansbck_char_index) = "m"] LEX	/ match_string \
	/ search		/ [answerback_entry.def_string.chars (ansbck_char_index) = "s"] LEX	/ match_string \
	/ skip <decimal-integer>
			/ LEX [answerback_entry.def_string.chars (ansbck_char_index) = "k";
			addr (answerback_entry.def_string.chars (ansbck_char_index+1)) -> based_fb8 = token.Nvalue;
			ansbck_char_index = ansbck_char_index + 2] LEX			/ next_spec \

	/ id <decimal-integer>
			/ LEX [answerback_entry.def_string.chars (ansbck_char_index) = "i";
			addr (answerback_entry.def_string.chars (ansbck_char_index+1)) -> based_fb8 = token.Nvalue;
			ansbck_char_index = ansbck_char_index + 2] LEX			/ next_spec \

	/ id rest		/ [answerback_entry.def_string.chars (ansbck_char_index) = "i";
			answerback_entry.def_string.chars (ansbck_char_index+1) = NUL_CHAR;
			ansbck_char_index = ansbck_char_index + 2] LEX (2)		/ next_spec \

ansbck_error
	/ <any-token>	/ ERROR (17) NEXT_STMT					/ ans_back_type \
	/ <no-token>	/ ERROR (7)						/ RETURN \

match_string
	/ <quoted-string>	/ [addr (answerback_entry.def_string.chars (ansbck_char_index+1)) -> based_fb8 = token.Lvalue;
			substr (answerback_entry.def_string.chars (1), ansbck_char_index+2, token.Lvalue)
			= token_value; ansbck_char_index = ansbck_char_index + token.Lvalue + 2] LEX
										/ next_spec \

	/ digit		/ [addr (answerback_entry.def_string.chars (ansbck_char_index+1)) -> based_fb8 = -2;
			ansbck_char_index = ansbck_char_index + 2] LEX			 / next_spec \

	/ letter		/ [addr (answerback_entry.def_string.chars (ansbck_char_index+1)) -> based_fb8 = -1;
				ansbck_char_index = ansbck_char_index + 2] LEX		/ next_spec \


	/ <any-token>	/ ERROR (17) LEX						/ next_spec \
	/ <no-token>	/ ERROR (7)						/ RETURN \

next_spec
	/ ,		/ LEX							/ answerback \
	/ ;		/ LEX [answerback_entry.def_string.length = ansbck_char_index - 1]	/ ans_back_type \
	/		/							/ ansbck_error \

ans_back_type
	/ type : ;	/ LEX (3)							/ mainloop \
	/ type : <defined_type> ;
			/ LEX (2) [answerback_entry.term_type_index = token.Nvalue] LEX (2)	/ mainloop \
	/ type :		/ LEX (2) ERROR (18) NEXT_STMT				/ mainloop \
	/ <any-token>	/							/ mainloop \
	/ <no-token>	/ ERROR (7)						/ RETURN \

	\"Video stuff 6/3/79 - BSG

video_table

video_loop
	/ clear_screen :	/ LEX (2) start_vseq (CLEAR_SCREEN)				/ vseq \
	/ clear_to_eos :	/ LEX (2) start_vseq (CLEAR_TO_EOS)				/ vseq \
	/ home :		/ LEX (2) start_vseq (HOME)				/ vseq \
	/ clear_to_eol :	/ LEX (2) start_vseq (CLEAR_TO_EOL)				/ vseq \
	/ cursor_up :	/ LEX (2) start_vseq (CURSOR_UP)				/ vseq \
	/ cursor_right :	/ LEX (2) start_vseq (CURSOR_RIGHT)				/ vseq \
	/ cursor_down :	/ LEX (2) start_vseq (CURSOR_DOWN)				/ vseq \
	/ cursor_left :	/ LEX (2) start_vseq (CURSOR_LEFT)				/ vseq \
	/ insert_chars :	/ LEX (2) start_vseq (INSERT_CHARS)				/ vseq \
	/ end_insert_chars : / LEX (2) start_vseq (END_INSERT_CHARS)			/ vseq \
	/ delete_chars :	/ LEX (2) start_vseq (DELETE_CHARS)				/ vseq \
	/ insert_lines :	/ LEX (2) start_vseq (INSERT_LINES)				/ vseq \
	/ delete_lines :	/ LEX (2) start_vseq (DELETE_LINES)				/ vseq \
	/ abs_pos :	/ LEX (2) start_vseq (ABS_POS)				/ vseq \
	/ screen_height : <decimal-integer> ;	/ LEX (2) [tty_video_table.screen_height = token.Nvalue] LEX (2)
										/ video_loop \
	/ screen_line_length : <decimal-integer> ; / LEX (2) [tty_video_table.screen_line_length = token.Nvalue] LEX (2)
										/ video_loop \
	/ scroll_count : <decimal-integer> ; / LEX (2) [tty_video_table.scroll_count = token.Nvalue] LEX (2)
										/ video_loop \
	/ <any-token>		/ finish_video_table				/ STACK_POP \
	/ <no-token>		/ ERROR (7) 					/ RETURN \
vseq
vseq_loop
	/ <quoted-string>	/ insert_quoted_string LEX					/ vseq_loop \
	/ ;		/ LEX end_vseq						/ video_loop \

	/ (		/ LEX							/ vseq_numeric_expr \
	/ <tty_char>	/ insert_single_char ((token.Nvalue)) LEX			/ vseq_loop \
	/ , pad <decimal-integer> ms  / LEX (2) video_encode_pad (1000 * token.Nvalue) LEX (2)	/ vseq_loop \
	/ , pad <decimal-integer> us  / LEX (2) video_encode_pad ((token.Nvalue)) LEX (2)	/ vseq_loop \
	/ , pad <decimal-integer>	/ LEX (2) [tty_video_seq.flags.cpad_present, tty_video_seq.flags.cpad_in_chars = "1"b]
				  [tty_video_seq.cpad = token.Nvalue] LEX		/ vseq_loop \
	/ <any-token>		/ ERROR (48) NEXT_STMT				/ video_loop \
	/ <no-token>		/ ERROR (7)					/ RETURN \


vseq_numeric_expr
	/		/ [unspec (temp_numeric_encoding) = "0"b]
			  [temp_numeric_encoding.must_be_on = "1"b]			/ \
	\" Open paren pre-parsed out
	/ binary		/ LEX							/ vseq_numencode_1 \
	/ decimal <decimal-integer> / [temp_numeric_encoding.flags.express_in_decimal = "1"b]
				LEX [temp_numeric_encoding.num_digits = token.Nvalue] LEX 	/ vseq_numencode_1 \
	/ decimal			/ LEX [temp_numeric_encoding.num_digits = 0]
				  [temp_numeric_encoding.express_in_decimal = "1"b]	/ vseq_numencode_1 \
	/ octal  <decimal-integer> / [temp_numeric_encoding.flags.express_in_octal = "1"b]
				LEX [temp_numeric_encoding.num_digits = token.Nvalue] LEX 	/ vseq_numencode_1 \
	/ octal			/ LEX [temp_numeric_encoding.num_digits = 0]
				  [temp_numeric_encoding.express_in_octal = "1"b]		/ vseq_numencode_1 \

vseq_numencode_1
	/ line		/ [temp_numeric_encoding.l_c_or_n = 0] LEX 			/ vseq_numencode_2 \
	/ LINE		/ [temp_numeric_encoding.l_c_or_n = 0] LEX 			/ vseq_numencode_2 \
	/ column		/ [temp_numeric_encoding.l_c_or_n = 1] LEX 			/ vseq_numencode_2 \
	/ COLUMN		/ [temp_numeric_encoding.l_c_or_n = 1] LEX 			/ vseq_numencode_2 \
	/ n		/ [temp_numeric_encoding.l_c_or_n = 2] LEX 			/ vseq_numencode_2 \
	/ N		/ [temp_numeric_encoding.l_c_or_n = 2] LEX 			/ vseq_numencode_2 \
	/ <any-token>	/ ERROR (46) NEXT_STMT POP					/ video_loop \
	/ <no-token>	/ ERROR (7)						/ RETURN \
vseq_numencode_2
	/ + <tty_char>	/ LEX [temp_numeric_encoding.offset  = token.Nvalue] LEX		/ vseq_numencode_3 \
	/ - <tty_char>	/ LEX [temp_numeric_encoding.offset = - token.Nvalue] LEX		/ vseq_numencode_3 \

vseq_numencode_3
	/ )		/ LEX [if temp_numeric_encoding.offset = 0 then temp_numeric_encoding.offset_is_0 = "1"b]
										/ \
	/		/ insert_single_char (bin (substr (unspec (temp_numeric_encoding), 1, 9)))
	  [if ^temp_numeric_encoding.offset_is_0 then call insert_single_char (bin (substr (unspec (temp_numeric_encoding), 10, 9)))]
	  [if temp_numeric_encoding.l_c_or_n = 2 then tty_video_seq.flags.able_to_repeat = "1"b]
			  [tty_video_seq.flags.interpret = "1"b]			/ vseq_loop \
	/ <any-token>	/ ERROR (46) NEXT_STMT POP					/ video_loop \
	/ <no-token>	/ ERROR (7)						/ RETURN \


	\"DSA TM stuff 12/21/84 Roger Negaret
          \" description of the negotiation information for a logical device

dsatm_device_table
dsatmdev_loop

          / data_presentation : ;                 / LEX (3) / dsatmdev_loop \
          / data_presentation :                   / LEX (2) / dpp \

          / sdp_class : ;                         / LEX (3) /dsatmdev_loop \
          / sdp_class :			/ LEX (2) / sdp_class \

          / real_class : ;			/ LEX (3) / dsatmdev_loop \
          / real_class :			/ LEX (2) / real_class \

          / device_id : ;			/ LEX (3) / dsatmdev_loop \
          / device_id : <decimal-integer> ;       / LEX (2) [dsatm_device.dev_id = token.Nvalue] LEX (2)                                 / dsatmdev_loop \

          / device_type : ;			/ LEX (3) / dsatmdev_loop \
          / device_type : <legal_dev_type> ;	/ LEX (2) [dsatm_device.dev_type = name_idx] LEX (2)                                   / dsatmdev_loop \

          / shareability : ;			/ LEX (3) / dsatmdev_loop \
          / shareability : <legal_shareability> ; / LEX (2) [dsatm_device.shareability = name_idx] LEX (2)                               / dsatmdev_loop \

          / allocation_unit : ;	          / LEX (3) / dsatmdev_loop \
          / allocation_unit : <legal_alloc_unit>  / LEX (2) set_alloc_unit LEX                                                           / alloc_unit \

          / line_overflow : ;			/ LEX (3) / dsatmdev_loop \
          / line_overflow : <legal_line_overflow> ; / LEX (2) [dsatm_device.line_overflow = name_idx] LEX (2)                            / dsatmdev_loop \

          / page_overflow : ;			/ LEX (3) / dsatmdev_loop \
          / page_overflow : <legal_page_overflow> ; / LEX (2) [dsatm_device.page_overflow = name_idx] LEX (2)                            / dsatmdev_loop \

          / character_encoding : ;		/ LEX (3) / dsatmdev_loop \
          / character_encoding :		/ LEX (2) / char_encoding \

          / character_set : ;			/ LEX (3) / dsatmdev_loop \
          / character_set :			/ LEX (2) / char_set \

          / character_subset : ;		/ LEX (3) / dsatmdev_loop \
          / character_subset :		/ LEX (2) / char_subset \

          / national_language : ;		/ LEX (3) / dsatmdev_loop \
          / national_language:		/ LEX (2) / nat_lang \

          / compression_algorithm : ;		/ LEX (3) / dsatmdev_loop \
          / compression_algorithm :		/ LEX (2) / compression \

          / character_font : ;		/ LEX (3) / dsatmdev_loop \
          / character_font :			/ LEX (2) / char_font \

          / max_record_size : ;		/ LEX (3) / dsatmdev_loop \
          / max_record_size : <decimal-integer> ; / LEX (2) [dsatm_device.max_rec_size = token.Nvalue] LEX (2)                           / dsatmdev_loop \

          / attd : ;                              / LEX (3) / dsatmdev_loop \
          / attd : <legal_attd> ;  / LEX (4)                / dsatmdev_loop \

          / att1 : ;                         / LEX (3)      / dsatmdev_loop \
          / att1 : <legal_att1> ;  / LEX (4)                / dsatmdev_loop \

          / stc_available :                 / LEX (2) [bitp = addr (dsatm_device.stc_available)] PUSH (dsatmdev_loop)                   / yes_no \

          / <any-token>		          / finish_dsatm_device                                                                 / STACK_POP \

          / <no-token>		          / ERROR (7) 			                                              / RETURN \

dpp

          / ;               			/ [dsatm_device.dpp_nb = dppx] LEX 									       / dsatmdev_loop \
          / <legal_dpp>                           / set_dpp LEX                  		/ dpp \
	/ <any-token>			/ ERROR (55) NEXT_STMT			/ dsatmdev_loop \
          / <no-token>		 	/ ERROR (7) 				/ RETURN \

sdp_class

          / ; 				/ [dsatm_device.sc_nb = scx] LEX 									       / dsatmdev_loop \
          / <legal_sdp_class> 		/ set_sdp_class  LEX			/ sdp_class \
	/ <any-token>			/ ERROR (55) NEXT_STMT			/ dsatmdev_loop \
          / <no-token>			/ ERROR (7) 				/ RETURN \

real_class

          / ; 				/ [dsatm_device.rc_nb = rcx] LEX 									       / dsatmdev_loop \
          / <legal_real_class> 		/ set_real_class  LEX			/ real_class \
	/ <any-token>			/ ERROR (55) NEXT_STMT			/ dsatmdev_loop \
          / <no-token>			/ ERROR (7) 				/ RETURN \

alloc_unit

          / ; 				/  LEX                                            / dsatmdev_loop \
          / <legal_alloc_unit> 		/ set_alloc_unit  LEX			/ alloc_unit \
	/ <any-token>			/ ERROR (55) NEXT_STMT			/ dsatmdev_loop \
          / <no-token>			/ ERROR (7) 				/ RETURN \

char_encoding
          
          / ;                                     / [dsatm_device.ce_nb = cex] LEX                  / dsatmdev_loop \
          / <legal_char_encoding> 		/ set_char_encoding LEX			/ char_encoding \
	/ <any-token>			/ ERROR (55) NEXT_STMT			/ dsatmdev_loop \
          / <no-token>			/ ERROR (7) 				/ RETURN \

char_set

          / ; 				/ [dsatm_device.cs_nb = csx] LEX 									       / dsatmdev_loop \
          / <legal_char_set> 			/ set_char_set LEX			/ char_set \
	/ <any-token>			/ ERROR (55) NEXT_STMT			/ dsatmdev_loop \
          / <no-token>			/ ERROR (7) 				/ RETURN \

char_subset

          / ; 				/ [dsatm_device.css_nb = cssx] LEX 									       / dsatmdev_loop \
          / <legal_char_subset> 		/ set_char_subset LEX			/ char_subset \
	/ <any-token>			/ ERROR (55) NEXT_STMT			/ dsatmdev_loop \
          / <no-token>			/ ERROR (7) 				/ RETURN \

char_font

          / ; 				/ [dsatm_device.cf_nb = cfx] LEX 									       / dsatmdev_loop \
          / <legal_char_font> 		/ set_char_font LEX			/ char_font \
	/ <any-token>			/ ERROR (55) NEXT_STMT			/ dsatmdev_loop \
          / <no-token>			/ ERROR (7) 				/ RETURN \

nat_lang

          / ; 				/ [dsatm_device.nl_nb = nlx] LEX 									       / dsatmdev_loop \
          / <legal_nat_lang> 			/ set_nat_lang LEX			/ nat_lang \
	/ <any-token>			/ ERROR (55) NEXT_STMT			/ dsatmdev_loop \
          / <no-token>			/ ERROR (7) 				/ RETURN \

compression

          / ; 				/ [dsatm_device.ca_nb = cax] LEX 									       / dsatmdev_loop \
          / <legal_compression> 		/ set_compression LEX			/ compression \
	/ <any-token>			/ ERROR (55) NEXT_STMT			/ dsatmdev_loop \
          / <no-token>			/ ERROR (7) 				/ RETURN \

          \" END of the DSA TM stuff

	\" preaccess command types

preaccess
	/ MAP ;		/ [p = addr (ttt.type_map); pa_type = 1] LEX (2)		/ preaccess_type \
	/ map ;		/ [p = addr (ttt.type_map); pa_type = 1] LEX (2)		/ preaccess_type \
	/ <any-token>	/ ERROR (34) NEXT_STMT				/ mainloop \
	/ <no-token>	/ ERROR (7)					/ RETURN \

preaccess_type
	/ type : <defined_type> ;
			/ LEX (2) [p -> based_fb = token.Nvalue] LEX (2)		/ mainloop \
	/ type :		/ LEX (2) ERROR (18) NEXT_STMT			/ mainloop \
	/ <any-token>	/ semant_error (35, pa_name (pa_type), "")		/ mainloop \
	/ <no-token>	/ ERROR (7)					/ RETURN \

	\" mode checking

check_modes
	/		/ [mode_string = ""]			/  \
	/ ;	 	/ LEX					/ STACK_POP \

next_mode
	/ <valid_mode>	/ [mode_string = mode_string || token_value] LEX	/ delim \
	/ <any-token>	/ ERROR (2) [mode_string = mode_string || token_value] LEX
								/ delim \
mode_err	/ <no-token>	/ ERROR (7)				/ RETURN \

delim
	/ ,		/ [mode_string = mode_string || ","] LEX	/ next_mode \
	/ ;		/ LEX					/ STACK_POP \
	/ <any-token>	/ ERROR (40) NEXT_STMT POP			/ STACK_POP \
	/		/					/ mode_err \

dft_modes
	/		/ [dft.modes = mode_string]			/ STACK_POP \

entry_modes
	/		/ [tte.modes = mode_string]			/ STACK_POP \


	\" end statement handler

finish
	/ <any-token>	/ ERROR (27)				/ RETURN \
	/ <no-token>	/					/ RETURN \

					++*/
%page;
/* format: style4 */
cv_ttf: proc;


/* External Entries */

dcl  com_err_ entry options (variable);
dcl  com_err_$suppress_name entry () options (variable);
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  get_group_id_ entry returns (char (32));
dcl  get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
dcl  get_wdir_ entry returns (char (168));
dcl  hcs_$delentry_seg entry (ptr, fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));
dcl  hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35));
dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  lex_error_ entry options (variable);
dcl  lex_string_$init_lex_delims entry (char (*), char (*), char (*), char (*), char (*), bit (*), char (*) varying, char (*) varying, char (*) varying, char (*) varying);
dcl  lex_string_$lex entry (ptr, fixed bin (21), fixed bin (21), ptr, bit (*), char (*), char (*), char (*), char (*), char (*), char (*) varying, char (*) varying, char (*) varying, char (*) varying, ptr, ptr, fixed bin (35));
dcl  pathname_ entry (char (*), char (*)) returns (char (168));
dcl  release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
dcl  suffixed_name_$new_suffix entry (char (*), char (*), char (*), char (32), fixed bin (35));
dcl  terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));
dcl  translator_temp_$get_segment entry (char (*), ptr, fixed bin (35));
dcl  translator_temp_$release_all_segments entry (ptr, fixed bin (35));


/* External Static */

dcl  cv_ttf_severity_ fixed bin (35) ext init (0);

dcl  dsatm_data_$device_multics_dft ext aligned;

dcl  (error_table_$badopt,
     error_table_$noentry,
     error_table_$too_many_args,
     error_table_$zero_length_seg,
     error_table_$noarg,
     error_table_$bad_conversion,
     error_table_$translation_failed) fixed bin (35) ext static;


/* Internal Static */

dcl  ALL_CAPS char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
dcl  ALL_LOWERCASE char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz");
dcl  BS char (1) int static options (constant) init ("");	/* backspace */
dcl  LEGAL_CHARS char (63) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_");
dcl  NUL_CHAR char (1) int static options (constant) init (""); /* NUL char (all zero) */
dcl  already_called bit (1) int static init ("0"b);
dcl  breaks char (43) varying int static;
dcl  ctl_chars char (32) varying int static;
dcl  lexctl char (80) varying int static;
dcl  lexdlm char (80) varying int static;
dcl  max_rep_depth fixed bin int static options (constant) init (2);
dcl  prog_name char (6) int static options (constant) init ("cv_ttf");
dcl  translation_failure fixed bin int static options (constant) init (3);


/* Automatic */

dcl  ans_back_table_ptr ptr init (null ());		/* ptr to work area for answerback tables */
dcl  ans_size fixed bin (18);				/* # words in specific answerback table entry */
dcl  ansbck_char_index fixed bin;			/* used in storing parsed answerback entry */
dcl  arg char (argl) based (argp);			/* overlay for input arg */
dcl  argc fixed bin;				/* # input args */
dcl  argl fixed bin;				/* length of specific input arg */
dcl  argp ptr;					/* ptr to specific input arg */
dcl  argx fixed bin;				/* which input arg being processed */
dcl  baud_error_printed bit (1);			/* flag for single output of baud error statement */
dcl  baudx fixed bin;				/* baud table entry index */
dcl  bit_count fixed bin (24);			/* input TTF bit_count */
dcl  bitp ptr init (null ());				/* misc bit string ptr */
dcl  block_ack_set bit (1);				/* flag to denote block ACK used in this type entry */
dcl  cax fixed bin;					/* used in dsatm_device coding (compression index) */
dcl  cex fixed bin;					/* used in dsatm_device coding (character encoding index) */
dcl  cfx fixed bin;					/* used in dsatm_device coding (character font index) */
dcl  check_0nums bit (1);
dcl  code fixed bin (35);				/* general error code */
dcl  count fixed bin;				/* c_chars.count temp counter */
dcl  cps_baud_value fixed bin;			/* equivalent of specified CPS expressed as bps */
dcl  created_table_segment bit (1) aligned;		/* flag to show cv_ttf created output TTT segment */
dcl  cssx fixed bin;				/* used in dsatm_device coding (character subset index) */
dcl  csx fixed bin;					/* used in dsatm_device coding (character set index) */
dcl  ct_table_offset fixed bin (18);			/* offset to next conversion table entry */
dcl  cur_delay_value fixed bin;			/* temp value of current delay value being processed */
dcl  cur_table_name char (32);			/* name of current table being processed */
dcl  default_count fixed bin;				/* counter for default_types temp entry */
dcl  defined fixed bin;				/* denotes new table name has entry for it in table_names */
dcl  delay_error_printed bit (1);			/* flag for single output of delay error statement */
dcl  delay_stmt bit (1);				/* flag to denote delay statement found */
dcl  delayx fixed bin;				/* delay table type index */
dcl  dft_bauds (12) fixed bin;			/* array of baud rates specified in Bauds statement */
dcl  dft_extended_tables_defined bit (1);		/* denotes have one or more default extended tables defined */
dcl  dft_extended_tablesp ptr init (null ());		/* ptr to any default extended tables */
dcl  dirname char (168);				/* directory for input TTF */
dcl  dppx fixed bin;				/* used in dsatm_device coding */
dcl  edited (1024) fixed bin;				/* placeholders for output escape sequences */
dcl  entryx fixed bin;				/* count of entries in conversion/translation table */
dcl  esc_p ptr init (null ());			/* ptr to special string to store edited/non-edited output escape values in */
dcl  extended_tables_workp ptr init (null ());		/* ptr to work area for all extended tables */
dcl  fb35 fixed bin (35);				/* general fixed bin (35) storage value */
dcl  fkey_table_offset fixed bin (18);			/* offset to start next function key table at */
dcl  fkey_tables_ptr ptr init (null ());		/* ptr to work area for function key tables */
dcl  floating_delay_value float bin;			/* general floating value for delay item */
dcl  got_temps bit (1);				/* flag to show have temp segments */
dcl  highest fixed bin;
dcl  i fixed bin;
dcl  increment fixed bin (18);
dcl  j fixed bin;
dcl  length_in_words fixed bin;
dcl  line_type_str bit (72);
dcl  max_output_escapes fixed bin;
dcl  max_values char (2);
dcl  maxind fixed bin (8);
dcl  misc_relocs_count fixed bin;
dcl  misc_relocs_ptr ptr init (null ());		/* ptr to work area for all relocs */
dcl  misc_tables_ptr ptr init (null ());		/* ptr to work area where will build all misc tables */
dcl  mode_line_length fixed bin;
dcl  mode_page_length fixed bin;
dcl  mode_string char (256) varying;
dcl  n_answerbacks fixed bin;
dcl  n_dft_bauds fixed bin;
dcl  n_fkey_tables fixed bin;
dcl  n_spec fixed bin;				/* number of delay values specified */
dcl  n_special_tables fixed bin;
dcl  n_table_names fixed bin;
dcl  n_tables fixed bin;
dcl  name_idx fixed bin;
dcl  name_to_test_for char (32);			/* translated name to check tables for */
dcl  new_delay_table_ptr ptr init (null ());
dcl  next_misc_offset fixed bin (18);
dcl  next_offset fixed bin (18);
dcl  nlx fixed bin;
dcl  not_edited (1024) fixed bin;
dcl  num_0nums fixed bin;
dcl  off_sw bit (1);
dcl  out_sus_set bit (1);
dcl  p ptr init (null ());
dcl  pa_type fixed bin;
dcl  prev_ptr ptr init (null ());
dcl  rcx fixed bin;
dcl  real_name char (32);
dcl  rep_depth fixed bin;
dcl  rep_error bit (1);
dcl  rep_factor (2) fixed bin;
dcl  rep_length fixed bin;
dcl  rep_start (2) fixed bin;
dcl  rep_used bit (1);
dcl  scx fixed bin;
dcl  seqs_index fixed bin;
dcl  size_of_ttt fixed bin (18);
dcl  sourcep ptr init (null ());
dcl  spec_offset fixed bin (18);
dcl  special_tables_ptr ptr init (null ());		/* ptr to area where special tables will be built */
dcl  specialp ptr init (null ());
dcl  stmtp ptr init (null ());
dcl  supplied_ename char (32);
dcl  table_names_ptr ptr init (null ());		/* ptr to work area for names of all tables */
dcl  table_size fixed bin (18);
dcl  tables_ptr ptr init (null ());			/* ptr to work area for tables entries */
dcl  targetp ptr init (null ());
dcl  temp_dfttp ptr init (null ());			/* ptr to temp copy of dftt with type names */
dcl  temp_strings_ptr ptr init (null ());		/* ptr to work area for all temp strings */
dcl  temp_ptr (10) ptr init ((10) null ());
dcl  temp_ttep ptr init (null ());
dcl  tempp ptr init (null ());
dcl  test_value char (8);
dcl  ttf_ename char (32);
dcl  ttfp ptr init (null ());
dcl  ttt_ename char (32);
dcl  wdir char (168);

dcl  1 dft aligned like tte;				/* for default values */

dcl  1 input_escapes aligned,
       2 len fixed bin (8) unal,
       2 str char (128) unal;

dcl  1 input_results aligned like input_escapes;


/* Based */

dcl  based_bit1 bit (1) based;
dcl  based_fb fixed bin based;
dcl  based_fb8 fixed bin (8) unal based;
dcl  based_fb17 fixed bin (17) unal based;
dcl  based_two_words (2) fixed bin based;
dcl  exp_string char (2048) based (addr (expanded));
dcl  fb8_array (count) fixed bin (8) unal based;
dcl  misc_strings (next_misc_offset) fixed bin based;
dcl  temp_table (0:255) fixed bin (8) unal based (tablep);
dcl  unexp_string char (2048) based (addr (unexpanded));

dcl  1 dummy_dftte based aligned like dftt.dftte;		/* for taking "size" of */

dcl  1 escapes (max_output_escapes) aligned based like c_chars;

dcl  1 extended_tables_work aligned based (extended_tables_workp),
       2 seqs char (4096),
       2 table fixed bin (71);			/* put a table here */

dcl  1 table_names (n_table_names) based (table_names_ptr) aligned,
       2 name char (32) unal,
       2 type fixed bin,				/* 1 = conv/trans, 2 = special */
       2 offset fixed bin (18);			/* -1 = undefined */

dcl  misc_relocs (misc_relocs_count) ptr unal based (misc_relocs_ptr);

dcl  1 temp_dftt based (temp_dfttp),			/* temporary copy of dftt, with type names */
       2 dft_count fixed bin,
       2 temp_dftte (0 refer (temp_dftt.dft_count)),
         3 entry like dftt.dftte,
         3 type_name char (32);

dcl  temp_key_index fixed bin;
dcl  temp_key_infop ptr init (null ());

dcl  1 temp_key_info (0:3) aligned based (temp_key_infop) like key_info;

dcl  1 temp_special_table aligned based (tablep),
       2 nl_seq aligned like c_chars,			/* new-line sequence */
       2 cr_seq aligned like c_chars,			/* carriage-return sequence */
       2 bs_seq aligned like c_chars,			/* backspace sequence */
       2 tab_seq aligned like c_chars,			/* horizontal tab sequence */
       2 vt_seq aligned like c_chars,			/* vertical tab sequence */
       2 ff_seq aligned like c_chars,			/* form-feed sequence */
       2 printer_on aligned like c_chars,		/* printer-on sequence */
       2 printer_off aligned like c_chars,		/* printer_off sequence */
       2 red_ribbon_shift aligned like c_chars,		/* red ribbon shift sequence */
       2 black_ribbon_shift aligned like c_chars,		/* black ribbon shift sequence */
       2 end_of_page aligned like c_chars,		/* end-of-page warning sequence */

       2 escape_length fixed bin,			/* number of escape sequences */
       2 not_edited_escapes (sc_escape_len refer (temp_special_table.escape_length)) like c_chars, /* use in ^edited mode */
       2 edited_escapes (sc_escape_len refer (temp_special_table.escape_length)) like c_chars, /* use in edited mode */

       2 input_escapes aligned,
         3 len fixed bin (8) unaligned,			/* length of string */
         3 str char (sc_input_escape_len refer (temp_special_table.input_escapes.len)) unaligned, /* escape sequence characters */
       2 input_results aligned,
         3 pad bit (9) unaligned,			/* so that strings will look the same */
         3 str char (sc_input_escape_len refer (temp_special_table.input_escapes.len)) unaligned; /* results of escape sequences */

dcl  1 temp_numeric_encoding unaligned like tty_numeric_encoding automatic;

dcl  1 temp_strings aligned based (temp_strings_ptr),
       2 exp_char_index fixed bin,
       2 unexp_char_index fixed bin,
       2 expanded (2048) fixed bin (8) unal,
       2 unexpanded (2048) fixed bin (8) unal,
       2 rep_item char (2048) varying;

/* Conditions */

dcl  (cleanup, conversion) condition;


/* Builtins */

dcl  (addr, addrel, baseno, bin, byte, char, collate, currentsize, dimension, divide, float, hbound, index, lbound,
     length, ltrim, max, mod, null, ptr, rank, rel, rtrim, size, substr, translate, unspec, verify) builtin;
%page; %include access_mode_values;
%page; %include author_dcl;
%page; %include baud_rates;
%page; %include dsatm_attn_fcn_info;
%page; %include dsatm_negotiate_info;
%page; %include dsatm_tty_modes;
%page; %include function_key_data;
%page; %include line_types;
%page; %include term_type_protocols;
%page; %include terminate_file;
%page; %include ttt;
%page; %include tty_can_types;
%page; %include tty_mode_names;
%page; %include tty_video_tables;
%page;
/* introductory setup */

	ttfp, tttp, tempp, temp_ptr (*) = null;		/* setup for clean_up */
	dft_extended_tablesp = null;
	c_chars_ptr = null;				/* make the compiler happy */
	got_temps = ""b;
	created_table_segment = ""b;
	dirname, supplied_ename, ttf_ename, ttt_ename = "";
	check_0nums = "0"b;

	on cleanup begin;
	     call clean_up;
	     cv_ttf_severity_ = 5;
	end;

	call cu_$arg_count (argc, code);
	if code ^= 0 then do;
	     call com_err_ (code, prog_name);
	     go to severity_5_failure;
	end;
	if argc < 1
	then do;
give_usage:    call com_err_$suppress_name (0, prog_name,
		"Usage:  cv_ttf ttf_name [-brief | -long]");
	     go to severity_5_failure;
	end;

	do argx = 1 to argc;
	     call cu_$arg_ptr (argx, argp, argl, code);
	     if char (arg, 1) ^= "-"
	     then do;
		if supplied_ename ^= ""
		then do;
		     call com_err_ (error_table_$too_many_args, prog_name, "Only one pathname may be given. ^a was the second.", arg);
		     go to severity_5_failure;
		end;

		call expand_pathname_ (arg, dirname, supplied_ename, code);
		if code ^= 0 then do;
path_error:
		     call com_err_ (code, prog_name, "^a", arg);
		     go to severity_5_failure;
		end;
		call expand_pathname_$add_suffix (arg, "ttf", dirname, ttf_ename, code);
		if code ^= 0 then go to path_error;

		call suffixed_name_$new_suffix (supplied_ename, "ttf", "ttt", ttt_ename, code); /* if we get this far, how can we fail? */
		if code ^= 0			/* still, let's have a look */
		then go to path_error;

	     end;					/* Pathname case */
	     else if arg = "-bf" | arg = "-brief"
	     then SERROR_CONTROL = "01"b;

	     else if arg = "-lg" | arg = "-long"
	     then SERROR_CONTROL = "10"b;

	     else if arg = "-ck1dig" then do;
		check_0nums = "1"b;			/* they made me change the name from ck0num to ck1dig */
		num_0nums = 0;
	     end;

	     else if arg = "-severity" | arg = "-sv" then do;
		if argx >= argc then do;
		     call com_err_ (error_table_$noarg, prog_name, "After ""^a"".", arg);
		     go to severity_5_failure;
		end;
		argx = argx + 1;
		call cu_$arg_ptr (argx, argp, argl, code);
		fb35 = cv_dec_check_ (arg, code);
		if code ^= 0 | fb35 < 0 | fb35 > 5 then do;
		     call com_err_ (error_table_$bad_conversion, prog_name,
			"Severity must be an integer in the range 0 - 5, not ""^a"".", arg);
		     go to severity_5_failure;
		end;
		MIN_PRINT_SEVERITY = fb35;
	     end;

	     else do;
		code = error_table_$badopt;
arg_error:	call com_err_ (code, prog_name, arg);
		go to severity_5_failure;
	     end;
	end;					/* argument processing loop */
	if supplied_ename = "" then go to give_usage;

/* initialize some variables */

	n_tables, n_answerbacks, n_table_names, n_dft_bauds, ct_table_offset, spec_offset, fkey_table_offset, default_count = 0;
	dsatmdevp = null;

	next_misc_offset = 1;			/* so that no valid offset will be zero */

	call initiate_file_ (dirname, ttf_ename, R_ACCESS, ttfp, bit_count, code);
	if code = error_table_$noentry
	then if ttf_ename ^= supplied_ename
	     then do;
		call initiate_file_ (dirname, supplied_ename, R_ACCESS, ttfp, bit_count, code);
		if code = 0
		then do;
		     call com_err_ (0, prog_name, "Warning: converting ^a. The segment should be named ^a.",
			pathname_ (dirname, supplied_ename), ttf_ename);
		     ttf_ename = supplied_ename;
		end;
	     end;
	if code ^= 0
	then do;
ttf_error:     call com_err_ (code, prog_name, "^a.", pathname_ (dirname, ttf_ename));
	     go to severity_5_failure;
	end;
	if bit_count = 0 then do;
	     code = error_table_$zero_length_seg;
	     go to ttf_error;
	end;

/* now create segment in which to build TTT */

	wdir = get_wdir_ ();
	call hcs_$make_seg (wdir, ttt_ename, "", 01010b, tttp, code);
	created_table_segment = (code = 0);
	if tttp = null
	then go to ttt_error;

	call hcs_$truncate_seg (tttp, 0, code);		/* start clean */
	if code ^= 0
	then do;
ttt_error:     call com_err_ (code, prog_name, ttt_ename);
	     go to severity_5_failure;
	end;

/* get a bunch of temporary segments for pieces of TTT */

	call get_temp_segments_ (prog_name, temp_ptr, code);
	if code ^= 0
	then do;
	     call com_err_ (code, prog_name, "Creating temporary segments");
	     go to severity_5_failure;
	end;

	got_temps = "1"b;
	tables_ptr = temp_ptr (1);
	special_tables_ptr = temp_ptr (2);
	misc_tables_ptr = temp_ptr (3);
	ans_back_table_ptr = temp_ptr (4);
	table_names_ptr = temp_ptr (5);
	temp_dfttp = temp_ptr (6);
	extended_tables_workp = temp_ptr (7);
	misc_relocs_ptr = temp_ptr (8);
	fkey_tables_ptr = temp_ptr (9);
	temp_strings_ptr = temp_ptr (10);
	misc_relocs_count = 0;

/* Set up TTT header */

	ttt.author.proc_group_id = get_group_id_ ();
	ttt.last_install_time = 0;
	ttt.lock = ""b;
	ttt.author.table = "TTT";
	ttt.author.w_dir = substr (wdir, 1, length (ttt.author.w_dir));
	ttt.version = TTT_version_4;

/* initialize default structure */

	ttep = addr (ttt.tt_entries (1));
	dft = tte;				/* all zero */
	dft.name = "";
	dft.modes = "";
	dft.protocol = 0;
	dft.line_types = (72)"1"b;			/* all valid initially */
	dft.erase = "#";
	dft.kill = "@";

	allocate extended_tables set (dft_extended_tablesp);
	dft_extended_tablesp -> extended_tables.tables_rp (*) = 0;
	dft_extended_tables_defined = "0"b;

/* set up for lex_string_ */

	call translator_temp_$get_segment (prog_name, tempp, code);
	if tempp = null
	then do;
	     call com_err_ (code, prog_name, "From translator_temp_$get_segment");
	     go to severity_5_failure;
	end;

	if ^already_called
	then do;
	     ctl_chars = substr (collate (), 1, 8) || substr (collate (), 10, 24);
	     breaks = ctl_chars || "()<>*,:;";
	     call lex_string_$init_lex_delims ("""", """", "/*", "*/", ";", "10"b, breaks, ctl_chars, lexdlm, lexctl);
	     already_called = "1"b;
	end;

	call lex_string_$lex (ttfp, divide (bit_count, 9, 21, 0), 0, tempp, "1000"b, """", """", "/*", "*/", ";",
	     breaks, ctl_chars, lexdlm, lexctl, stmtp, Pthis_token, code);

/* Go to it! */

	call SEMANTIC_ANALYSIS ();

/*  put everything together */

	if MERROR_SEVERITY >= translation_failure
	then call com_err_ (error_table_$translation_failed, prog_name);

	else do;
	     do i = 1 to n_table_names;		/* append conv/trans tables to TTT */
		if table_names (i).offset = -1	/* oops, this one was never defined */
		then call semant_error (28, table_names (i).name, "");

		else if table_names (i).type ^= SPEC_TYPE & table_names (i).type ^= FKEY_TYPE
		then do;
		     n_tables = n_tables + 1;
		     tablep = addr (ttt.tables (n_tables));
		     table_entry.name = table_names (i).name;
		     table_entry.type = table_names (i).type;
		     sourcep = ptr (tables_ptr, table_names (i).offset);
		     table_entry.table = sourcep -> cv_trans_struc;
		     table_names (i).offset = bin (rel (tablep), 18); /* update offset for later use */
		end;
	     end;

	     ttt.n_tables = n_tables;

/* now special tables */

	     specialp = addr (ttt.rest_of_ttt);
	     next_offset = bin (rel (specialp), 18);

	     n_special_tables = 0;
	     do i = 1 to n_table_names;
		if table_names (i).type = SPEC_TYPE & table_names (i).offset ^= -1
		then do;
		     n_special_tables = n_special_tables + 1;
		     specialp -> special_table.name = table_names (i).name;
		     sourcep = ptr (special_tables_ptr, table_names (i).offset);
		     specialp -> special_table.version = SPECIAL_VERSION_2;
		     specialp -> special_table.default = 0;
		     specialp -> special_table.table.special_chars = sourcep -> special_chars;

		     table_names (i).offset = next_offset;
		     table_size = divide (length (unspec (sourcep -> special_chars)) + 35, 36, 18, 0);
		     next_offset = next_offset + table_size + 11; /* include name and header */
		     specialp = ptr (tttp, next_offset);
		end;
	     end;


	     ttt.n_special_tables = n_special_tables;

/* now function key tables */

	     n_fkey_tables = 0;
	     ttt.fkey_offset = next_offset;

	     do i = 1 to n_table_names;
		if table_names (i).type = FKEY_TYPE & table_names (i).offset ^= -1
		then do;
		     n_fkey_tables = n_fkey_tables + 1;
		     fkey_tablep = ptr (tttp, next_offset);
		     function_key_data_ptr = ptr (fkey_tables_ptr, table_names (i).offset);
		     fkey_table.name = table_names (i).name;
		     fkey_table.version = function_key_data.version;
		     fkey_table.highest = function_key_data.highest;
		     fkey_table.cursor_motion_keys = function_key_data.cursor_motion_keys;
		     fkey_table.function_keys = function_key_data.function_keys;
		     sourcep = function_key_data.seq_ptr; /* move corresponding fkey sequences */
		     targetp = ptr (tttp, next_offset + currentsize (fkey_table));
		     targetp -> function_key_seqs = sourcep -> function_key_seqs;
		     fkey_table.seq_offset = bin (rel (targetp));
		     fkey_table.seq_len = function_key_data.seq_len;
		     table_names (i).offset = next_offset;
		     next_offset = next_offset + currentsize (fkey_table) + currentsize (targetp -> function_key_seqs);
		end;
	     end;
	     ttt.n_fkey_tables = n_fkey_tables;

	     increment = next_offset - 1;		/* to be added to all relative ptrs in tte */
	     targetp = ptr (tttp, next_offset);		/* pointer to next free spot in TTT */
	     misc_tables_ptr = addrel (misc_tables_ptr, 1); /* skip over first (unused) word */
	     next_misc_offset = next_misc_offset - 1;	/* so size of array is right */

	     targetp -> misc_strings = misc_tables_ptr -> misc_strings; /* fill it in */
	     next_offset = next_offset + next_misc_offset;

	     if default_count = 0
	     then do;
		ttt.default_type_offset = 0;
		call ERROR (32);
	     end;

	     else do;
		ttt.default_type_offset = next_offset;
		dfttp = ptr (tttp, next_offset);	/* this is where we will put default_types table */

		do i = 1 to default_count;
		     dftte (i) = temp_dftte (i).entry;
		     if temp_dftte (i).term_type_index = 0 /* default type specified before type defined */
		     then do;
			name_to_test_for = translate (temp_dftte (i).type_name, ALL_CAPS, ALL_LOWERCASE);
			do j = 1 to ttt.n_tt_entries; /* find it now */
			     ttep = addr (ttt.tt_entries (j));
			     if tte.name = name_to_test_for
			     then go to found_match;
			end;

			if j > ttt.n_tt_entries
			then call semant_error (29, temp_dftte (i).type_name, "");
			else
found_match:		     dftte (i).term_type_index = j;

		     end;
		end;

		dftt.dft_count = default_count;
		next_offset = next_offset + default_count * size (dummy_dftte) + 1;
	     end;

	     if n_answerbacks > 0
	     then ttt.answerback_offset = next_offset;
	     else ttt.answerback_offset = 0;

/* now append answerback table */

	     answerback_entry_ptr = ans_back_table_ptr;	/* get pointer to base of temp seg */
	     do i = 1 to n_answerbacks;
		targetp = ptr (tttp, next_offset);

		if i > 1				/* not first one */
		then prev_ptr -> answerback_entry.next = next_offset;

		answerback_length = answerback_entry.length; /* so refer will work when we assign it */
		targetp -> answerback_entry = answerback_entry;

		ans_size = divide (answerback_length + 3, 4, 18, 0) + 3; /* total number of words in entry */
		next_offset = next_offset + ans_size;
		answerback_entry_ptr = addrel (answerback_entry_ptr, ans_size);
		prev_ptr = targetp;
	     end;

	     size_of_ttt, ttt.total_ttt_size = next_offset;

/* go through all entries. for each one, update the relative pointers,
   *  and check for reasonable consistency between output_conversions and
   *  special tables
*/

	     call perform_misc_relocs;

	     highest = 0;

	     do i = 1 to ttt.n_tt_entries;
		ttep = addr (ttt.tt_entries (i));

		call set_table_offset (tte.input_translation_rp);
		call set_table_offset (tte.output_translation_rp);
		call set_table_offset (tte.input_conversion_rp);
		call set_table_offset (tte.output_conversion_rp);
		call set_table_offset (tte.special_rp);
		call set_table_offset (tte.fkey_rp);

		if tte.special_rp <= 0		/* no special table */
		then if tte.output_conversion_rp > 0	/* but there is an output_conversion table */
		     then call semant_error (30, tte.name, "");
		     else ;			/* it's all right not to have either */

		else if tte.output_conversion_rp > 0	/* if we have both, cross-check */
		then do;
		     tablep = ptr (tttp, tte.output_conversion_rp);
		     specialp = ptr (tttp, tte.special_rp);
		     specialp = addr (specialp -> special_table.special_chars);

		     maxind = table_entry.cv_trans.value (0);

		     do j = 1 to hbound (tablep -> cv_trans.value, 1); /* make sure all indicators are represented by sequences */
			if table_entry.cv_trans.value (j) > maxind
			then maxind = table_entry.cv_trans.value (j);
		     end;

		     if maxind > 16			/* any escape sequences at all */
		     then if maxind - 16 > specialp -> special_chars.escape_length
			then call semant_error (31, tte.name, table_entry.name);
		end;

/* check for consistent framing characters */

		if tte.frame_begin ^= NUL_CHAR & tte.frame_end = NUL_CHAR
		then call semant_error (41, tte.name, "");

/* check for consistent flow control specifications */

		if tte.output_block_acknowledge
		then if tte.output_buffer_size = 0 | tte.output_suspend_etb = NUL_CHAR | tte.output_resume_ack = NUL_CHAR
		     then call semant_error (43, tte.name, "");
		     else ;

		else if (tte.output_suspend_etb = NUL_CHAR & tte.output_resume_ack ^= NUL_CHAR) |
		     (tte.output_suspend_etb ^= NUL_CHAR & tte.output_resume_ack = NUL_CHAR)
		then call semant_error (43, tte.name, "");

		if (tte.input_suspend = NUL_CHAR & tte.input_resume ^= NUL_CHAR & ^tte.input_timeout) |
		     (tte.input_suspend ^= NUL_CHAR & tte.input_resume = NUL_CHAR)
		then call semant_error (44, tte.name, "");

/* make sure coded type is reasonable in case this is site's first TTT */

		highest, tte.coded_type = highest + 1;
	     end;

	     ttt.highest_coded_type = highest;		/* if install/up_ttt_ is used, this will be overwritten */

	     if ttt.type_map = 0
	     then call semant_error (35, "MAP", "");	/* warn if preaccess types omitted */

/* essentially all done */

	     if check_0nums
	     then if num_0nums > 0 then call com_err_ (0, prog_name, "^d incompatible character specification^[s^] found",
			num_0nums, num_0nums ^= 1);
		else call ioa_ ("No incompatible character specifications found.");

	     if MERROR_SEVERITY >= translation_failure
	     then do;
		call com_err_ (error_table_$translation_failed, prog_name);
		if created_table_segment then size_of_ttt = -1;
		else size_of_ttt = 0;
	     end;
	     if size_of_ttt >= 0 then do;
		call terminate_file_ (tttp, 36 * size_of_ttt, TERM_FILE_TRUNC_BC_TERM, code);
		if code ^= 0
		then do;
		     call com_err_ (code, prog_name, "Could not set bit count of TTT");
		     go to severity_5_failure;
		end;
	     end;
	end;

	call clean_up;				/* final wrapup */
	cv_ttf_severity_ = MERROR_SEVERITY;
	return;

severity_5_failure:
	call clean_up;
	cv_ttf_severity_ = 5;
	return;
%page;
clean_up: proc;

/* cleanup handler -- makes sure anything we initiated gets terminated, anything we allocated gets freed */

	if ttfp ^= null
	then call terminate_file_ (ttfp, (0), TERM_FILE_TERM, (0));

	if tttp ^= null
	then if created_table_segment
	     then do;
		call hcs_$delentry_seg (tttp, (0));
		tttp = null;
	     end;
	     else call terminate_file_ (tttp, (0), TERM_FILE_TRUNC_BC_TERM, (0));

	if tempp ^= null
	then call translator_temp_$release_all_segments (tempp, (0));
	tempp = null;

	if got_temps
	then call release_temp_segments_ (prog_name, temp_ptr, code);
	got_temps = "0"b;

	if dft_extended_tablesp ^= null () then free dft_extended_tablesp -> extended_tables;

	return;

     end /* clean_up */;

add_increment: proc (rp);

/* internal procedure to add increment to offsets in misc_tables */

dcl  rp fixed bin (18);				/* input as offset in misc_tables, output as correct offset in TTT */

	if rp <= 0 then return;			/* no target */
	else rp = rp + increment;
	return;

     end /* add_increment */;



set_table_offset: proc (rp);

/* internal procedure to set offsets in tte from table_names array */

dcl  rp fixed bin (18);				/* input as index in array, output as correct offset */

	if rp <= 0 then return;			/* no table, leave it alone */
	else rp = table_names (rp).offset;
	return;

     end /* set_table_offset */;

statement_error: proc (error_num, parm1, parm2);

dcl  error_num fixed bin;
dcl  parm1 char (*);
dcl  parm2 char (*);
dcl  (stmt_ptr, token_ptr) ptr init (null);

	stmt_ptr = token.Pstmt;
	token_ptr = Pthis_token;

semant_error: entry (error_num, parm1, parm2);

	if error_control_table (error_num).severity >= MIN_PRINT_SEVERITY
	then call lex_error_ (error_num, SERROR_PRINTED (error_num), (error_control_table.severity (error_num)),
		MERROR_SEVERITY, stmt_ptr, token_ptr, SERROR_CONTROL,
		(error_control_table.message (error_num)), (error_control_table.brief_message (error_num)),
		parm1, parm2);
	else do;
	     MERROR_SEVERITY = max (MERROR_SEVERITY, error_control_table (error_num).severity);
	     SERROR_PRINTED (error_num) = "1"b;
	end;
	return;

     end /* statement_error */;

/* Syntax Functions */


/* returns TRUE if token contains upper/lower case, numeric or underscore */

legal_name: proc returns (bit (1) aligned);

	return (verify (token_value, LEGAL_CHARS) = 0);
     end legal_name;


/* returns TRUE if legal name
   and token_value is either a new table name (defined = 0)
   or references a table which has not been filled in yet (defined = table index) */
new_table_name: proc returns (bit (1) aligned);

	if ^legal_name ()
	then do;
	     call statement_error (19, token_value, "");
	     return ("0"b);
	end;

	if token.Lvalue > 32
	then do;
	     call statement_error (39, token_value, "");
	     return ("0"b);
	end;

	do i = 1 to n_table_names;
	     if table_names.name (i) = token_value
	     then if table_names.offset (i) >= 0
		then do;
		     call statement_error (21, token_value, "");
		     return ("0"b);
		end;

		else do;
		     defined = i;			/* to be used by action routine */
		     return ("1"b);
		end;
	end;

	defined = 0;
	return ("1"b);
     end new_table_name;


/* returns TRUE if legal name and not a currently defined terminal type */

new_type_name: proc returns (bit (1) aligned);

	if ^legal_name () then do;
	     call statement_error (19, token_value, "");
	     return ("0"b);
	end;

	if token.Lvalue > 32
	then do;
	     call statement_error (39, token_value, "");
	     return ("0"b);
	end;

	name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE);
	do i = 1 to ttt.n_tt_entries;
	     ttep = addr (ttt.tt_entries (i));
	     if tte.name = name_to_test_for
	     then do;
		call statement_error (20, token_value, "");
		return ("0"b);
	     end;
	end;

	return ("1"b);
     end new_type_name;


valid_mode:
     procedure () returns (bit (1) aligned);

	if substr (token_value, 1, 1) = "^" then do;
	     test_value = substr (token_value, 2);
	     off_sw = "1"b;
	end;
	else do;
	     test_value = token_value;
	     off_sw = "0"b;
	end;

	do i = lbound (modestr, 1) to hbound (modestr, 1);/* see if MCS value */
	     if modestr (i) = test_value then return ("1"b);
	end;

	do i = lbound (TTY_BOOLEAN_MODE_DSA_NAME, 1) to	/* see if DSA value */
	     hbound (TTY_BOOLEAN_MODE_DSA_NAME, 1);
	     if DSA_modestr (i) = test_value then return ("1"b);
	end;

	do i = lbound (CAN_TYPE_NAMES, 1) to hbound (CAN_TYPE_NAMES, 1);
	     if token_value = CAN_TYPE_NAMES (i) then return ("1"b);
	end;

	if (test_value = "force") then		/* either "force" or "^force" */
	     return ("1"b);

	if (token_value = "default") | (token_value = "init") then
	     return ("1"b);				/* these modes can't be negated */

	if (substr (test_value, 1, 2) = "ll") then
	     if (token.Lvalue <= 2) then
		return ("0"b);
	     else do;
		if off_sw then do;
		     if dsatmdevp = null () then mode_line_length = 0;
		     else dsatm_device.line_length = 0;
		     return ("1"b);
		end;
		else do;
		     if substr (test_value, 3, 1) = "=" then
			i = cv_dec_check_ (substr (test_value, 4, token.Lvalue - 3), code);
		     else
			i = cv_dec_check_ (substr (test_value, 3, token.Lvalue - 2), code);
		     if code ^= 0 then return ("0"b);
		     else do;
			if dsatmdevp = null () then mode_line_length = i;
			else dsatm_device.line_length = i;
			return ("1"b);
		     end;
		end;
	     end;

	if (substr (test_value, 1, 2) = "pl") then
	     if (token.Lvalue <= 2) then
		return ("0"b);
	     else do;
		if off_sw then do;
		     if dsatmdevp = null () then mode_page_length = 0;
		     else dsatm_device.page_length = 0;
		     return ("1"b);
		end;
		else do;
		     if substr (test_value, 3, 1) = "=" then
			i = cv_dec_check_ (substr (test_value, 4, token.Lvalue - 3), code);
		     else
			i = cv_dec_check_ (substr (test_value, 3, token.Lvalue - 2), code);
		     if code ^= 0 then return ("0"b);
		     else do;
			if dsatmdevp = null () then mode_page_length = i;
			else dsatm_device.page_length = i;
			return ("1"b);
		     end;
		end;
	     end;

	return ("0"b);				/* here iff not recognized */

     end valid_mode;


valid_edit: proc returns (bit (1) aligned);

	if tty_char () then return (token.Nvalue ^= rank (BS));
	else return ("0"b);

     end /* valid_edit */;


valid_baud: proc returns (bit (1) aligned);

	token.Nvalue = cv_dec_check_ (token_value, code);
	if code ^= 0
	then return ("0"b);

	do i = 1 to hbound (baud_table, 1);
	     if token.Nvalue = baud_table (i)
	     then return ("1"b);
	end;

	return ("0"b);
     end /* valid_baud */;


valid_cps: proc returns (bit (1) aligned);

	token.Nvalue = cv_dec_check_ (token_value, code);
	if code ^= 0
	then return ("0"b);

	if token.Nvalue = 10
	then do;
	     cps_baud_value = 110;
	     return ("1"b);
	end;

	else do;
	     cps_baud_value = token.Nvalue * 10;
	     do i = 1 to hbound (baud_table, 1);
		if cps_baud_value = baud_table (i)
		then return ("1"b);
	     end;

	     return ("0"b);
	end;

     end /* valid_cps */;


delay_value: proc returns (bit (1) aligned);

/* floating point values 0.0 < X < 1.0 */

	if delayx = 2 | delayx = 4
	then do;
	     on conversion go to bad_delay;
	     floating_delay_value = float (token_value);
	     revert conversion;

	     if floating_delay_value < 0 | floating_delay_value > 1.0
	     then
bad_delay:	return ("0"b);
	     else return ("1"b);
	end;

/* fixed point values */
	else do;
	     token.Nvalue = cv_dec_check_ (token_value, code);
	     if code ^= 0
	     then return ("0"b);

	     if delayx = 1 | delayx = 5 then do;
		if token.Nvalue < -127 | token.Nvalue > 127 then
		     return ("0"b);
	     end;
	     else if delayx = 3 then do;
		if token.Nvalue < 0 | token.Nvalue > 127 then
		     return ("0"b);
	     end;
	     else if delayx = 6 then do;
		if token.Nvalue < 0 | token.Nvalue > 511 then
		     return ("0"b);
	     end;

	     return ("1"b);
	end;

     end /* delay_value */;


defined_type: proc returns (bit (1) aligned);

	name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE);
	do i = 1 to ttt.n_tt_entries;
	     temp_ttep = addr (ttt.tt_entries (i));
	     if temp_ttep -> tte.name = name_to_test_for
	     then do;
		token.Nvalue = i;
		return ("1"b);
	     end;
	end;

	return ("0"b);
     end /* defined_type */;


valid_line_type: proc returns (bit (1) aligned);

dcl  lowest fixed bin;

	lowest = 1;
	go to check_line_type;

valid_dft_line_type: entry returns (bit (1) aligned);

	lowest = -2;

check_line_type:
	do i = lowest to max_line_type;
	     if token_value = line_types (i)
	     then do;
		token.Nvalue = i;
		return ("1"b);
	     end;
	end;

	return ("0"b);
     end /* valid_line_type */;


octal_char: proc returns (bit (1) aligned);

	if token.Lvalue > 3
	then return ("0"b);

	token.Nvalue = cv_oct_check_ (token_value, code);
	return (code = 0);
     end /* octal_char */;

tty_char: proc returns (bit (1) aligned);

dcl  i fixed bin;
dcl  asc_mnemonic char (3);

dcl  asc_value (0:32) char (3) static options (constant) init
	("nul", "soh", "stx", "etx", "eot", "enq", "ack", "bel",
	"bs ", "tab", "lf ", "vt ", "ff ", "cr ", "so ", "si ",
	"dle", "dc1", "dc2", "dc3", "dc4", "nak", "syn", "etb",
	"can", "em ", "sub", "esc", "fs ", "gs ", "rs ", "us ", "sp ");

	if token.quoted_string & token.Lvalue = 1
	then call return_tty_char (bin (unspec (token_value)));

	if token.Lvalue = 1 then do;
	     if index ("01234567", token_value) ^= 0 then do;
		if check_0nums then do;
		     call ERROR (49);
		     num_0nums = num_0nums + 1;
		     if octal_char () then return ("1"b);
		end;
	     end;
	     if index (breaks, token_value) = 0
	     then call return_tty_char (bin (unspec (token_value)));
	end;
	if octal_char () then return ("1"b);
	if token.Lvalue = 2 & substr (token_value, 1, 1) = "^" then do;
	     i = index ("@abcdefghijklmnopqrstuvwxyz[\]^_", substr (token_value, 2, 1));
	     if i = 0 then i = index ("@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_", substr (token_value, 2, 1));
	     if i = 0 then return ("0"b);
	     call return_tty_char (i - 1);
	end;
	if token.Lvalue <= 3 then do;
	     asc_mnemonic = translate (token_value, ALL_LOWERCASE, ALL_CAPS);
	     if asc_mnemonic = "del" then call return_tty_char (127);
	     if asc_mnemonic = "nl " then call return_tty_char (10);
	     if asc_mnemonic = "pad" then call return_tty_char (0);
	     if asc_mnemonic = "ht" then call return_tty_char (9);
	     do i = lbound (asc_value, 1) to hbound (asc_value, 1);
		if asc_value (i) = asc_mnemonic then call return_tty_char (i);
	     end;

	end;
	return ("0"b);

return_tty_char: proc (a_value);

dcl  a_value fixed bin;

	     token.Nvalue = a_value;
	     go to nlret;
	end return_tty_char;

nlret:	return ("1"b);

     end tty_char;

indicator_value: proc returns (bit (1) aligned);

	if ^octal_char ()
	then return ("0"b);

	return (token.Nvalue > 16);
     end /* indicator_value */;


no_table: proc returns (bit (1) aligned);

	return (tablep = null);
     end /* no_table */;


rep_err_found: proc returns (bit (1) aligned);

	return (rep_error);
     end /* rep_err_found */;

/* Syntax functions for function_key tables */

fkey_entry_err: proc returns (bit (1) aligned);

	if temp_key_index > KEY_CTRL_AND_SHIFT
	then return ("1"b);
	else return ("0"b);

     end fkey_entry_err;

/* ACTION ROUTINES */

init_type: proc;

/* set up a new terminal type entry */

	mode_line_length, mode_page_length = -1;
	dsatmdevp = null ();

	ttt.n_tt_entries = ttt.n_tt_entries + 1;
	ttep = addr (ttt.tt_entries (ttt.n_tt_entries));
	unspec (tte.tables) = "0"b;
	tte = dft;
	tte.name = translate (token_value, ALL_CAPS, ALL_LOWERCASE);
	baud_error_printed, delay_stmt, block_ack_set, out_sus_set = "0"b;
	if dft_extended_tables_defined then do;
	     call set_extended;
	     extended_tables = dft_extended_tablesp -> extended_tables;
	end;

	return;

     end /* init_type */;


finish_type: proc;

	if tte.initial_string.offset ^= 0 then
	     call register_misc_reloc (tte.initial_string.offset);
	if tte.additional_info.offset ^= 0 then
	     call register_misc_reloc (tte.additional_info.offset);
	if tte.delay_rp ^= 0 then
	     call register_misc_reloc (tte.delay_rp);
	if tte.extended_tables_rp ^= 0 then
	     call register_misc_reloc (tte.extended_tables_rp);
	return;

     end finish_type;

get_protocol: proc returns (fixed bin);

	do i = 1 to hbound (protocol_names, 1);
	     if rtrim (token_value) = protocol_names (i) then
		return (protocol_values (i));
	end;

	call ERROR (54);
	return (-1);

     end get_protocol;


define_table: proc (table_type, a_ptr, next_offset);

/* assign an offset to a table */

dcl  table_type fixed bin;
dcl  a_ptr ptr;
dcl  next_offset fixed bin (18);

	if defined > 0				/* its name has been used */
	then if table_names.type (defined) ^= table_type
	     then do;				/* wrong type */
		call statement_error (22, token_value, table_types (table_names.type (defined)));
		tablep = null;
		return;
	     end;
	     else ;

	else do;
	     defined, n_table_names = n_table_names + 1;
	     table_names.name (defined) = token_value;
	     table_names.type (defined) = table_type;
	end;

	table_names.offset (defined) = next_offset;
	cur_table_name = token_value;
	tablep = ptr (a_ptr, next_offset);
	return;
     end /* define_table */;


define_ct_table: proc (table_type);

dcl  table_type fixed bin;

	call define_table (table_type, tables_ptr, ct_table_offset);
	if tablep = null then return;

	ct_table_offset = ct_table_offset + size (cv_trans) + 2;

	tablep -> cv_trans_struc.version = CV_TRANS_VERSION;
	tablep -> cv_trans_struc.default = 0;
	tablep = addrel (tablep, 2);
	return;
     end /* define_ct_table */;

set_extended: proc;

dcl  i fixed bin;

	if tte.extended_tables_rp = 0 then do;
	     extended_tablesp = get_misc_space (size (extended_tables));
	     tte.extended_tables_rp = bin (rel (extended_tablesp));
	     unspec (extended_tables) = "0"b;
	     extended_tables.ntables = extended_tables_ntables;
	     do i = 1 to extended_tables.ntables;
		call register_misc_reloc (extended_tables.tables_rp (i));
	     end;
	end;
	extended_tablesp = ptr (misc_tables_ptr, tte.extended_tables_rp);
	return;

     end set_extended;

define_video: proc;

	ttyvtblp = addr (extended_tables_work.table);	/* build a table here temporarily */
	tty_video_table.nseq = N_VIDEO_SEQUENCES;
	tty_video_table.video_chars_len = 4096;		/* to clear max space */
	unspec (tty_video_table) = "0"b;
	tty_video_table.nseq = N_VIDEO_SEQUENCES;
	tty_video_table.version = tty_video_tables_version_1;
	extended_tables_work.seqs = "";
	seqs_index = 0;
	return;

     end define_video;

finish_video_table: proc;

/* Make a lotta checks:
   abspos, screenlinelne, screenheight must be defined,
   abspos char syntax, extensions, */

dcl  p ptr;

	tty_video_table.video_chars_len = seqs_index;
	if seqs_index > 0 then
	     tty_video_table.video_chars = substr (extended_tables_work.seqs, 1, seqs_index);
	p = get_misc_space (currentsize (tty_video_table));
	extended_tables.tables_rp (VIDEO_RP) = bin (rel (p));
	p -> tty_video_table = tty_video_table;
	ttyvtblp = p;

	return;

     end finish_video_table;

/* start define a new video sequence */

start_vseq: proc (a_seqn);

dcl  a_seqn fixed bin;

	ttyvseqp = addr (tty_video_table.sequences (a_seqn));
	unspec (tty_video_seq) = "0"b;
	exp_char_index, unexp_char_index = 1;
	tty_video_seq.present = "1"b;
	return;

     end start_vseq;

end_vseq: proc;

	if exp_char_index <= 1 then do;		/* not really any sequence */
	     tty_video_seq.present = "0"b;
	     return;
	end;
	tty_video_seq.len = exp_char_index - 1;
	tty_video_seq.seq_index = seqs_index + 1;
	seqs_index = seqs_index + tty_video_seq.len;
	substr (extended_tables_work.seqs, tty_video_seq.seq_index, tty_video_seq.len) = substr (exp_string, 1, tty_video_seq.len);
	return;

     end end_vseq;

/* DSA stuffs */

define_dsatm_device: proc;

dcl  dftdevp ptr init (null ());

	dsatmdevp = addr (extended_tables_work.table);	/* build a table here temporarily */

	/*** initialization with the structure defined in dsatm_data_ */

	dftdevp = addr (dsatm_data_$device_multics_dft);
	dsatmdevp -> dsatm_device = dftdevp -> dsatm_device;

	/*** update of the line and page length from the modes statement */

	if mode_line_length ^= -1 then dsatm_device.line_length = mode_line_length;
	if mode_page_length ^= -1 then dsatm_device.page_length = mode_page_length;

	/*** initialization of the internal variables */

	dppx, scx, rcx, cex, csx, cssx, cfx, nlx, cax = 0;


	/*** initialization of dsatm_device structure */

	dsatm_device.init_accept_confg = 0;
	dsatm_device.dpp (*) = 0;
	dsatm_device.sdp_dpp.version = 0;
	dsatm_device.sdp_dpp.sdp_class (*) = 0;
	dsatm_device.real_dpp.version = 0;
	dsatm_device.real_dpp.real_class (*) = 0;
	dsatm_device.real_dpp.real_model = "";
	dsatm_device.trans_dpp.version = 0;
	dsatm_device.dev_id = 0;
	dsatm_device.dev_type = 0;
	dsatm_device.attribute.shareability = 0;
	dsatm_device.attribute.alloc_unit = "0"b;
	dsatm_device.line_length = 0;
	dsatm_device.page_length = 0;
	dsatm_device.line_overflow = 0;
	dsatm_device.page_overflow = 0;
	dsatm_device.char_encoding (*) = 0;
	dsatm_device.char_set (*) = 0;
	dsatm_device.char_subset (*) = 0;
	dsatm_device.nat_lang (*) = 0;
	dsatm_device.compression (*) = 0;
	dsatm_device.char_font (*) = 0;
	dsatm_device.terminal_type = "";
	dsatm_device.ete_ack_level = 0;
	dsatm_device.max_rec_size = 0;
	unspec (dsatm_device.attentions) = "0"b;
	dsatm_device.stc_available = "0"b;
	unspec (dsatm_device.repetitive_parm_nb) = "0"b;
	unspec (dsatm_device.parm_rejected) = "0"b;

	return;

     end define_dsatm_device;


legal_dpp: proc returns (bit (1) aligned);

	name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE);
	do name_idx = 1 to hbound (DPP_NAME, 1);
	     if name_to_test_for = DPP_NAME (name_idx) then return ("1"b);
	end;

	return ("0"b);

     end;

set_dpp: proc;

	dppx = dppx + 1;
	max_values = ltrim (char (hbound (dsatm_device.dpp, 1)));
	if dppx > hbound (dsatm_device.dpp, 1) then call statement_error (56, max_values, "");

	dsatm_device.dpp (dppx) = name_idx;

     end;

legal_sdp_class: proc returns (bit (1) aligned);

	name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE);
	do name_idx = 1 to hbound (SC_NAME, 1);
	     if name_to_test_for = SC_NAME (name_idx) then return ("1"b);
	end;

	return ("0"b);

     end;

set_sdp_class: proc;

	scx = scx + 1;
	max_values = ltrim (char (hbound (dsatm_device.sdp_dpp.sdp_class, 1)));
	if scx > hbound (dsatm_device.sdp_dpp.sdp_class, 1) then call statement_error (56, max_values, "");

	dsatm_device.sdp_dpp.sdp_class (scx) = name_idx;

     end;

legal_real_class: proc returns (bit (1) aligned);

	name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE);
	do name_idx = 1 to hbound (RC_NAME, 1);
	     if name_to_test_for = RC_NAME (name_idx) then return ("1"b);
	end;

	return ("0"b);

     end;

set_real_class: proc;

	rcx = rcx + 1;
	max_values = ltrim (char (hbound (dsatm_device.real_dpp.real_class, 1)));
	if rcx > hbound (dsatm_device.real_dpp.real_class, 1) then call statement_error (56, max_values, "");

	dsatm_device.real_dpp.real_class (rcx) = name_idx;

     end;

legal_dev_type: proc returns (bit (1) aligned);

	name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE);
	do name_idx = 0 to hbound (DT_NAME, 1);
	     if name_to_test_for = DT_NAME (name_idx) then return ("1"b);
	end;

	return ("0"b);

     end;

legal_shareability: proc returns (bit (1) aligned);

	name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE);
	do name_idx = 1 to hbound (SH_NAME, 1);
	     if name_to_test_for = SH_NAME (name_idx) then return ("1"b);
	end;

	return ("0"b);

     end;

legal_alloc_unit: proc returns (bit (1) aligned);

	name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE);
	do name_idx = 1 to hbound (AU_NAME, 1);
	     if name_to_test_for = AU_NAME (name_idx) then return ("1"b);
	end;

	return ("0"b);

     end;

set_alloc_unit: proc;

	dsatm_device.alloc_unit = dsatm_device.alloc_unit | AU_VALUE (name_idx);

     end;

legal_line_overflow: proc returns (bit (1) aligned);

	name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE);
	do name_idx = 2 to hbound (LO_NAME, 1);
	     if name_to_test_for = LO_NAME (name_idx) then return ("1"b);
	end;

	return ("0"b);

     end;

legal_page_overflow: proc returns (bit (1) aligned);

	name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE);
	do name_idx = 2 to hbound (PO_NAME, 1) - 1;
	     if name_to_test_for = PO_NAME (name_idx) then return ("1"b);
	end;

	return ("0"b);

     end;

legal_char_encoding: proc returns (bit (1) aligned);

	name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE);
	do name_idx = 1 to hbound (CE_NAME, 1);
	     if name_to_test_for = CE_NAME (name_idx) then return ("1"b);
	end;

	return ("0"b);

     end;

set_char_encoding: proc;

	cex = cex + 1;
	max_values = ltrim (char (hbound (dsatm_device.char_encoding, 1)));
	if cex > hbound (dsatm_device.char_encoding, 1) then call statement_error (56, max_values, "");

	dsatm_device.char_encoding (cex) = name_idx;

     end;

legal_char_set: proc returns (bit (1) aligned);

	name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE);
	do name_idx = 1 to hbound (CS_NAME, 1);
	     if name_to_test_for = CS_NAME (name_idx) then return ("1"b);
	end;

	return ("0"b);

     end;

set_char_set: proc;

	csx = csx + 1;
	max_values = ltrim (char (hbound (dsatm_device.char_set, 1)));
	if csx > hbound (dsatm_device.char_set, 1) then call statement_error (56, max_values, "");

	dsatm_device.char_set (csx) = name_idx;

     end;

legal_char_subset: proc returns (bit (1) aligned);

	name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE);
	do name_idx = 1 to hbound (CSS_NAME, 1);
	     if name_to_test_for = CSS_NAME (name_idx) then return ("1"b);
	end;

	return ("0"b);

     end;

set_char_subset: proc;

	cssx = cssx + 1;
	max_values = ltrim (char (hbound (dsatm_device.char_subset, 1)));
	if cssx > hbound (dsatm_device.char_subset, 1) then call statement_error (56, max_values, "");

	dsatm_device.char_subset (cssx) = name_idx;

     end;

legal_char_font: proc returns (bit (1) aligned);

	name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE);
	do name_idx = 1 to hbound (CF_NAME, 1);
	     if name_to_test_for = CF_NAME (name_idx) then return ("1"b);
	end;

	return ("0"b);

     end;

set_char_font: proc;

	cfx = cfx + 1;
	max_values = ltrim (char (hbound (dsatm_device.char_font, 1)));
	if cfx > hbound (dsatm_device.char_font, 1) then call statement_error (56, max_values, "");

	dsatm_device.char_font (cfx) = name_idx;

     end;

legal_nat_lang: proc returns (bit (1) aligned);

	name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE);
	do name_idx = 1 to hbound (NL_NAME, 1);
	     if name_to_test_for = NL_NAME (name_idx) then return ("1"b);
	end;

	return ("0"b);

     end;

set_nat_lang: proc;

	nlx = nlx + 1;
	max_values = ltrim (char (hbound (dsatm_device.nat_lang, 1)));
	if nlx > hbound (dsatm_device.nat_lang, 1) then call statement_error (56, max_values, "");

	dsatm_device.nat_lang (nlx) = name_idx;

     end;

legal_compression: proc returns (bit (1) aligned);

	name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE);
	do name_idx = 1 to hbound (CA_NAME, 1);
	     if name_to_test_for = CA_NAME (name_idx) then return ("1"b);
	end;

	return ("0"b);

     end;

set_compression: proc;

	cax = cax + 1;
	max_values = ltrim (char (hbound (dsatm_device.compression, 1)));
	if cax > hbound (dsatm_device.compression, 1) then call statement_error (56, max_values, "");

	dsatm_device.compression (cax) = name_idx;

     end;

legal_attd: proc returns (bit (1) aligned);
dcl  attx fixed bin;

	attx = 0;
	go to common;

legal_att1: entry returns (bit (1) aligned);

	attx = 1;
	go to common;

common:

	if /* case */ token_value = "BREAK" | token_value = "break" then
	     dsatm_device.attentions.attn (attx).invocation.break = "1"b;

	else if token_value = "SEC_DIALOG" | token_value = "sec_dialog" then
	     dsatm_device.attentions.attn (attx).invocation.sec_dialog = "1"b;

	else if tty_char () | (token.quoted_string & token.Lvalue = 2) then do;
	     dsatm_device.attentions.attn (attx).invocation.string = "1"b;
	     dsatm_device.attentions.attn (attx).string_value (1) = token_value;
	end;

	else return ("0"b);

	return ("1"b);

     end;

finish_dsatm_device: proc;

dcl  p ptr;

	p = get_misc_space (currentsize (dsatm_device));
	extended_tables.tables_rp (DSATM_DEVICE_RP) = bin (rel (p));
	p -> dsatm_device = dsatm_device;
	dsatmdevp = p;

	return;

     end /* finish_dsatm_device */;

define_special: proc;

	call define_table (SPEC_TYPE, special_tables_ptr, spec_offset);
	max_output_escapes,
	     input_escapes.len = 0;
	return;
     end /* define_special */;


check_special: proc;

	if tablep -> special_chars.nl_seq.count = 0
	then call semant_error (23, table_names.name (defined), "new_line");

	if tablep -> special_chars.cr_seq.count = 0 &
	     tablep -> special_chars.bs_seq.count = 0
	then call semant_error (23, table_names.name (defined), "carriage_return and backspace");

	tablep -> special_chars.escape_length = max_output_escapes;
	tablep -> special_chars.not_edited_escapes = addr (not_edited) -> escapes;
	tablep -> special_chars.edited_escapes = addr (edited) -> escapes;
	tablep -> special_chars.input_escapes.len = input_escapes.len;
	tablep -> special_chars.input_escapes.str = input_escapes.str;
	tablep -> special_chars.input_results.str = input_results.str;

	length_in_words = divide (length (unspec (tablep -> special_chars)) + 35, 36, 17);
	spec_offset = spec_offset + length_in_words;

	return;
     end /* check_special */;


copy_string: proc (targetp);

dcl  targetp ptr;
dcl  1 target aligned based (targetp),
       2 offset fixed bin (18),
       2 len fixed bin;

dcl  stringp ptr;
dcl  stringl fixed bin;
dcl  target_string char (stringl) based aligned;
dcl  target_string_array (stringl) char (1) based;

	stringl = token.Lvalue + 2;
	stringp = get_misc_char_space (stringl);
	target.len = token.Lvalue;
	target.offset = bin (rel (stringp));

	stringp -> target_string = token_value;
	addr (stringp -> target_string_array (stringl - 1)) -> based_fb17 = 0;

	return;
     end /* copy_string */;


push_rep: proc;

/* for starting repetition factors in string specifications */

	if rep_depth >= max_rep_depth
	then do;
	     call ERROR (37);
	     rep_error = "1"b;
	     return;
	end;

	if token.Nvalue <= 0
	then do;
	     call statement_error (36, token_value, "");
	     rep_error = "1"b;
	     return;
	end;

	rep_depth = rep_depth + 1;
	rep_factor (rep_depth) = token.Nvalue;

	if token.Nvalue > 1
	then do;
	     rep_used = "1"b;
	     addr (unexpanded (unexp_char_index)) -> based_fb17 = -token.Nvalue;
	     unexp_char_index = unexp_char_index + 2;
	     rep_start (rep_depth) = exp_char_index;
	end;

	return;
     end /* push_rep */;


pop_rep: proc;

/* processes ">" at end of repeated spec */

	if rep_depth <= 0
	then do;
	     call ERROR (38);
	     rep_error = "1"b;
	     return;
	end;

	if rep_factor (rep_depth) > 1
	then do;
	     addr (unexpanded (unexp_char_index)) -> based_fb17 = -1;
	     unexp_char_index = unexp_char_index + 2;

	     rep_length = exp_char_index - rep_start (rep_depth);
	     rep_item = substr (exp_string, rep_start (rep_depth), rep_length);

	     do i = 2 to rep_factor (rep_depth);	/* copy the string the requisite number of times */
		substr (exp_string, exp_char_index, rep_length) = rep_item;
		exp_char_index = exp_char_index + rep_length;
	     end;
	end;

	rep_depth = rep_depth - 1;
	return;
     end /* pop_rep */;


insert_single_char: proc (n);

dcl  n fixed bin (18);

	expanded (exp_char_index) = n;
	unexpanded (unexp_char_index) = n;
	exp_char_index = exp_char_index + 1;
	unexp_char_index = unexp_char_index + 1;
	return;

     end insert_single_char;

insert_quoted_string: proc;

dcl  i fixed bin;
dcl  c char (1);

	do i = 1 to token.Lvalue;
	     c = substr (token_value, i, 1);
	     call insert_single_char (rank (c));
	end;
	return;

     end insert_quoted_string;

video_encode_pad: proc (time);

dcl  time fixed bin (35);

	tty_video_seq.cpad_present = "1"b;
	if time < 100 then do;
	     call ERROR (48);
	     return;
	end;
	tty_video_seq.cpad = divide (time + 99, 100, 18, 0);
	return;

     end video_encode_pad;

store_string: proc (targetp);

/* sets up pointer and length of string specified in octal */

dcl  targetp ptr;

dcl  1 target based (targetp) aligned,
       2 offset fixed bin (18),
       2 len fixed bin;

dcl  target_string char (stringl) based;
dcl  target_string_array (stringl) char (1) based;
dcl  stringl fixed bin;
dcl  stringp ptr;

	if rep_depth ^= 0
	then do;
	     call ERROR (38);
	     return;
	end;

	exp_char_index = exp_char_index - 1;
	unexp_char_index = unexp_char_index - 1;

	stringl = exp_char_index + 2;
	if rep_used then stringl = stringl + unexp_char_index;
	stringp = get_misc_char_space (stringl);

	target.len = exp_char_index;
	target.offset = bin (rel (stringp));

	substr (stringp -> target_string, 1, exp_char_index) = substr (exp_string, 1, exp_char_index);

	if ^rep_used				/* in this case, no need to store unexpanded version */
	then
	     addr (stringp -> target_string_array (exp_char_index + 1)) -> based_fb17 = -1;

	else do;
	     addr (stringp -> target_string_array (exp_char_index + 1)) -> based_fb17 = unexp_char_index;
	     substr (stringp -> target_string, exp_char_index + 3, unexp_char_index) =
		substr (unexp_string, 1, unexp_char_index);
	end;

	return;
     end /* store_string */;


set_table: proc (target, table_type);

dcl  target fixed bin (18);
dcl  table_type fixed bin;

	do i = 1 to n_table_names;
	     if table_names.name (i) = token_value
	     then if table_names.type (i) ^= table_type
		then do;
		     call statement_error (22, token_value, table_types (table_names.type (i)));
		     target = 0;
		     return;
		end;

		else do;
		     target = i;			/* use index into names table for now */
		     return;
		end;
	end;

/* didn't find it, have to add entry */

	n_table_names = i;				/* i.e., n_tables_names + 1 */
	table_names.name (n_table_names) = token_value;
	table_names.type (n_table_names) = table_type;
	table_names.offset (n_table_names) = -1;
	target = n_table_names;

	return;
     end /* set_table */;


copy_type: proc;

dcl  hold_extended_tables_rp fixed bin (18);

/* for like attribute */

	temp_ttep = addr (ttt.tt_entries (token.Nvalue));
	real_name = tte.name;			/* hang on to name of new type */
	hold_extended_tables_rp = tte.extended_tables_rp;
	tte = temp_ttep -> tte;
	tte.name = real_name;			/* put correct name back */
	tte.like_type = token.Nvalue;			/* display_ttt needs this */
	tte.bauds_overridden, tte.delay_overridden (*) = "0"b;
	if tte.extended_tables_rp ^= 0 then do;		/* must have one of our own */
	     tte.extended_tables_rp = hold_extended_tables_rp;
	     call set_extended;
	     extended_tables = ptr (misc_tables_ptr, temp_ttep -> tte.extended_tables_rp) -> extended_tables;
	end;
	return;
     end /* copy_type */;


make_delay_entry: proc (baud_rate);

/* when a new baud rate specified, set up an array of delay values for it */

dcl  baud_rate fixed bin;

	if delay_stmt
	then do;
	     if ^baud_error_printed
	     then do;
		call statement_error (24, tte.name, "");
		baud_error_printed = "1"b;
	     end;
	     return;
	end;

	if baudx = 1				/* first one for this terminal type */
	then do;
	     tte.delay_rp = next_misc_offset;
	     delay_tablep = ptr (misc_tables_ptr, next_misc_offset);
	     next_misc_offset = next_misc_offset + 1;
	     delay_table.n_bauds = 1;
	     if tte.like_type ^= 0
	     then tte.bauds_overridden = "1"b;
	end;

	else delay_table.n_bauds = delay_table.n_bauds + 1;

	delay_table.baud_rate (delay_table.n_bauds) = baud_rate;
	delay_table.version (delay_table.n_bauds) = DELAY_VERSION;
	delay_table.mbz (delay_table.n_bauds) = 0;	/* "default" word */

	next_misc_offset = next_misc_offset + 9;	/* for baud rate, version, default word, 6 delay values */
	return;
     end /* make_delay_entry */;


set_delay: proc;

	if tte.delay_rp = 0
	then do;
	     if n_dft_bauds <= 0
	     then do;
		if ^delay_error_printed
		then do;
		     call statement_error (25, tte.name, "");
		     delay_error_printed = "1"b;
		end;
		return;
	     end;

	     do baudx = 1 to n_dft_bauds;
		call make_delay_entry (dft_bauds (baudx));
	     end;
	end;

	delay_tablep = ptr (misc_tables_ptr, tte.delay_rp);

	if tte.like_type ^= 0			/* overriding "like" */
	then if ^tte.bauds_overridden			/* but using same bauds statement */
	     then do;
		if ^delay_stmt			/* first one */
		then do;				/* copy delay table of original type */
		     new_delay_table_ptr = ptr (misc_tables_ptr, next_misc_offset);
		     new_delay_table_ptr -> delay_table.n_bauds = delay_table.n_bauds;
		     do baudx = 1 to delay_table.n_bauds;
			new_delay_table_ptr -> delay_table.delay_array (baudx) =
			     delay_table.delay_array (baudx);
		     end;

		     tte.delay_rp = next_misc_offset;
		     next_misc_offset = next_misc_offset + 1 + 9 * (baudx - 1);
		     delay_tablep = new_delay_table_ptr;
		end;

		tte.delay_overridden (delayx) = "1"b;
	     end;

	delay_stmt = "1"b;				/* we've got one now */
	n_spec = n_spec + 1;

	if n_spec > delay_table.n_bauds		/* more values than we have room for */
	then do;
	     if ^delay_error_printed
	     then do;
		call ERROR (26);
		delay_error_printed = "1"b;
	     end;
	     return;
	end;

	if delayx = 2 | delayx = 4
	then cur_delay_value = addr (floating_delay_value) -> based_fb; /* fake the floating ones */
	else cur_delay_value = token.Nvalue;

	delay_table.delay_array (n_spec).delays (delayx) = cur_delay_value;
	return;
     end /* set_delay */;


set_up_answerback: proc;

	if n_answerbacks = 0
	then answerback_entry_ptr = ans_back_table_ptr;
	else answerback_entry_ptr = addrel (answerback_entry_ptr,
		divide (length (unspec (answerback_entry)) + 35, 36, 17, 0));
	n_answerbacks = n_answerbacks + 1;
	answerback_entry.next,
	     answerback_entry.term_type_index = 0;

	ansbck_char_index = 1;
	return;
     end /* set_up_answerback */;


check_for_any: proc;

	if temp_dftte (default_count).baud ^= 0 |
	     temp_dftte (default_count).line_type ^= 0
	then call ERROR (33);
	return;
     end /* check_for_any */;

/* Get current token numeric value in character form */

make_char: proc returns (char (1));

	return (byte (token.Nvalue));

     end make_char;

/* get some space in the misc_tables segment */

get_misc_space: proc (n) returns (ptr);

dcl  n fixed bin;
dcl  p ptr;

	p = ptr (misc_tables_ptr, next_misc_offset);
	next_misc_offset = next_misc_offset + n;
	return (p);

     end get_misc_space;

get_misc_char_space: proc (n) returns (ptr);

dcl  n fixed bin;

	return (get_misc_space (divide (n + 3, 4, 17, 0)));

     end get_misc_char_space;

/* keep track of relocations of stuff in misc space */

register_misc_reloc: proc (n);

dcl  n fixed bin (18);

	misc_relocs_count = misc_relocs_count + 1;
	misc_relocs (misc_relocs_count) = addr (n);
	return;

     end register_misc_reloc;

/* preform the relocations */

perform_misc_relocs: proc;

dcl  reloc_abort condition;
dcl  i fixed bin;
dcl  p ptr;
dcl  based_rp fixed bin (18) based (p);
dcl  temp_rp fixed bin (18);

	do i = 1 to misc_relocs_count;
	     p = misc_relocs (i);
	     if baseno (tttp) = baseno (p) then		/* in ttt segment */
		call add_increment (based_rp);
	     else if baseno (misc_tables_ptr) = baseno (p) then do;
		temp_rp = bin (rel (p));
		call add_increment (temp_rp);
		p = ptr (tttp, temp_rp);
		call add_increment (based_rp);
	     end;
	     else signal reloc_abort;
	end;
	return;

     end perform_misc_relocs;

/* Function key table routines */

define_fkey_table: proc;

	call define_table (FKEY_TYPE, fkey_tables_ptr, fkey_table_offset);
	function_key_data_ptr = addr (extended_tables_work.table);

/* Initialize */

	unspec (function_key_data.sequence) = "0"b;
	unspec (function_key_data.cursor_motion_keys) = "0"b;
	function_key_data_highest = -1;
	function_key_data.version = function_key_data_version_1;
	seqs_index = 0;
	extended_tables_work.seqs = "";

     end define_fkey_table;

finish_fkey_table: proc;

dcl  table_p ptr;
dcl  seq_p ptr;

	function_key_data.highest = function_key_data_highest;
	if function_key_data.highest < 0		/* no function keys defined */
	then do;
	     function_key_data.highest = 0;
	     function_key_data.function_keys (0, *) = 0;
	end;
	else do i = 1 to function_key_data.highest;
	     key_info_ptr = addr (function_key_data.function_keys (i, 0));
	     if key_info.sequence_length = 0
	     then call semant_error (51, cur_table_name, ltrim (char (i)));
	end;
	table_p = ptr (fkey_tables_ptr, fkey_table_offset);
	seq_p = ptr (fkey_tables_ptr, fkey_table_offset + currentsize (function_key_data));
	function_key_data.seq_len = seqs_index;
	function_key_data.seq_ptr = addr (extended_tables_work.seqs);
	table_p -> function_key_data = function_key_data;
	seq_p -> function_key_seqs = function_key_seqs;
	tablep -> function_key_data.seq_ptr = seq_p;
	fkey_table_offset = fkey_table_offset + currentsize (function_key_data) + currentsize (function_key_seqs);
	if mod (fkey_table_offset, 2) > 0
	then fkey_table_offset = fkey_table_offset + 1;

     end finish_fkey_table;

start_fkey_seq: proc (a_ptr);

dcl  a_ptr ptr;

	temp_key_infop = a_ptr;
	temp_key_index = 0;
	exp_char_index, unexp_char_index = 1;

     end start_fkey_seq;

end_fkey_seq: proc;

	if exp_char_index > 1
	then do;
	     if temp_key_index = KEY_PLAIN &
		temp_key_info (temp_key_index).sequence_length > 0
	     then call statement_error (53, cur_table_name, "");
	     temp_key_info (temp_key_index).sequence_length = exp_char_index - 1;
	     temp_key_info (temp_key_index).sequence_index = seqs_index + 1;
	     seqs_index = seqs_index + temp_key_info (temp_key_index).sequence_length;
	     substr (extended_tables_work.seqs,
		temp_key_info (temp_key_index).sequence_index,
		temp_key_info (temp_key_index).sequence_length)
		= substr (exp_string, 1, temp_key_info (temp_key_index).sequence_length);
	end;
	temp_key_index = temp_key_index + 1;
	exp_char_index, unexp_char_index = 1;

     end end_fkey_seq;

init_fkey_area: proc (curr_index);

dcl  curr_index fixed bin;
dcl  j fixed bin;

	if curr_index > function_key_data_highest
	then do;
	     do i = function_key_data_highest + 1 to curr_index;
		do j = lbound (function_key_data.function_keys, 2) to hbound (function_key_data.function_keys, 2);
		     unspec (function_key_data.function_keys (i, j)) = "0"b;
		end;
	     end;
	     function_key_data_highest = curr_index;
	end;

     end init_fkey_area;

/* ERROR CONTROL TABLE */

dcl  1 error_control_table (56) aligned int static options (constant),
       2 severity fixed bin (17) unal init (
	  3,					/* 1 */
	  1,					/* 2 */
	  (4) 3,					/* 3-6 */
	  3,					/* 7 */
	  (4) 3,					/* 8-11 */
	  1,					/* 12 */
	  (10) 3,					/* 13-22 */
	  1,					/* 23 */
	  (8) 3,					/* 24-31 */
	  (2) 1,					/* 32-33 */
	  2,					/* 34 */
	  1,					/* 35 */
	  (13) 3,					/* 36-48 */
	  1,					/* 49 */
	  3,					/* 50 */
	  3,					/* 51 */
	  3,					/* 52 */
	  1,					/* 53 */
	  1,					/* 54 */
	  (2) 3),					/* 55-56 */

       2 Soutput_stmt bit (1) unal init (

	  "0"b,					/* 1 */
	  (5) (1)"1"b,				/* 2-6 */
	  "0"b,					/* 7 */
	  (3) (1)"1"b,				/* 8-10 */
	  (3) (1)"0"b,				/* 11-13 */
	  (9) (1)"1"b,				/* 14-22 */
	  "0"b,					/* 23 */
	  (3) (1)"1"b,				/* 24-26 */
	  (7) (1)"0"b,				/* 27-33 */
	  "1"b,					/* 34 */
	  "0"b,					/* 35 */
	  (5) (1)"1"b,				/* 36-40 */
	  "0"b,					/* 41 */
	  "1"b,					/* 42 */
	  (2) (1)"0"b,				/* 43-44 */
	  (2) (1)"1"b,				/* 45-46 */
	  "0"b,					/* 47 */
	  (3) (1)"1"b,				/* 48-50 */
	  "0"b,					/* 51 */
	  (2) (1)"1"b,				/* 52-53 */
	  "0"b,					/* 54 */
	  (2) (1)"1"b),				/* 55-56 */

       2 message char (100) varying init (

	  "TTF is empty.",				/* 1 */
	  "Unrecognized mode ""^a"" specified.",	/* 2 */
	  "Invalid editing char ""^a"" specified.",	/* 3 */
	  "Value must be yes or no.",			/* 4 */
	  "Keyword ""^a"" unrecognized or out of order.", /* 5 */
	  "Syntax error.",				/* 6 */
	  "Unexpected end of TTF encountered.",		/* 7 */
	  "Invalid baud rate ^a specified.",		/* 8 */
	  "Invalid delay value ^a specified.",		/* 9 */
	  "Invalid line type ^a specified.",		/* 10 */
	  "Too many entries in table ""^a"".",		/* 11 */
	  "Table ""^a"" has fewer than 128 entries. Remainder have been set to 0.", /* 12 */
	  "Table ""^a"" contains invalid entry ""^a"".",	/* 13 */
	  """^a"" is not a valid indicator value.",	/* 14 */
	  "More than 3 items in a sequence.",		/* 15 */
	  """^a"" is not a valid sequence element.",	/* 16 */
	  """^a"" is not a valid answerback specification.", /* 17 */
	  "Type ""^a"" has not been defined.",		/* 18 */
	  "The name ""^a"" contains an invalid character.", /* 19 */
	  "Type ""^a"" has already been defined.",	/* 20 */
	  "Table ""^a"" has already been defined.",	/* 21 */
	  "Table ""^a"" has already been specified as a ^a table.", /* 22 */
	  "Table ""^a"" contains a null ^a sequence.",	/* 23 */
	  "A bauds statement appears after a delay statement for terminal type ""^a"".", /* 24 */
	  "No baud rates have been specified for terminal type ""^a"".", /* 25 */
	  "More delay values than baud rates specified.", /* 26 */
	  "Text follows the end statement.",		/* 27 */
	  "Table ""^a"" has been referenced but not defined.", /* 28 */
	  "Type ""^a"" has been referenced in default types table but not defined.", /* 29 */
	  "Type ""^a"" has an output conversion table but no special table.", /* 30 */
	  "Type ""^a"" uses conversion table ""^a"", which contains an escape not represented in the special table.", /* 31 */
	  "No default_types statement specified.",	/* 32 */
	  "Last entry in default_types statement does not specify ""any any"".", /* 33 */
	  "Unrecognized preaccess command ^a specified.", /* 34 */
	  "No type specified for preaccess command ^a.",	/* 35 */
	  "Invalid repetition factor ^a specified.",	/* 36 */
	  "Repetition factors nested too deep.",	/* 37 */
	  "Unbalanced brackets.",			/* 38 */
	  "Name ""^a"" is too long.",			/* 39 */
	  "Mode delimiter missing at or before ""^a"".",	/* 40 */
	  "Entry for type ^a contains one null and one non-null framing character.", /* 41 */
	  "Attempt to specify incompatible output flow control protocols.", /* 42 */
	  "Inconsistency in specification of output flow control for type ^a.", /* 43 */
	  "Inconsistency in specification of input flow control for type ^a.", /* 44 */
	  "Invalid token ""^a"" in video control sequence.", /* 45 */
	  "Invalid token ""^a"" in video argument sequence.", /* 46 */
	  "Video control sequence too long or empty.",	/* 47 */
	  "Unexpressible padding time: ^a.",		/* 48 */
	  "This character specification will convert invalidly without -ck1dig. Precede it by a zero. ^a", /* 49 */
	  "Invalid token ""^a"" in function key control sequence.", /* 50 */
	  "Table ""^a"", missing function key data for key(^a)", /* 51 */
	  "Table ""^a"", too many control sequences specified for a function key.", /* 52 */
	  "Table ""^a"", function key control sequence already defined.", /* 53 */
	  "Invalid protocol ""^a"" specified.",		/* 54 */
	  "Option not defined for this keyword: ^a.",	/* 55 */
	  "Maximum number of allowable options ""^a"" exceeded."), /* 56 */

       2 brief_message char (30) varying init (

	  "",					/* 1 */
	  (2) (1)"^a",				/* 2-3 */
	  "",					/* 4 */
	  "^a",					/* 5 */
	  (2) (1)"",				/* 6-7 */
	  (5) (1)"^a",				/* 8-12 */
	  """^a"" contains ""^a""",			/* 13 */
	  "^a",					/* 14 */
	  "",					/* 15 */
	  (6) (1)"^a",				/* 16-21 */
	  "^a is ^a",				/* 22 */
	  "^a has null ^a",				/* 23 */
	  (2) (1)"^a",				/* 24-25 */
	  (2) (1)"",				/* 26-27 */
	  (3) (1)"^a",				/* 28-30 */
	  "^a uses ^a",				/* 31 */
	  (2) (1)"",				/* 32-33 */
	  (3) (1)"^a",				/* 34-36 */
	  (2) (1)"",				/* 37-38 */
	  (3) (1)"^a",				/* 39-41 */
	  "",					/* 42 */
	  (4) (1)"^a",				/* 43-46 */
	  "",					/* 47 */
	  (3) (1)"^a",				/* 48-50 */
	  "Table ""^a"" - key(^a)",			/* 51 */
	  (2) (1)"Table ""^a""",			/* 52-53 */
	  "^a",					/* 54 */
	  "Option not defined: ""^a"".",		/* 55 */
	  "Max number of options is ^a.");		/* 56 */




		    disk_usage_stat.pl1             10/27/83  1614.3rew 10/27/83  1441.6      154422



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


disk_usage_stat: proc;

/* program to do some disk statistics
   THVV
   Fixed up by R. Holmsedt and C. Hornig, September 1979.
   */

dcl  path char (168),				/* root of tree */
     level fixed bin,				/* current depth relative to root. */
     ctime char (24),
    (co, dp) char (128),				/* titles for report */
     junk char (1),
    (i, j, k) fixed bin,
    (t1, t2, t3) fixed bin,
     half fixed bin,				/* Half the number of records. for median ages. */
     rolder (0: 90) fixed bin,
     folder (0: 90) fixed bin,
     nxt_midnight fixed bin (71),
     slp ptr,
     lth fixed bin (24),
     NL char (1) int static init ("
"),
     kk fixed bin,
     gap fixed bin,
     ap ptr,
     al fixed bin,
     bchr char (al) unaligned based (ap),
     ec fixed bin (35);

dcl (nsegs (0: 15),
     ndirs (0: 15),
     nlinks (0: 15),
     nrecs (0: 15),
     ndrecs (0: 15),
     nnames (0: 15)) fixed bin,
    (mscale, maxlv) fixed bin,
     nscale fixed bin,
     urage (0: 90) fixed bin,
     ufage (0: 90) fixed bin,
     mrage (0: 90) fixed bin,
     mfage (0: 90) fixed bin,
     max_seg_size fixed bin,
     rsize (0: 256) fixed bin,
     n_ents_w_i_names (0: 2048) fixed bin,
     n_dirs_w_i_names (0: 2048) fixed bin,
     tnnames fixed bin,
     max_names_in_dir fixed bin,
     max_names_on_ent fixed bin,
     current_pathname char (168),
     path_with_max_names char (168),
     dir_with_max_names char (168),
     bigseg_name char (168),
     bigdir fixed bin,				/* Size of biggest dir, in records. */
     bigdir_name char (168),
     lrm fixed bin,					/* Age of least-recently-modified seg */
     lrm_segname char (168),
     lru fixed bin,					/* Age of least-recently-used seg */
     lru_segname char (168),
     pending_names (0: 15) fixed bin,			/* Pushdown list */
     savlvl fixed bin;				/* Level in pdl */

dcl  has_starstar bit (1) init ("0"b),
     starname_name (128) char (32),
     starname_type (128) fixed bin,
     starname_recs (128) fixed bin,
     starname_fils (128) fixed bin,
     starname_lnks (128) fixed bin,
     nsfx fixed bin;

dcl  xxx char (120) int static init ((120)"x");

dcl  datebin_$this_midnight entry (fixed bin (71)),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     system_info_$titles entry (char (*), char (*), char (*), char (*)),
     sweep_disk_ entry (char (168), entry),
     absolute_pathname_ entry (char (*), char (*), fixed bin (35)),
     check_star_name_$entry entry (char (*), fixed bin (35)),
     match_star_name_ entry (char (*), char (*), fixed bin (35)),
    (ioa_, ioa_$rsnnl) entry options (variable),
     com_err_ entry options (variable),
     date_time_ entry (fixed bin (71), char (*)),
     hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)),
     get_wdir_ entry () returns (char (168)),
     hcs_$terminate_noname entry (ptr, fixed bin (35));

dcl  bcs char (262144) based (slp);

dcl (binary, clock, divide, substr, addr, null, index, fixed) builtin;

/* ======================================================= */

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then path = ">";
	else do;
	     call absolute_pathname_ (bchr, path, ec);
	     if ec ^= 0 then do;
		call com_err_ (ec, "disk_usage_stat", "^a", bchr);
		return;
	     end;
	end;

	call datebin_$this_midnight (nxt_midnight);

	bigdir,
	     lrm, lru,
	     mscale,
	     maxlv, savlvl,
	     nsegs (*), nlinks (*), ndirs (*),
	     pending_names (*),
	     nrecs (*), ndrecs (*), nnames (*),
	     max_seg_size,
	     rsize (*),
	     urage (*), mrage (*), ufage (*), mfage (*),
	     n_ents_w_i_names (*), n_dirs_w_i_names (*),
	     starname_recs (*), starname_fils (*), starname_lnks (*),
	     tnnames,
	     max_names_in_dir,
	     max_names_on_ent = 0;

	nsfx = 0;
	call hcs_$initiate_count ((get_wdir_ ()), "starname_list", "", lth, 0, slp, ec);
	if slp = null then go to no_sl;
	lth = divide (lth, 9, 17, 0);
	kk = 1;
	do k = 1 to lth while (nsfx < 100);
	     if substr (bcs, k, 1) = NL then do;
		if substr (bcs, kk, 1) = "&" then go to skipline; /* Skip comment. */
		nsfx = nsfx + 1;
		starname_name (nsfx) = substr (bcs, kk, k-kk);
		call check_star_name_$entry (starname_name (nsfx), ec);
		if ec >= 0 & ec <= 2
		then starname_type (nsfx) = ec;
		else do;
		     call com_err_ (ec, "disk_usage_stat", "^a", starname_name (nsfx));
		     starname_type (nsfx) = 0;
		end;
		if starname_type (nsfx) = 2 then has_starstar = "1"b;
skipline:		kk = k + 1;
	     end;
	end;
	call hcs_$terminate_noname (slp, ec);
no_sl:	if ^has_starstar then do;
	     nsfx = nsfx + 1;
	     starname_name (nsfx) = "**";
	     starname_type (nsfx) = 2;
	end;

/* Now, go to work. Call disk sweeper program */

	call sweep_disk_ (path, counter);

/* On return from sweep of hierarchy, print the report. */

	do while (savlvl > 0);
	     i = pending_names (savlvl);
	     n_dirs_w_i_names (i) = n_dirs_w_i_names (i) + 1;
	     if i > max_names_in_dir then do;
		max_names_in_dir = i;
		call set_dwmn ();
	     end;
	     savlvl = savlvl - 1;
	end;

	call date_time_ ((clock ()), ctime);

	call system_info_$titles (junk, junk, co, dp);
	call ioa_ ("^|^a^/^/^-^a", co, dp);
	call ioa_ ("^/Multics disk usage for ""^a"" - ^a", path, ctime);

	call ioa_ ("^/Depth^3xSegs^3xDirs  Links^3xRecs  Dir Recs  Names^/");
	do i = 0 to maxlv;
	     call ioa_ ("^5d ^6d ^6d ^6d ^6d ^9d ^6d", i,
		nsegs (i), ndirs (i), nlinks (i), nrecs (i), ndrecs (i), nnames (i));
	     if i > 0 then do;
		nsegs (0) = nsegs (0) + nsegs (i);
		ndirs (0) = ndirs (0) + ndirs (i);
		nlinks (0) = nlinks (0) + nlinks (i);
		nrecs (0) = nrecs (0) + nrecs (i);
		ndrecs (0) = ndrecs (0) + ndrecs (i);
		nnames (0) = nnames (0) + nnames (i);
	     end;
	end;
	call ioa_ ("-----  -----  -----  -----  -----  --------  -----");
	call ioa_ ("Total ^6d ^6d ^6d ^6d ^9d ^6d",
	     nsegs (0), ndirs (0), nlinks (0), nrecs (0), ndrecs (0), nnames (0));

	if nsegs (0) = 0 then do;
	     call ioa_ ("^/No segments exist for ""^a""", path);
	end;
	else
	call ioa_ ("^/^10xAverage segment size:^7x^7.1f records", (1e0*nrecs (0))/nsegs (0));
	if ndirs (0) = 0 then do;
	     call ioa_ ("^/No directories exist under ""^a""", path);
	     go to nodirs;
	end;
	else
	call ioa_ ("^10xAverage directory size:^5x^7.1f records", (1e0*ndrecs (0))/ndirs (0));
	call ioa_ ("^10xAverage segments/directory: ^7.1f", (1e0*nsegs (0))/ndirs (0));
	call ioa_ ("^10xAverage links/directory:^4x^7.1f", (1e0*nlinks (0))/ndirs (0));
	call ioa_ ("^10xAverage names/directory:^4x^7.1f", (1e0*nnames (0))/ndirs (0));
nodirs:
	half = divide (nsegs (0), 2, 17, 0);		/* Get half the number of segments. */
	t1, t2, t3 = 0;
	do i = 90 to 0 by -1;
	     t1, rolder (i) = t1 + urage (i);
	     t2, folder (i) = t2 + ufage (i);
	     if t2 > half then if t3 = 0 then t3 = i;
	end;
	if nsegs (0) = 0 then goto fini;
	else
	call set_scale (100, t1, nscale);
	call ioa_ ("^/Distribution by date of last reference");
	call ioa_ ("^/^10xMedian number of days since last reference is ^d.", t3);
	if lru = 0 then lru_segname = "(none)";		/* puts out junk otherwise */
	call ioa_ ("^10xLeast recently used segment (^d days) is ^a", lru, lru_segname);
	call ioa_ ("^/Age^3xSegs  Older^3xRecs  Older  Scale: one ""x"" is ^d records", nscale);
	do i = 0 to 90;
	     call ioa_ ("^3d^7d^7d^7d^7d  ^a", i, ufage (i), folder (i), urage (i), rolder (i),
		substr (xxx, 1, divide (rolder (i)+nscale-1, nscale, 17, 0)));
	end;

	t1, t2, t3 = 0;
	do i = 90 to 0 by -1;
	     t1, rolder (i) = t1 + mrage (i);
	     t2, folder (i) = t2 + mfage (i);
	     if t2 > half then if t3 = 0 then t3 = i;
	end;
	call set_scale (100, t1, nscale);
	call head;
	call ioa_ ("^/Distribution by date of last modification");
	call ioa_ ("^/^10xMedian number of days since last modification is ^d.", t3);
	if lrm = 0 then lrm_segname = "(none)";		/* puts out junk if =0 days */
	call ioa_ ("^10xLeast recently modified segment (^d days) is ^a", lrm, lrm_segname);
	call ioa_ ("^/Age^3xSegs  Older^3xRecs  Older  Scale: one ""x"" is ^d records", nscale);
	do i = 0 to 90;
	     call ioa_ ("^3d^7d^7d^7d^7d  ^a", i, mfage (i), folder (i), mrage (i), rolder (i),
		substr (xxx, 1, divide (rolder (i)+nscale-1, nscale, 17, 0)));
	end;

	call head;
	call ioa_ ("^/Distribution by segment size: ^d records total", nrecs (0));
	call ioa_ ("^/^10xLargest segment (^d recs) is ^a", max_seg_size, bigseg_name);
	if ndirs (0) = 0
	then call ioa_ ("^/No other directories exist under ""^a""", path);
	else call ioa_ ("^10xLargest directory (^d recs) is ^a", bigdir, bigdir_name);
	call set_scale (120, mscale, mscale);
	call ioa_ ("^/   K  Count  Scale: one ""x"" is ^d segments", mscale);
	gap = 0;
	do i = 0 to max_seg_size;
	     if rsize (i) = 0 then do;		/* Check for gap. */
		gap = gap + 1;
		go to sgap1;
	     end;
	     if gap > 0 then do;
		if gap < 4 then do j = (i-gap) to (i-1);
		     call ioa_ ("^4d^7d", j, 0);
		end;
		else call ioa_ ("^4x(^d)", gap);
		gap = 0;
	     end;
	     call ioa_ ("^4d^7d  ^a", i, rsize (i),	/* print row of x's */
		substr (xxx, 1, divide (rsize (i)+mscale-1, mscale, 17, 0)));
sgap1:	end;

	call head;
	call ioa_ ("^/Distribution by segment name");
	call ioa_ ("^/Name^30xSegs^3xRecs  Links^/");
	t1, t2, t3 = 0;
	do i = 1 to nsfx;
	     call ioa_ ("^32a^6d^7d^7d", starname_name (i), starname_fils (i), starname_recs (i), starname_lnks (i));
	     t1 = t1 + starname_fils (i);
	     t2 = t2 + starname_recs (i);
	     t3 = t3 + starname_lnks (i);
	end;
	call ioa_ ("^/TOTAL^26x^7d^7d^7d", t1, t2, t3);

	call head;
	call ioa_ ("^/Entry distribution by number of names: ^d entries total", nsegs (0) + ndirs (0) + nlinks (0));
	call ioa_ ("^/^10xEntry with most names (^d) is ^a", max_names_on_ent, path_with_max_names);
	t1 = 0;
	do i = 1 to max_names_on_ent;
	     if n_ents_w_i_names (i) > t1 then t1 = n_ents_w_i_names (i);
	end;
	call set_scale (100, t1, nscale);
	call ioa_ ("^/Nnames  Nents  Scale: one ""x"" is ^d entries", nscale);
	gap = 0;
	do i = 1 to max_names_on_ent;
	     if n_ents_w_i_names (i) = 0 then do;	/* Check for gap. */
		gap = gap + 1;
		go to sgap2;
	     end;
	     if gap > 0 then do;
		if gap < 4 then do j = (i-gap) to (i-1);
		     call ioa_ ("^6d^7d", j, 0);
		end;
		else call ioa_ ("^6x(^d)", gap);
		gap = 0;
	     end;
	     call ioa_ ("^6d^7d  ^a", i, n_ents_w_i_names (i),
		substr (xxx, 1, divide (n_ents_w_i_names (i)+nscale-1, nscale, 17, 0)));
sgap2:	end;

	call head;
	call ioa_ ("^/Directory distribution by number of names: ^d directories total", ndirs (0));
	call ioa_ ("^/^10xDirectory containing most names (^d) is ^a", max_names_in_dir, dir_with_max_names);
	t1, t2 = 0;
	do i = 1 to max_names_in_dir;			/* Empty directories are not scanned. */
	     if t1 < n_dirs_w_i_names (i) then t1 = n_dirs_w_i_names (i);
	     t2 = t2 + n_dirs_w_i_names (i);
	end;
	n_dirs_w_i_names (0) = ndirs (0) - t2;
	if t1 < n_dirs_w_i_names (0) then t1 = n_dirs_w_i_names (0);
	call set_scale (100, t1, nscale);
	if ndirs (0) = 0 then goto sgap;		/* attempt to access beyond end of stack if no dirs */
	else
	call ioa_ ("^/Nnames  Ndirs  Scale: one ""x"" is ^d directories", nscale);
	gap = 0;
	do i = 0 to max_names_in_dir;
	     if n_dirs_w_i_names (i) = 0 then do;	/* Check for gap. */
		gap = gap + 1;
		go to sgap;
	     end;
	     if gap > 0 then do;
		if gap < 4 then do j = (i-gap) to (i-1);
		     call ioa_ ("^6d^7d", j, 0);
		end;
		else call ioa_ ("^6x(^d)", gap);
		gap = 0;
	     end;
	     call ioa_ ("^6d^7d  ^a", i, n_dirs_w_i_names (i),
		substr (xxx, 1, divide (n_dirs_w_i_names (i)+nscale-1, nscale, 17, 0)));
sgap:	end;

	return;

/* -------------------------------------------------------- */

counter:	proc (sdn, sen, lvl, een, bptr, nptr);

dcl  sdn char (168),				/* superior dir name */
     sen char (32),					/* dirname */
     lvl fixed bin,					/* distance from root */
     een char (32),					/* entry name */
     bptr ptr,					/* ptr to info structure */
     nptr ptr;					/* ptr to names structure */

dcl  seg_length fixed bin,				/* length of seg in records */
     no_of_names fixed bin,				/* number of names on segment */
     nnames_in_dir fixed bin,				/* number of names in a directory */
     ndays fixed bin,				/* number of days since use or mod */
     date_temp fixed bin (71);			/* date temp */
dcl  ecc fixed bin (35);

dcl 1 branch based (bptr) aligned,			/* thing returned by star_long */
    2 type bit (2) unal,
    2 nname bit (16) unal,
    2 nindex bit (18) unal,
    2 dtm bit (36) unal,
    2 dtu bit (36) unal,
    2 mode bit (5) unal,
    2 pad bit (13) unal,
    2 records bit (18) unal;

	     level = lvl;				/* save in global. */
	     if lvl > maxlv then maxlv = lvl;
	     no_of_names = fixed (branch.nname, 16);
	     nnames (lvl) = nnames (lvl) + no_of_names;
	     n_ents_w_i_names (no_of_names) = n_ents_w_i_names (no_of_names) + 1;
	     do while (lvl < savlvl);
		nnames_in_dir = pending_names (savlvl);
		n_dirs_w_i_names (nnames_in_dir) = n_dirs_w_i_names (nnames_in_dir) + 1;
		if nnames_in_dir > max_names_in_dir then do;
		     max_names_in_dir = nnames_in_dir;
		     call set_dwmn ();
		end;
		pending_names (savlvl) = 0;
		savlvl = savlvl - 1;
	     end;
	     savlvl = lvl;
	     pending_names (savlvl) = pending_names (savlvl) + no_of_names;
	     call ioa_$rsnnl ("^a^[>^]^a^[>^]^a", current_pathname, (0), sdn, (sdn ^= ""), sen, (sen ^= ""), een);
	     if no_of_names > max_names_on_ent then do;
		max_names_on_ent = no_of_names;
		path_with_max_names = current_pathname;
	     end;

	     if branch.type = "00"b then do;		/* link? */
		nlinks (lvl) = nlinks (lvl) + 1;
	     end;
	     else if branch.type = "01"b then do;	/* seg? */
		nsegs (lvl) = nsegs (lvl) + 1;
		seg_length = fixed (records, 18);
		if seg_length > max_seg_size then do;	/* Biggest? */
		     max_seg_size = seg_length;
		     bigseg_name = current_pathname;
		end;
		nrecs (lvl) = nrecs (lvl) + seg_length;
		rsize (seg_length) = rsize (seg_length) + 1;
		if rsize (seg_length) > mscale then mscale = rsize (seg_length);
		date_temp = binary (branch.dtu) * 1e16b;
		ndays = divide (nxt_midnight - date_temp, 86400000000, 17, 0);
		if ndays < 0 then ndays = 0;		/* Correct for oprs running system with bad clock. */
		if ndays < 5000 then if ndays > lru then do; /* Oldest (no segment is 13 years old) */
			lru = ndays;
			lru_segname = current_pathname;
		     end;
		if ndays > 90 then ndays = 90;
		ufage (ndays) = ufage (ndays) + 1;
		urage (ndays) = urage (ndays) + seg_length;
		date_temp = binary (branch.dtm) * 1e16b;
		ndays = divide (nxt_midnight - date_temp, 86400000000, 17, 0);
		if ndays < 0 then ndays = 0;		/* No science-fiction */
		if ndays < 5000 then if ndays > lrm then do; /* Oldest? */
			lrm = ndays;
			lrm_segname = current_pathname;
		     end;
		if ndays > 90 then ndays = 90;
		mfage (ndays) = mfage (ndays) + 1;
		mrage (ndays) = mrage (ndays) + seg_length;
	     end;
	     else if branch.type = "10"b then do;	/* dir? */
		seg_length = fixed (records, 16);
		if seg_length > bigdir then do;	/* Biggest? */
		     bigdir = seg_length;
		     bigdir_name = current_pathname;
		end;
		ndrecs (lvl) = ndrecs (lvl) + seg_length;
		ndirs (lvl) = ndirs (lvl) + 1;
	     end;

	     do k = 1 to nsfx;			/* Classify by type of name */
		if starname_type (k) = 0 then ecc = binary (een ^= starname_name (k));
		else if starname_type (k) = 2 then ecc = 0;
		else call match_star_name_ (een, starname_name (k), ecc);
		if ecc = 0 then do;
		     if branch.type = "01"b then do;
			starname_recs (k) = starname_recs (k) + seg_length;
			starname_fils (k) = starname_fils (k) + 1;
		     end;
		     else if branch.type = "00"b then starname_lnks (k) = starname_lnks (k) + 1;
		     go to sf1;
		end;
	     end;
sf1:	     ;

	end counter;

set_scale: proc (Page_width, Line_max, Scale);

dcl (Page_width, Line_max, Scale) fixed bin;
dcl (t1, t2, t3) fixed bin;

	     Scale = divide (Line_max, Page_width, 35, 0);
	     t1, t2 = 1;
	     do while (Scale >= t1);
		t3 = divide (t1, t2, 17, 0);
		if t3 = 1 then t1 = 2 * t2;
		else if t3 = 2 then t1 = 5 * t2;
		else t1, t2 = 10 * t2;
	     end;
	     Scale = t1;

	end set_scale;

set_dwmn:	proc ();

dcl (i, j, k) fixed bin;

	     k = savlvl - level;			/* Going to strip of this many >'s */
	     j = 168;
	     do while (k > 0);
		do i = j to 1 by -1 while (substr (current_pathname, i, 1) ^= ">"); end;
		j = i-1;
		k = k - 1;
	     end;
	     dir_with_max_names = substr (current_pathname, 1, j);

	end set_dwmn;

head:	proc;

	     call ioa_ ("^|Disk usage for ""^a"" - ^a", path, ctime);

	end;

fini:
     end disk_usage_stat;




		    display_anst.pl1                08/04/87  1455.5rew 08/04/87  1221.9       67041



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

/* format: style4 */
display_anst: proc;

/* DISPLAY_ANST - dump answer table on console.

   THVV

   Modified by T. Casey, August 1975 to add dump_autbl and dump_dutbl
   Modified by D. M. Wells, July 1976, to understand about FTP channels
   Modified by G. C. Dixon, April 1978:  rename entry points to
   display_anst, display_aut & display_dut and standardize control arguments.
   Modified by E. N. Kittlitz, September 1982: merge in old dump_anstbl entries.

*/


/****^  HISTORY COMMENTS:
  1) change(87-05-31,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-24,Hartogs), install(87-08-04,MR12.1-1055):
      A) Expand length of -channel operand to hold up to 32 characters.
      B) Allow -channel operand to be a starname.
                                                   END HISTORY COMMENTS */


dcl  al fixed bin (21);
dcl  ansp ptr;
dcl  ap ptr;
dcl  argc fixed bin;
dcl  argn fixed bin;
dcl  bchr char (al) based (ap) unaligned;
dcl  dn char (168);
dcl  ec fixed bin (35);
dcl  en char (32);
dcl  entry_sw fixed bin;
dcl  hdr bit (1) aligned init ("1"b);
dcl  mode fixed bin init (1);
dcl  oct bit (1) aligned init ("0"b);
dcl  old_dump bit (1) aligned;
dcl  path char (168);
dcl  sch_tty char (32) aligned init ("");
dcl  sch_user char (32) aligned init ("");
dcl  star_type fixed bin(2);
dcl  whoami char (12);

dcl  entry_var variable entry (ptr, bit (1) aligned, bit (1) aligned, fixed bin,
	char (*) aligned, char (*) aligned, char (*) aligned);

dcl  ANS fixed bin init (1) static options (constant);
dcl  AUT fixed bin init (2) static options (constant);
dcl  DUT fixed bin init (3) static options (constant);

dcl  (char, null) builtin;

dcl  cleanup condition;

dcl  check_star_name_ entry (char(*), bit(36), fixed bin(2), fixed bin(35));
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  dump_anstbl_ entry (ptr, bit (1) aligned, bit (1) aligned, fixed bin, char (*) aligned, char (*) aligned, char (*) aligned);
dcl  dump_autbl_ entry (ptr, bit (1) aligned, bit (1) aligned, fixed bin, char (*) aligned, char (*) aligned, char (*) aligned);
dcl  dump_dutbl_ entry (ptr, bit (1) aligned, bit (1) aligned, fixed bin, char (*) aligned, char (*) aligned, char (*) aligned);
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  pathname_ entry (char (*), char (*)) returns (char (168));
dcl  terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));

dcl  error_table_$badopt fixed bin (35) ext;
%page;
/* -------------------------------------------------------- */

	whoami = "display_anst";
	old_dump = "0"b;
	go to ans_join;

dump_anstbl: entry;

	whoami = "dump_anstbl";
	old_dump = "1"b;

ans_join: path = ">system_control_1>answer_table";
	entry_sw = ANS;
	entry_var = dump_anstbl_;

JOIN:	ansp = null;
	on cleanup begin;
		if ansp ^= null then
		     call terminate_file_ (ansp, 0, TERM_FILE_TERM, (0));
	     end;
	call cu_$arg_count (argc, ec);
	if ec ^= 0 then do;
	     call com_err_ (ec, whoami);
	     go to exit;
	end;

	do argn = 1 to argc;
	     call cu_$arg_ptr (argn, ap, al, ec);
	     if char (bchr, 1) = "-" then do;
		if bchr = "-all" then mode = 0;
		else if bchr = "-a" then mode = 0;
		else if bchr = "-lock" then mode = 2;
		else if bchr = "-octal" then oct = "1"b;
		else if bchr = "-oc" then oct = "1"b;
		else if bchr = "-o" & old_dump then oct = "1"b;
		else if bchr = "-no_octal" | bchr = "-noc" then oct = "0"b;
		else if bchr = "-no_header" then hdr = "0"b;
		else if bchr = "-nhe" then hdr = "0"b;
		else if bchr = "-nh" & old_dump then hdr = "0"b;
		else if bchr = "-header" | bchr = "-he" then hdr = "1"b;
		else if bchr = "-name" | bchr = "-nm" |
			old_dump & bchr = "-user" then do;
		     argn = argn + 1;
		     if argn > argc then do;
no_arg:			call com_err_ (ec, whoami, "Control argument ^a requires an operand.", bchr);
			go to exit;
		     end;
		     call cu_$arg_ptr (argn, ap, al, ec);
		     if ec ^= 0 then do;
cu_fail:			call com_err_ (ec, whoami);
			go to exit;
		     end;
		     mode = 9;
		     sch_user = bchr;
		end;
		else if bchr = "-pathname" | bchr = "-pn" then do;
		     argn = argn + 1;
		     if argn > argc then go to no_arg;
		     call cu_$arg_ptr (argn, ap, al, ec);
		     if ec ^= 0 then go to cu_fail;
		     path = bchr;
		end;
		else if bchr = "-active" then mode = 1;
		else if bchr = "-dial" & entry_sw = ANS then mode = 4;
		else if bchr = "-in" then mode = 3;
		else if (bchr = "-channel" | bchr = "-chn") & entry_sw = ANS
		then do;
		     argn = argn + 1;
		     if argn > argc then go to no_arg;
		     call cu_$arg_ptr (argn, ap, al, ec);
		     if ec ^= 0 then go to cu_fail;
CHN:		     call check_star_name_ (bchr,
		          CHECK_STAR_ENTRY_DEFAULT, star_type, ec);
		     if ec ^= 0 then do;
			call com_err_ (ec, whoami, "channel ^a", bchr);
			go to exit;
		     end;
		     else if star_type = STAR_TYPE_MATCHES_EVERYTHING then;
		     else do;
			mode = 9;
			sch_tty = bchr;
		     end;
		end;
		else do;
bad_arg:		     call com_err_ (error_table_$badopt, whoami, "^a", bchr);
		     go to exit;
		end;
	     end;					/* first char is - */
	     else if old_dump then do;		/* old dump, first char not - */
		if char (bchr, 3) = "caa" |
		     char (bchr, 3) = "net" |
		     char (bchr, 3) = "ftp" |
		     char (bchr, 3) = "tty" then go to CHN;
		else path = bchr;			/* it's a pathname */
	     end;
	     else do;				/* new dump, first char not - */
	          go to CHN;
	     end;
nxarg:	end;

	call expand_pathname_ (path, dn, en, ec);
	if ec ^= 0 then do;
	     call com_err_ (ec, whoami, "^a", path);
	     go to exit;
	end;
	call initiate_file_ (dn, en, R_ACCESS, ansp, (0), ec);
	if ansp = null then do;
	     call com_err_ (ec, whoami, "^a", pathname_ (dn, en));
	     go to exit;
	end;

	call entry_var (ansp, hdr, oct, mode, sch_tty, sch_user, "user_output");

exit:	call terminate_file_ (ansp, 0, TERM_FILE_TERM, (0));
	return;


dump_autbl: entry;

	old_dump = "1"b;
	whoami = "dump_autbl";
	go to aut_join;

display_aut: entry;

	old_dump = ""b;
	whoami = "display_aut";

aut_join: path = ">system_control_dir>absentee_user_table";
	entry_var = dump_autbl_;
	entry_sw = AUT;
	goto JOIN;


dump_dutbl: entry;

	old_dump = "1"b;
	whoami = "dump_dutbl";
	go to dut_join;

display_dut: entry;

	old_dump = ""b;
	whoami = "display_dut";

dut_join: path = ">system_control_dir>daemon_user_table";
	entry_var = dump_dutbl_;
	entry_sw = DUT;
	goto JOIN;
%page; %include access_mode_values;
%page; %include check_star_name;
%page; %include terminate_file;

     end display_anst;




		    display_cdt.pl1                 04/09/85  1352.0r w 04/08/85  1134.4       57780



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


/* format: style2 */

display_cdt:
     procedure;

/* DUMP_CDT - dump Channel Definition Table.

   THVV
   Modified by Mike Grady 5/10/76 for -cmf arg, also
   for version 2 CDT.
   Modified for error code from dump_cdt_ and dump_cmf_ BIM 1/82 
   */

	dcl     (path, dn)		 char (168),
	        en		 char (32),
	        ec		 fixed bin,
	        cdtp		 ptr,
	        sch_tty		 char (32) init (""),
	        al		 fixed bin (21),
	        ap		 ptr,
	        arg		 char (al) based (ap) unaligned;


	dcl     arg_count		 fixed bin;
	dcl     arg_list_ptr	 pointer;
	dcl     argx		 fixed bin;

	dcl     (addr, null, substr)	 builtin;

	dcl     dump_cmf_		 entry (ptr, ptr);

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

	dcl     cu_$arg_count	 entry (fixed bin, fixed bin (35));
	dcl     cu_$arg_list_ptr	 entry (ptr);
	dcl     cu_$arg_ptr_rel	 entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
	dcl     check_star_name_$entry entry (char (*), fixed bin (35));

	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35)),
	        com_err_		 entry options (variable);

	dcl     cleanup		 condition;

	dcl     (
	        error_table_$noarg,
	        error_table_$badopt,
	        error_table_$too_many_args,
	        error_table_$inconsistent
	        )			 fixed bin (35) ext;


	dcl     initiate_file_	 entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
	dcl     terminate_file_	 entry (ptr, fixed bin (24), bit (*), fixed bin (35));
	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));
	dcl     sc_stat_$sysdir	 char (168) aligned external;
	dcl     1 dca		 aligned like dump_cdt_args;
	dcl     cmf_sw		 bit (1) aligned;
	dcl     code		 fixed bin (35);

	dcl     ME		 char (32) init ("display_cdt") internal static options (constant);


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

	if arg_count = 0
	then do;
		call com_err_ (0, ME,
		     "Usage: display_cdt {channel} {-cmf PATH|-all|-header|-pathname PATH|-brief|-long");
		return;
	     end;

	call cu_$arg_list_ptr (arg_list_ptr);		/* For rel calls */

	cdtp, dca.switch = null;
	on cleanup call clean_up;

	unspec (dca) = ""b;
	dca.channel_name = "";
	cmf_sw = "0"b;
	path = "";

	argx = 0;
	do while (argx < arg_count);

	     call get_next_arg ("");

	     if al > 0
	     then if substr (arg, 1, 1) = "-"
		then do;
			if arg = "-all" | arg = "-a"
			then dca.all = "1"b;
			else if arg = "-subtree"
			then dca.subtree = "1"b;
			else if arg = "-brief" | arg = "-bf"
			then dca.brief = "1"b;
			else if arg = "-long" | arg = "-lg"
			then dca.brief = "0"b;
			else if arg = "-no_header" | arg = "-nhe"
			then dca.hdr = "0"b;
			else if arg = "-header" | arg = "-he"
			then dca.hdr = "1"b;
			else if arg = "-channel" | arg = "-chn"
			then do;
				call get_next_arg ("A channel with -channel");
CHANNEL_ARG:
				if dca.channel_name ^= ""
				then do;
					call com_err_ (error_table_$too_many_args, ME,
					     "Multiple -channel args are not permitted.");
					go to RETURN;
				     end;
				call check_star_name_$entry (arg, code);
				dca.channel_name = arg;
				if code = 0
				then dca.all = "0"b;
				else if code = 1
				then do;
					dca.starname = "1"b;
					dca.all = "0"b;
				     end;
				else if code = 2
				then dca.all = "1"b;
				else do;
					call com_err_ (code, ME, "Bad channel name: ^a", arg);
					go to RETURN;
				     end;
			     end;
			else if arg = "-cmf"
			then do;
				cmf_sw = "1"b;
				call get_next_arg ("Pathname following -cmf");
				call iox_$attach_name (unique_chars_ (""b) || ".dump_cdt_output_", dca.switch,
				     "vfile_ " || arg, null, code);
				if code ^= 0
				then do;
					call com_err_ (code, "display_cdt", "Unable to attach output file");
					go to RETURN;
				     end;
				call iox_$open (dca.switch, Stream_output, "0"b, code);
				if code ^= 0
				then do;
					call com_err_ (code, "display_cdt", "Unable to open output file");
					go to RETURN;
				     end;
			     end;
			else if arg = "-pathname" | arg = "-pn"
			then do;
				call get_next_arg ("A pathname following -pathname");
				path = arg;
			     end;
			else do;
				call com_err_ (error_table_$badopt, "display_cdt", """^a""", arg);
				go to RETURN;
			     end;
		     end;
		else go to CHANNEL_ARG;		/* positional = -channel */
	end;

	if path = ""
	then path = pathname_ ((sc_stat_$sysdir), "cdt");

	call expand_pathname_ (path, dn, en, code);
	if code ^= 0
	then do;
		call com_err_ (code, "display_cdt", "^a", path);
		go to RETURN;
	     end;

	call initiate_file_ (dn, en, R_ACCESS, cdtp, (0), code);

	if code ^= 0
	then do;
		call com_err_ (code, "display_cdt", "^a", en);
		go to RETURN;
	     end;

	if cmf_sw
	then call dump_cmf_ (cdtp, dca.switch);		/* dump cdt in form of cmf */
	else do;
		dca.switch = iox_$user_output;
		dca.cdt_ptr = cdtp;
		call dump_cdt_ (addr (dca), code);
		if code ^= 0
		then call com_err_ (code, ME, "^a", dca.channel_name);
	     end;

RETURN:
	call clean_up;
	return;

clean_up:
     procedure;
	if dca.switch ^= null & dca.switch ^= iox_$user_output
	then do;
		call iox_$close (dca.switch, code);
		call iox_$detach_iocb (dca.switch, code);
		call iox_$destroy_iocb (dca.switch, code);
	     end;
	if cdtp ^= null
	then call terminate_file_ (cdtp, (0), TERM_FILE_TERM, (0));
	cdtp = null;
     end clean_up;

get_next_arg:
     procedure (what_did_we_want);
	declare what_did_we_want	 char (*);
	argx = argx + 1;
	if argx > arg_count
	then do;
		call com_err_ (error_table_$noarg, ME, "^a", what_did_we_want);
		go to RETURN;
	     end;
	call cu_$arg_ptr_rel (argx, ap, al, (0), arg_list_ptr);
     end get_next_arg;

%include dump_cdt_args_;
%include terminate_file;
%include access_mode_values;
%include iox_dcls;
%include iox_modes;
     end display_cdt;




		    display_cpu_error.pl1           03/14/85  0810.8rew 03/13/85  1018.4      287262



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


/* format: style4,delnl,insnl,ifthenstmt,indnoniterend */

/* DISPLAY_CPU_ERROR: Command to display MCs and hregs from CPU errors from
   the syserr log */

/* Written Oct 1982 by Rich Coppola */
/* Most of this program was borrowed from the mos_edac_summary command. */
/*
   Modified Jan 1984 by Paul Farley to add checking for other syserr entry
   types (Currently hardware_fault and verify_lock), which is defined by
   display_cpu_error_binary_defs.  This is being implemented by using three
   new control arguments "-all", "-match" and "-exclude".  The default will
   be to only examine the hardware_fault entries.
   Modified 1985-02-21, EJ Sharpe: use syserr_fault_msg.incl.pl1, use date_time_$format
*/

display_cpu_error:
     proc;

/* Automatic */

dcl  CPU_TAGS char (16) int static options (constant) init ("ABCDEFGHabcdefgh");

dcl  arg char (arg_len) based (arg_ptr);		/* A command argument */
dcl  arg_copy char (15) varying;			/* Temp copy of an argument */
dcl  arg_count fixed bin;				/* The number of arguments */
dcl  arg_len fixed bin;				/* Length of an argument */
dcl  arg_list_ptr ptr;				/* Pointer to commands argument list */
dcl  arg_no fixed bin init (1);			/* For scanning argument list */
dcl  arg_ptr ptr;					/* Pointer to an argument */
dcl  argc fixed bin;				/* for getting cpu args */
dcl  def_idx fixed bin;				/* binary_def index */

dcl  code fixed bin (35);				/* Standard system status code */
dcl  cpu_cnt fixed bin init (0);			/* Number of CPUs requested */

dcl  expand_sw bit (1) init ("0"b);			/* Set if user just wants hregs interpreted */

dcl  for_arg char (for_len) based (for_ptr);		/* This is the -for argument */
dcl  for_len fixed bin;				/* Saved length of -for argument */
dcl  for_ptr ptr;					/* Saved pointer to the -for argument */
dcl  for_sw bit (1) init ("0"b);			/* Set if -for used */
dcl  for_time fixed bin (71);				/* Time specified on -for */
dcl  from_sw bit (1) init ("0"b);			/* Set if -from used */
dcl  from_time fixed bin (71);			/* Time specified on -from */

dcl  scan_text bit (1) init ("0"b);			/* Set if -match used */
dcl  match_sw bit (1) init ("0"b);			/* Set if -match used */
dcl  exclude_sw bit (1) init ("0"b);			/* Set if -exclude used */

dcl  hr_switches bit (5);
dcl  mask bit (36) aligned init ("0"b);			/* Mask of significant bits in status word */
dcl  more_args bit (1);				/* Set while there are more arguments to scan */
dcl  area_ptr ptr init (null);			/* Free area pointer */
dcl  free_area area based (area_ptr);			/* Free area for allocating strings */
dcl  msg_seq fixed bin (35);				/* Sequence number */
dcl  msg_time fixed bin (71);				/* Time of syserr message */

dcl  only_scu bit (1) init ("0"b);			/* 1 => don't display hregs */
dcl  open_status bit (36) aligned;			/* Code from syserr_log_util_$open */
dcl  plural_sw bit (1);
dcl  ptr_array (1) ptr;				/* An array of pointers as required by get_temp_segment_ */
dcl  (print_cnt, read_cnt) fixed bin init (-1);

dcl  segs_allocated bit (1) init ("0"b);		/* Set after work segments created */
dcl  tab_cnt fixed bin init (0);			/* Number of seperate status found */
dcl  thread_sw bit (1) init ("1"b);			/* Set to thread hregs */
dcl  (tm1, tm2) char (24);				/* Used to call date_time_ */
dcl  to_sw bit (1) init ("0"b);			/* Set if -to used */
dcl  to_time fixed bin (71);				/* Time specified on -to */

dcl  workp ptr;					/* Pointer to work segment */
dcl  1 work aligned based (workp),			/* Declaration of work segment */
       2 cpureq (8) char (1),				/* Table of requested CPUs */
       2 buffer (500) bit (36) aligned;			/* Syserr messages are read here */

dcl  ctext char (512);				/* Text of current message */
dcl  ctextl fixed bin;				/* Length of current message */
dcl  1 string_data based,				/* Data for match or exclude */
       2 first ptr,					/* Pointer to first string */
       2 last ptr,					/* Pointer to last string */
       2 count fixed bin init (0);			/* Number of strings in list */

dcl  1 match_data like string_data automatic;		/* List of match strings */
dcl  1 exclude_data like string_data automatic;		/* List of exclude strings */

dcl  1 str aligned based,				/* Structure allocated for each string */
       2 next ptr init (null),			/* Pointer to next in list */
       2 len fixed bin init (arg_len),			/* Length of messaage */
       2 data char (arg_len refer (str.len));		/* The string */

/* Constants */

dcl  name char (17) int static options (constant) init ("display_cpu_error");
						/* Name of procedure */

/* External entries */

dcl  com_err_ entry options (variable);
dcl  convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35));
dcl  convert_date_to_binary_$relative entry (char (*), fixed bin (71), fixed bin (71), fixed bin (35));
dcl  convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  cu_$arg_list_ptr entry (ptr);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr);
dcl  cv_bin_$oct entry (fixed bin, char (12));
dcl  date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);
dcl  db_print entry (ptr, char (*) aligned, ptr, char (*), fixed bin, fixed bin, ptr, fixed bin, fixed bin);
dcl  error_table_$end_of_info ext fixed bin (35);
dcl  error_table_$badopt ext fixed bin (35);
dcl  get_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35));
dcl  hran_$hranl entry (ptr, ptr, bit (1));
dcl  hran_$no_thread entry (ptr, ptr, bit (5));
dcl  ioa_ entry options (variable);
dcl  ioa_$rsnnl entry () options (variable);
dcl  iox_$user_output ptr ext;
dcl  print_syserr_msg_$open_err entry (bit (36) aligned, char (*), fixed bin (35));
dcl  release_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35));
dcl  get_system_free_area_ entry returns (ptr);
dcl  syserr_log_util_$open entry (bit (36) aligned, fixed bin (35));
dcl  syserr_log_util_$read entry (ptr, fixed bin, fixed bin, fixed bin (35));
dcl  syserr_log_util_$close entry (fixed bin (35));
dcl  syserr_log_util_$search entry (fixed bin (71), fixed bin (71), fixed bin (35), fixed bin (35));

dcl  cleanup condition;

dcl  (length, fixed, addr, addrel, baseptr, substr, null, hbound, lbound, bin, index, rtrim, unspec, verify) builtin;

%page;
/* Initialization */

	on cleanup call clean_up;

	call get_temp_segments_ (name, ptr_array, code);	/* Get a work segment */
	if code ^= 0 then do;
	     call com_err_ (code, name, "Can't get temp segment");
	     go to done;
	     end;
	segs_allocated = "1"b;			/* Recpuber that they are allocated */
	workp = ptr_array (1);			/* Copy pointer to my segment */

	call cu_$arg_list_ptr (arg_list_ptr);		/* Need pointer to argument list */
	call cu_$arg_count (arg_count);		/* And the length */
	more_args = (arg_count > 0);			/* Set if args to scan */
	call scan_args;				/* Scan the argument list */

	call syserr_log_util_$open (open_status, code);	/* Open the syserr log */
	if code ^= 0 | substr (open_status, 1, 2) ^= "11"b then do;
						/* If error */
	     call print_syserr_msg_$open_err (open_status, name, code);
	     if code ^= 0 then go to done;		/* Not recoverable */
	     end;

	if ^from_sw then do;			/* No -from, so start at beginning */
	     call syserr_log_util_$search (0, msg_time, msg_seq, code);
	     if code ^= 0 then do;
		call com_err_ (code, name, "Can't find first message in log.");
		go to done;
		end;
	     from_time = msg_time;			/* Official starting time */
	     end;
	else do;					/* -from used, find right message */
	     call syserr_log_util_$search (from_time, msg_time, msg_seq, code);
	     if code ^= 0 then do;
		call com_err_ (code, name, "Locating first message requested.");
		go to done;
		end;
	     end;

	if for_sw then do;				/* Now can compute -for limit */
	     call convert_date_to_binary_$relative (for_arg, to_time, from_time, code);
	     if code ^= 0 then do;
		call com_err_ (code, name, "-for ^a", for_arg);
		go to done;
		end;
	     to_sw = "1"b;				/* Now, just as if -to was specified */
	     end;
	if ^to_sw then to_time = from_time;		/* Initialize last message time */

	syserr_msgp = addr (work.buffer);		/* Read here */
%page;

	call print_header;

/* Loop thru the file */
	read_cnt = 0;
loop:
	call syserr_log_util_$read (syserr_msgp, hbound (buffer, 1), (0), code);
	if code ^= 0 then do;
	     if code = error_table_$end_of_info then go to done;
	     call com_err_ (code, name, "Reading syserr log");
	     go to done;
	     end;

	read_cnt = read_cnt + 1;
	if to_sw then do;				/* If time limit */
	     if syserr_msg.time > to_time then go to done;
	     end;
	else to_time = syserr_msg.time;		/* Save last message time */

	if scan_text then do;
	     do def_idx = lbound (display_cpu_error_binary_defs, 1) to hbound (display_cpu_error_binary_defs, 1);
		if display_cpu_error_binary_defs (def_idx) = syserr_msg.data_code then goto continue_check;
	     end;
	     goto loop;				/* wrong type */

continue_check:
	     if syserr_msg.data_size <= 0 then goto loop; /* no binary data */
	     ctextl = syserr_msg.text_len;		/* Save length */
	     substr (ctext, 1, ctextl) = syserr_msg.text; /* Save data */
	     if match_sw
	     then					/* If matching strings */
		if ^match_string (addr (match_data)) then goto loop;
	     if exclude_sw
	     then					/* If excluding by string */
		if match_string (addr (exclude_data)) then goto loop;
	     call print_it;
	     goto loop;
	     end;					/* DEFAULT */
	if syserr_msg.data_code = SB_hw_fault & syserr_msg.data_size > 0 then call print_it;
	go to loop;

/* End of log reached */

/* End of command */

done:
	if print_cnt = 0 then do;			/* if no messages printed */
	     if read_cnt = 0 then plural_sw = "1"b;
	     call com_err_ (0, name, "No messages matched criteria given. ^d message^v(s ^) read.", read_cnt, plural_sw)
		;
	     end;


	call clean_up;
	return;

miss_err:
	call com_err_ (0, name, "Argument required after ^a.", arg_copy);
	goto done;
%page;
/* Procedure to scan the argument list */

scan_args:
     proc;

	do while (more_args);			/* Do while thins to look at */
	     call get_arg;
	     if arg = "-from" | arg = "-fm" then do;	/* Start time */
		from_sw = "1"b;
		call time_arg (from_time);
		end;
	     else if arg = "-to" then do;		/* Ending time */
		to_sw = "1"b;
		call time_arg (to_time);
		end;
	     else if arg = "-for" then do;		/* Time limit */
		for_sw = "1"b;
		call time_arg (for_time);		/* For syntax checking only */
		for_len = arg_len;			/* Save pointer to this argument */
		for_ptr = arg_ptr;
		end;
	     else if arg = "-expand" | arg = "-exp" then do;
		thread_sw = "0"b;
		expand_sw = "1"b;
		end;
	     else if arg = "-nothread" then thread_sw = "0"b;
	     else if arg = "-mc" then only_scu = "1"b;
	     else if arg = "-cpu" then do;		/* List of CPUs */
		if ^more_args then do;		/* Need more args */
no_cpu:
		     call com_err_ (0, name, "Argument missing after -cpu");
		     go to done;
		     end;
		call get_arg;
		if verify (arg, CPU_TAGS) ^= 0 then do;
new_cpu:
		     call com_err_ (0, name, "Invalid CPU Tag(s) ^a", arg);
		     return;
		     end;

		if arg_len > 8 then do;
		     call com_err_ (0, name, "Too many CPUs specified (^a).", arg);
		     return;
		     end;

		do argc = 1 to arg_len;
		     work.cpureq (argc) = substr (arg, argc, 1);
		     cpu_cnt = cpu_cnt + 1;		/* Count CPU found */
		end;
		end;

	     else if arg = "-all" | arg = "-a" then scan_text = "1"b;
						/* scan all valid syserr types. */
	     else if arg = "-match" then do;
		call string_check (addr (match_data));	/* Add to match string */
		match_sw = "1"b;
		scan_text = "1"b;
		end;

	     else if arg = "-exclude" | arg = "-ex" then do;
		call string_check (addr (exclude_data));/* Add to exclude list */
		exclude_sw = "1"b;
		scan_text = "1"b;
		end;

	     else do;				/* Bad arg */
		call com_err_ (error_table_$badopt, name, "^a", arg);
		go to done;
		end;
	end;

	if to_sw & for_sw then do;			/* Conflict */
	     call com_err_ (0, name, "Conflicting arguments: -to and -for");
	     go to done;
	     end;

	return;

     end scan_args;
%page;
/* Procedure to return the next argument from command line */

get_arg:
     proc;

	call cu_$arg_ptr_rel (arg_no, arg_ptr, arg_len, code, arg_list_ptr);
	if code ^= 0 then do;			/* Should never happen */
	     call com_err_ (code, name, "Arg ^d", arg_no);
	     go to done;
	     end;
	arg_no = arg_no + 1;			/* For next call */
	more_args = (arg_no <= arg_count);
	return;

put_arg:
     entry;					/* Entry to return argument after scanning too far */
	arg_no = arg_no - 1;
	more_args = (arg_no <= arg_count);
	return;

     end get_arg;

/* Procedure to convert a time argument */

time_arg:
     proc (t);

dcl  arg_copy char (10) var;				/* Save copy of arg here */
dcl  t fixed bin (71);				/* The time to ouput */


	arg_copy = arg;
	if ^more_args then do;			/* Must be more */
	     call com_err_ (0, name, "Argument required after ^a.", arg_copy);
	     go to done;
	     end;
	call get_arg;
	call convert_date_to_binary_ (arg, t, code);
	if code ^= 0 then do;
	     call com_err_ (code, name, "^a ^a", arg_copy, arg);
	     go to done;
	     end;

	return;

     end time_arg;
%page;
/* Procedure to add a string to list of strings */

string_check:
     proc (p);

dcl  p ptr;					/* Pointer to header block */
dcl  1 sdata like string_data based (p);		/* The header block */
dcl  link ptr;					/* A temp pointer */

	arg_copy = arg;				/* Save copy of control argument */
	if ^more_args then go to miss_err;		/* Another argument is needed */
	call get_arg;				/* So get it */
	if area_ptr = null then area_ptr = get_system_free_area_ ();
						/* If this is first allocate */
scheck:
	allocate str in (free_area) set (link);
	if sdata.count = 0
	then sdata.first = link;			/* If first in chain */
	else sdata.last -> str.next = link;		/* If not first, add to chain */
	sdata.last = link;				/* This is last in chain */
	sdata.count = sdata.count + 1;		/* Count it */
	link -> str.data = arg;			/* Copy the real string */
	if ^more_args then return;			/* If no more args, then all done here */
	call get_arg;				/* Get next arg */
	if substr (arg, 1, 1) ^= "-" then go to scheck;	/* If not control arg, treat as string */
	call put_arg;				/* Return argument so next user can get it */
	return;

     end string_check;
%page;
/* Procedure to match a string */

match_string:
     proc (p) returns (bit (1) aligned);

dcl  (p, q) ptr;
dcl  1 mdata like string_data based (p);		/* String list structure */

	if mdata.count = 0 then return ("0"b);		/* Return no if list empty */
	q = mdata.first;				/* Get first in list */
	do while (q ^= null);			/* Do until end */
	     if index (substr (ctext, 1, ctextl), q -> str.data) ^= 0 then return ("1"b);
	     q = q -> str.next;
	end;

	return ("0"b);				/* No match */

     end match_string;
%page;
/* Procedure to print a cpu error entry */

print_it:
     proc;

dcl  PRS (0:7) ptr aligned;
dcl  cpu char (1);
dcl  cpu_tag (8) char (1) init ("a", "b", "c", "d", "e", "f", "g", "h");
dcl  error_msg char (100) aligned;
dcl  found bit (1);
dcl  hr_ptr ptr;
dcl  tcpu char (1);
dcl  (i, j) fixed bin;

	found = "0"b;
	fmsgp = addr (syserr_msg.data);
	scup = addr (mach_cond.scu);
	hr_ptr = addr (fault_msg.hist_reg);
	i = index (syserr_msg.text, " CPU ");
	if i = 0 then do;
	     if cpu_cnt = 0 then goto p_data;		/* any CPU */
	     i = fixed (scu.cpu_no, 17) + 1;
	     cpu = cpu_tag (i);
	     do j = 1 to cpu_cnt while (found = "0"b);
		if cpu = work.cpureq (j) then found = "1"b;
	     end;
	     if ^found then return;			/* This cpu not in list */
	     goto p_data;
	     end;
	tcpu = substr (syserr_msg.text, i + 5, 1);
	cpu = cpu_tag (index ("ABCDEFGH", tcpu));
	if cpu_cnt > 0
	then do j = 1 to cpu_cnt while (found = "0"b);
	     if cpu = work.cpureq (j) then found = "1"b;
	end;

	if cpu_cnt > 0
	then if ^found then return;			/*  don't count this one */

p_data:						/* found one, print it */
	call ioa_ ("^/^a ^d^/^a", date_time_$format ("date_time", (syserr_msg.time), "", ""), syserr_msg.seq_num,
	     syserr_msg.text);
	unspec (PRS) = unspec (mach_cond.prs);
	call ioa_ ("^/Pointer Registers:^-^12p  ^12p  ^12p  ^12p^/^2-^12p  ^12p  ^12p  ^12p", PRS);
	call ioa_ (
	     "^/Index Registers:^-x0: ^6.3b x1: ^6.3b x2: ^6.3b x3: ^6.3b^/^2-x4: ^6.3b x5: ^6.3b x6: ^6.3b x7: ^6.3b",
	     mach_cond.x);
	call ioa_ ("^2-A: ^w Q: ^w EXP: ^3.3b^/^2-Timer: ^9.3b Ring Alarm Reg: ^.3b^/", mach_cond.a, mach_cond.q,
	     "0"b || mach_cond.e, mach_cond.t, mach_cond.ralr);
	if mach_cond.mask ^= "0"b
	then call ioa_ ("Memory Controller Mask: ^12.3b ^12.3b", substr (mach_cond.mask, 1, 36),
		substr (mach_cond.mask, 37, 36));
	if mach_cond.errcode ^= 0 then do;
	     call convert_status_code_ ((mach_cond.errcode), (""), error_msg);
	     call ioa_ ("MC.ERRCODE:^/^a", rtrim (error_msg));
	     end;

	call ioa_ ("MC Fault Time: ^a  (^18.3b)",
	     date_time_$format ("date_time", fixed (mach_cond.fault_time, 71), "", ""), mach_cond.fault_time);
	call interpret_fault_reg ((mach_cond.fault_reg));
	if mach_cond.cpu_type ^= 0
	then if mach_cond.ext_fault_reg ^= "0"b then call interpret_ext_fault_reg ((mach_cond.ext_fault_reg));
	if scu.mif then call ioa_ ("EIS Info:^-^w ^w ^w ^w^/^-^w ^w ^w ^w", mach_cond.eis_info);

	call ioa_ ("^/SCU Data:^2-^w ^w ^w ^w^/^2-^w ^w ^w ^w^/", mach_cond.scu);
	call interp_scu (scup);
	print_cnt = print_cnt + 1;
	if only_scu = "1"b then return;

	hr_switches = expand_sw || "1"b || "1"b || "1"b || "1"b;
	call ioa_ ("^/History Register Data:^/");
	if thread_sw
	then call hran_$hranl (hr_ptr, null, "0"b);
	else call hran_$no_thread (hr_ptr, null, hr_switches);

	return;

     end print_it;
%page;

/* Procedure to print the header line */

print_header:
     proc;


	tm1 = date_time_$format ("date_time", from_time, "", "");
						/* Starting time is easy */

	if to_sw
	then tm2 = date_time_$format ("date_time", to_time, "", "");
						/* Stop time is easy if given */
	else do;					/* Otherwise get last message  */
	     call syserr_log_util_$search (-1, msg_time, msg_seq, code);
						/* Search to eof */
	     if code ^= 0 then do;			/* Should not fail */
log_err:
		call com_err_ (code, name, "From syserr_log_util_$search.");
		return;
		end;

	     tm2 = date_time_$format ("date_time", msg_time, "", "");
						/* Edit time */
	     call syserr_log_util_$search (from_time, msg_time, msg_seq, code);
						/* Back to first msg */
	     if code ^= 0 then go to log_err;
	     end;

	call ioa_ ("^/Syserr log from ^a to ^a", tm1, tm2);
	print_cnt = 0;
	return;

     end print_header;


%page;
/* Cleanup handler */

clean_up:
     proc;

	call syserr_log_util_$close (code);

	if segs_allocated then do;
	     segs_allocated = "0"b;
	     call release_temp_segments_ (name, ptr_array, code);
	     end;
	return;

     end clean_up;
%page;
/* Internal procedure to print fault reg data */

interpret_fault_reg:
     proc (fault_reg);

dcl  fault_reg bit (36);
dcl  (fault_no, break) fixed bin;
dcl  1 illeg_acts based (addr (fault_reg)),
       (
       2 pad bit (16),
       2 IA (4) bit (4),
       2 pad1 bit (4)
       ) unal;
dcl  port_name (4) char (3) int static options (constant) init ("A: ", "B: ", "C: ", "D: ");

dcl  (line1, line2) char (80) varying;
dcl  (line1_sw, line2_sw) bit (1) init ("0"b);

dcl  FAULT_TYPES (36) char (15) var int static options (constant)
	init ("ILL OP", "ILL MOD", "ILL SLV", "ILL PROC", "NEM", "OOB", "WRT INH", "PROC PAR-UPR", "PROC PAR-LWR",
	"$CON A", "$CON B", "$CON C", "$CON D", "ONC (DA ERR1)", "ONC (DA ERR2)", "", "", "", "", "", "", "", "", "",
	"", "", "", "", "", "", "", "", "CACHE-PAR DIR", "CACHE-PAR STR", "CACHE-PAR IA", "CACHE-PAR BLK");


dcl  SC_IA_TYPES (1:15) char (42) var int static options (constant)
	init ("Unassigned (01)", "Non-existent Address (02)", "Stop on Condition (03)", "Unassigned (04)",
	"Data Parity, Store to SC (05)", "Data Parity in Store (06)", "Data Parity in Store AND Store to SC (07)",
	"Not Control (10)", "Port Not Enabled (11)", "Illegal Command (12)", "Store Not Ready ( 13)",
	"ZAC Parity, Active Module to SC (14)", "Data Parity, Active Module to SC (15)", "ZAC Parity, SC to Store (16)",
	"Data Parity, SC to Store (17)");


	if fault_reg = "0"b then return;


	line1, line2 = "";

	do fault_no = 1 to 15;
	     if substr (fault_reg, fault_no, 1) = "1"b then do;
		line1 = line1 || FAULT_TYPES (fault_no) || ", ";
		line1_sw = "1"b;
		end;
	end;

	break = 0;
	do fault_no = 1 to 4 while (break = 0);		/* do IAs now */
	     if IA (fault_no) then do;
		line2 = "Ilegal Action on CPU Port " || port_name (fault_no);
		line2 = line2 || SC_IA_TYPES (bin (IA (fault_no), 4)) || ", ";
		line2_sw = "1"b;
		break = 1;
		end;
	end;

	do fault_no = 33 to 36;
	     if substr (fault_reg, fault_no, 1) = "1"b then do;
		line1 = line1 || FAULT_TYPES (fault_no) || ", ";
		line1_sw = "1"b;
		end;
	end;

	if line1_sw
	then					/* remove trailing comma & space */
	     line1 = substr (line1, 1, (length (line1) - 2));
	if line2_sw then line2 = substr (line2, 1, (length (line2) - 2));

	call ioa_ ("^/Fault Register:^-^w^[  (^a)^;^s^]^[^/^18t(^a)^]", fault_reg, line1_sw, line1, line2_sw, line2);

	return;

%page;
interpret_ext_fault_reg:
     entry (ext_fault_reg);

dcl  ext_fault_reg bit (15);
dcl  indx fixed bin;

dcl  EXT_FAULT_TYPES (15) char (39) var int static options (constant)
	init ("Bffr. Ovflw - Port A", "Bffr. Ovflw - Port B", "Bffr. Ovflw - Port C", "Bffr. Ovflw - Port D",
	"Bffr. Ovflw - Primary Dir", "Write Notify Parity Error on ANY Port", "Dup. Dir. LVL 0 Parity Error",
	"Dup. Dir. LVL 1 Parity Error", "Dup. Dir. LVL 2 Parity Error", "Dup. Dir. LVL 3 Parity Error",
	"Dup. Dir. Multi Match Error", "PTW Ass. Mem. Parity Error", "PTW Ass. Mem. Match Error",
	"SDW Ass. Mem. Parity Error", "SDW Ass. Mem. Match Error");


	line1 = "";
	do indx = 1 to 15;
	     if substr (ext_fault_reg, indx, 1) = "1"b then line1 = line1 || EXT_FAULT_TYPES (indx) || ", ";
	end;

	if line1 ^= "" then do;
	     line1 = substr (line1, 1, (length (line1) - 2));
	     call ioa_ ("^/DPS8 Extended Fault Register: ^5.3b^/^32t(^a)", ext_fault_reg, line1);
	     end;


	return;


     end interpret_fault_reg;


%page;
interp_scu:
     proc (scup);

dcl  at_by_wd char (2);
dcl  cpul (0:7) char (1) int static options (constant) init ("a", "b", "c", "d", "e", "f", "g", "h");
dcl  cvbinbuf char (12);
dcl  flt_bf char (24) varying;
dcl  flt_ln char (100);
dcl  fltdtab (0:35) bit (1) based (byptr) unaligned;
dcl  iocbp ptr;
dcl  scup ptr;					/* pointer to SCU Data */
dcl  TAG_ptr ptr;					/* pointer to tag table */
dcl  1 TAG (64) based (TAG_ptr),
       2 code char (4) unal,
       2 pad bit (8) unal,
       2 chain bit (1);

dcl  tag_prt bit (1) init ("0"b);
dcl  tag_ char (4) init ("");
dcl  (lnpos, flt_lng, inst6, i, j) fixed bin;
dcl  (byptr, refptr) ptr;
dcl  tsrpr bit (1);

dcl  1 scud based (scup) aligned,
       2 wd0 unaligned,				/* :: */
         3 prr bit (3),				/* Procedure Ring Register */
         3 psr bit (15),				/* Procedure Segment Register */
         3 apust bit (18),				/* APU Status */
       2 wd1 unaligned,				/* :: */
         3 fid bit (20),				/* fault/interrupt data */
         3 ill_act_lns bit (4),			/* Illegal Action Lines */
         3 ill_act_chan bit (3),			/* Illegal Action Channel (Port) */
         3 con_chan bit (3),				/* Connect Channel (Port) */
         3 fi bit (6),				/* Fault/Interrupt Vector Address */
       2 wd2 unaligned,				/* :: */
         3 trr bit (3),				/* Temporary Ring Register */
         3 tsr bit (15),				/* Temporary Segment Register */
         3 mbz bit (9),				/* :: */
         3 cpu bit (3),				/* Processor Number */
         3 tmd bit (6),				/* :: */
       2 wd3 fixed bin (35),				/* :: */
       2 wd4 unaligned,				/* :: */
         3 ict bit (18),				/* Instruction Counter */
         3 ir bit (18),				/* Indicator Register */
       2 wd5 unaligned,				/* :: */
         3 ca bit (18),				/* Computed Address */
         3 cus bit (12),				/* CU Status */
         3 ct_hold bit (6),				/* remember mod field */
       2 wd6 fixed bin (35),				/* Even Instruction */
       2 wd7 fixed bin (35);				/* Odd Instruction */

/* Constants */

dcl  ill_act (0:15) char (37) varying int static options (constant)
	init ("...", "Unassigned", "Non Existent Address", "Fault on Condition", "Unassigned",
	"Data Parity (Store -> SCU)", "Data Parity in Store", "Data Parity (Store -> SCU & in Store)", "Not Control",
	"Port Not Enabled", "Illegal Command", "Store Not Ready", "ZAC Parity (Processor -> SCU)",
	"Data Parity (Processor -> SCU)", "ZAC parity (SCU -> Store)", "Data Parity (SCU -> Store)");

dcl  indrs (18:31) char (4) varying int static options (constant)
	init ("zero", "neg", "cary", "ovfl", "eovf", "eufl", "oflm", "tro", "par", "parm", "^bar", "tru", "mif", "abs");

dcl  APU (18:32) char (6) varying int static options (constant)
	init ("priv", "xsf", "sdwamm", "sd-on", "ptwamm", "pt-on", "pi-ap", "dsptw", "sdwnp", "sdwp", "ptw", "ptw2",
	"fap", "fanp", "fabs");

dcl  CU (18:29) char (3) varying int static options (constant)
	init ("rf", "rpt", "rd", "rl", "pot", "pon", "xde", "xdo", "itp", "rfi", "its", "fif");

dcl  g1and7flts (5) bit (6) int static options (constant) unaligned init ("01"b3, "11"b3, "21"b3, "31"b3, "37"b3);

dcl  grp1flt (0:19) char (24) varying int static options (constant)
	init ("Illegal Ring Order", "Not in Execute Bracket", "Execute Bit off", "Not In Read Bracket", "Read Bit Off",
	"Not In Write Bracket", "Write Bit Off", "Not A Gate", "Not In Call Bracket", "Outward Call",
	"Bad Outward Call", "Inward Return", "Cross Ring Transfer", "Ring Alarm", "Associative Memory",
	"Out of Segment Bounds", "Processor Parity Upper", "Processor Parity Lower", "SC To Proc. Seq. Error 1",
	"SC To Proc. Seq. Error 2");

dcl  grp2flt (0:6) char (24) varying int static options (constant)
	init ("Illegal Segment Number", "Illegal Op Code", "Illegal Address & Mod", "Illegal Slave Procedure",
	"Illegal Procedure", "Non Existent Address", "Out Of Bounds");

dcl  flt_int_typ (0:63) char (24) varying int static options (constant)
	init ("...", "Shutdown", "...", "Store", "Bulk Store 0 Term", "MME 1", "...", "Fault Tag 1", "IOM 0 Overhead",
	"Timer Runout", "IOM 1 Overhead", "Command", "IOM 2 Overhead", "Derail", "IOM 3 Overhead", "Lockup",
	"IOM 0 Terminate Ch 40-77", "Connect", "IOM 1 Terminate Ch 40-77", "Parity", "Bulk Store 1 Term",
	"Illegal Procedure", "...", "Op Not Complete", "IOM 0 Terminate", "Startup", "IOM 1 Terminate", "Overflow",
	"IOM 2 Terminate", "Divide Check", "IOM 3 Terminate", "Execute", "IOM 0 Marker Ch 40-77", "(DF0) Segment",
	"IOM 1 Marker Ch 40-77", "(DF1) Page", "...", "Directed Fault 2", "...", "Directed Fault 3", "IOM 0 Marker",
	"Access Violation", "IOM 1 Marker", "MME 2", "IOM 2 Marker", "MME 3", "IOM 3 Marker", "MME 4", "...",
	"(FT2) Linkage", "...", "Fault Tag 3", "...", "...", "...", "...", "IOM 0 Special", "...", "IOM 1 Special",
	"...", "IOM 2 Special", "...", "IOM 3 Special", "Trouble");

dcl  TAG_table (8) char (40) int static options (constant) init (
						/* tag table */
	"     au   qu   du   ic   al   ql   dl   ", "x0   x1   x2   x3   x4   x5   x6   x7   ",
	"n*  aau* aqu* ailtg ic* aal* aql* ailtg ", "0*  a1*  a2*  a3*  a4*  a5*  a6*  a7*  a",
	"fi   itp  iltg its  sd   scr  f2   f3   ", "ci   i    sc   ad   di   dic aid   idc a",
	"*n   *au  *qu  iltg *ic  *al  *ql  iltg ", "*0   *1   *2   *3   *4   *5   *6   *7   ");

%page;

	flt_ln, flt_bf = "";
	tsrpr = "0"b;
	flt_bf = flt_int_typ (fixed (scud.wd1.fi, 6));
	if substr (flt_bf, 1, 3) = "..."
	then call ioa_ ("^/Fault/Interrupt (^o), Undefined", fixed (scud.wd1.fi, 6));
	else do;
	     flt_lng = length (flt_int_typ (fixed (scud.wd1.fi, 6)));
	     substr (flt_ln, 1, flt_lng) = substr (flt_bf, 1, flt_lng);
	     byptr = addrel (scup, 1);
	     if fltdtab (35) = "1"b then do;
		substr (flt_ln, flt_lng + 2, 5) = "Fault";
		lnpos = flt_lng + 8;
		do i = 1 to hbound (g1and7flts, 1);	/*  If grp 1 or 7 faults, don't print out tsr|ca */
		     if scud.wd1.fi = g1and7flts (i) then tsrpr = "1"b;
		end;
		end;
	     else do;
		substr (flt_ln, flt_lng + 2, 9) = "Interrupt";
		lnpos = flt_lng + 12;
		tsrpr = "1"b;			/* don't print out tsr|ca for interrupts */
		end;
	     flt_lng = fixed (scud.wd1.fi, 6);
	     call cv_bin_$oct (flt_lng, cvbinbuf);
	     substr (flt_ln, lnpos, 4) = "(" || substr (cvbinbuf, 11, 2) || ")";
	     lnpos = lnpos + 4;
	     j = lnpos;
	     do i = 0 to hbound (grp1flt, 1);
		if fltdtab (i) then do;
		     if substr (flt_ln, 1, 5) = "Store" | substr (flt_ln, 1, 12) = "Illegal Proc"
		     then if i <= 6
			then call ioa_$rsnnl ("^a, ^a", flt_ln, j, flt_ln, grp2flt (i));
			else ;
		     else call ioa_$rsnnl ("^a, ^a", flt_ln, j, flt_ln, grp1flt (i));
		     end;
	     end;
	     call ioa_ ("^a", flt_ln);
	     end;
	if ill_act_lns ^= "0"b then do;		/* display illegal action lines if present */
	     call ioa_ ("Illegal Action Code (^o) - ^a", fixed (scud.wd1.ill_act_lns, 4),
		ill_act (fixed (scud.wd1.ill_act_lns, 4)));
	     end;
	if tsrpr
	then at_by_wd = "At";			/* if not printing tsr */
	else at_by_wd = "By";
	byptr = addrel (baseptr (fixed (scud.wd0.psr, 18)), fixed (scud.wd4.ict, 18));
	if ^tsrpr then refptr = addrel (baseptr (fixed (scud.wd2.tsr, 18)), fixed (scud.wd5.ca, 18));
	call ioa_ ("^a: ^p", at_by_wd, byptr);
	if ^tsrpr
	then					/* if we want to print out tsr|ca */
	     call ioa_ ("Referencing: ^p", refptr);
	call ioa_ ("On: cpu ^a (#^o)", cpul (fixed (scud.wd2.cpu, 3)), fixed (scud.wd2.cpu, 3));
	flt_ln = "";
	byptr = addr (scud.wd4);			/* display Indicator register if any bits present */
	do i = lbound (indrs, 1) to hbound (indrs, 1);
	     if fltdtab (i) then call ioa_$rsnnl ("^a ^a,", flt_ln, j, flt_ln, indrs (i));
	end;
	if flt_ln ^= "" then do;
	     substr (flt_ln, j, 1) = " ";
	     call ioa_ ("Indicators: ^a", flt_ln);
	     flt_ln = "";
	     end;
	byptr = addr (scud.wd0);			/* display interpreted APU status if any bits present */
	do i = lbound (APU, 1) to hbound (APU, 1);
	     if fltdtab (i) then call ioa_$rsnnl ("^a ^a,", flt_ln, j, flt_ln, APU (i));
	end;
	if flt_ln ^= "" then do;
	     substr (flt_ln, j, 1) = " ";
	     call ioa_ ("APU Status: ^a", flt_ln);
	     flt_ln = "";
	     end;
	byptr = addr (scud.wd5);			/* display interprted CU status if any bits present */
	do i = lbound (CU, 1) to hbound (CU, 1);
	     if fltdtab (i) then call ioa_$rsnnl ("^a ^a,", flt_ln, j, flt_ln, CU (i));
	end;

	TAG_ptr = addr (TAG_table);
	i = fixed (wd5.ct_hold);

	if i ^= 0 then do;
	     tag_ = TAG.code (i + 1);
	     tag_prt = "1"b;
	     end;

	if (flt_ln ^= "") | (tag_ ^= "") then do;
	     substr (flt_ln, j, 1) = " ";
	     call ioa_ ("CU Status:  ^a  ^[^/CT Hold: ^a^]", flt_ln, tag_prt, tag_);
	     end;

	iocbp = iox_$user_output;
	call ioa_ ("Instructions: ");			/* display Instructions (words 6 & 7) */
	call db_print (iocbp, iocbp -> iocb.name, addr (scud.wd6), "i", inst6, 1, null, 0, 0);

	call db_print (iocbp, iocbp -> iocb.name, addr (scud.wd7), "i", inst6 + 1, 1, null, 0, 0);
	return;

     end interp_scu;
%page;
%include syserr_message;
%page;
%include syserr_binary_def;
%page;
%include syserr_fault_msg;
%page;
%include mc;
%page;
%include iocb;


     end display_cpu_error;




		    display_rtdt.pl1                10/27/83  1614.3rew 10/27/83  1441.6       99459



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


display_rtdt: proc;

/* This procedure formats and prints the contents of a Resource Type Description Table (RTDT). */
/* Written 03/13/78 by C. D. Tavares */

%include rtdt;

dcl  sysdir char (168) static initial (">system_control_1"),
     sysent char (32) static initial ("rtdt") options (constant);

dcl  null builtin;

dcl  cu_$arg_count ext entry (fixed bin),
     nargs fixed bin;

dcl  cu_$arg_list_ptr ext entry (pointer),
     alp pointer;

	rtdtp = null ();

	call cu_$arg_list_ptr (alp);

	call cu_$arg_count (nargs);

	begin;

dcl  dirname char (168),
     ename char (32);

dcl  temp_name char (128) aligned;

dcl  cu_$arg_ptr_rel ext entry (fixed bin, pointer, fixed bin, fixed bin (35), pointer),
     ap pointer,
     al fixed bin,
     arg based (ap) char (al),
     code fixed bin (35);

dcl  com_err_ ext entry options (variable),
     expand_pathname_$add_suffix ext entry (char (*), char (*), char (*), char (*), fixed bin (35));

dcl  hcs_$initiate_count ext entry (char (*), char (*), char (*), fixed bin (24), fixed bin, pointer, fixed bin (35)),
     bc fixed bin (24);

dcl  i fixed bin,
     header_sw bit (1) aligned,
     n_names_to_match fixed bin,
     date_time_string char (24),
     attribute_string char (512) varying;

dcl  ioa_ ext entry options (variable),
     hcs_$terminate_noname ext entry (pointer, fixed bin (35)),
     date_time_ ext entry (fixed bin (52), char (*)),
     clock_ ext entry returns (fixed bin (52));

dcl (error_table_$unimplemented_version,
     error_table_$name_not_found,
     error_table_$badopt) external fixed bin (35) static;

dcl (index, length, null, pointer, reverse, string, substr) builtin,
     cleanup condition;

dcl (convert_authorization_$to_string,
     convert_authorization_$from_string) ext entry (bit (72) aligned, char (*), fixed bin (35));

dcl (SYSTEM_HIGH, SYSTEM_LOW) bit (72) aligned;

dcl  matchnames (nargs) char (32);

dcl  temp_atts (2) bit (72);

dcl  cv_rcp_attributes_$to_string_given_rtde ext entry (pointer, bit (72) dimension (2), char (*) varying, fixed bin (35));

	     call convert_authorization_$from_string (SYSTEM_LOW, "system_low", code);
	     if code ^= 0 then call crump (code, "system_low");
	     call convert_authorization_$from_string (SYSTEM_HIGH, "system_high", code);
	     if code ^= 0 then call crump (code, "system_high");

	     dirname = sysdir;
	     ename = sysent;
	     n_names_to_match = 0;
	     header_sw = "1"b;

	     do i = 1 to nargs;
		call cu_$arg_ptr_rel (i, ap, al, code, alp);
		if code ^= 0 then call crump (code, "obtaining arguments");

		if arg = "-pn" | arg = "-pathname" then do;
		     i = i + 1;
		     call cu_$arg_ptr_rel (i, ap, al, code, alp);
		     if code ^= 0 then call crump (code, "No pathname supplied.");

		     call expand_pathname_$add_suffix (arg, "rtdt", dirname, ename, code);
		     if code ^= 0 then call crump (code, arg);
		end;

		else if arg = "-nhe" | arg = "-no_header" then header_sw = ""b;

		else if substr (arg, 1, 1) = "-" then call crump (error_table_$badopt, arg);

		else do;
		     n_names_to_match = n_names_to_match + 1;
		     matchnames (n_names_to_match) = arg;
		end;
	     end;

	     on cleanup call clean_up;

/* ------------------------- */

clean_up:	     proc;
		if rtdtp ^= null then call hcs_$terminate_noname (rtdtp, 0);
	     end clean_up;

/* ------------------------- */

	     call hcs_$initiate_count (dirname, ename, "", bc, 0, rtdtp, code);
	     if rtdtp = null then
		if ename = "rtdt.rtdt" then do;
		     ename = "rtdt";
		     call hcs_$initiate_count (dirname, ename, "", bc, 0, rtdtp, code);
		end;
	     if rtdtp = null then call crump (code, "^a>^a");

	     if (rtdt.version ^= RTDT_version_2) & (rtdt.version ^= RTDT_version_3) then
		call crump (error_table_$unimplemented_version, "^a>^a");

	     if header_sw then do;
		call date_time_ (clock_ (), date_time_string);
		call ioa_ ("/*	^a>^a -- ^a	*/^/", dirname, ename, date_time_string);

		call ioa_ ("/* Author:	^a */^/", rtdt.author.proc_group_id);
	     end;

	     cttp = pointer (rtdt.charge_type_table_ptr, rtdt.rtdt_area);

	     do rtdep = pointer (rtdt.first_resource, rtdt.rtdt_area)
		     repeat (pointer (rtde.next_resource, rtdt.rtdt_area))
		     while (rtdep ^= null);

		if rtde.valid then do;
		     do i = 1 to n_names_to_match while (matchnames (i) ^= rtde.name);
		     end;

		     if (i <= n_names_to_match | n_names_to_match = 0) then do;

			if i <= n_names_to_match then matchnames (i) = "";

			call ioa_ ("^/^[Volume^;Device^]:^2-^a;", rtde.is_volume, rtde.name);

			if rtde.is_synonym then call ioa_ ("Like:^2-^a;", rtde.syn_to);

			else do;
			     temp_atts (1) = rtde.attributes_valid;
			     temp_atts (2) = rtde.attributes_to_match;
			     call cv_rcp_attributes_$to_string_given_rtde (rtdep, temp_atts, attribute_string, code);
			     if code ^= 0 then do;
				call com_err_ (code, "display_rtdt", "Error displaying attributes for ^a", rtde.name);
				attribute_string = "";
			     end;

			     attribute_string = attribute_string || ";";
			     if attribute_string = ";" then call ioa_ ("Attribute_domain:^-;");
			     else do i = 1 by 1 while (attribute_string ^= "");
				call ioa_ ("^[Attribute_domain:^-^;^2-  ^]^a", (i = 1), knockoff_50_ch (attribute_string));
			     end;

			     call ioa_ ("Limit:^2-^[open^;^d^];", (rtde.process_limit = -1), rtde.process_limit);
			     call ioa_ ("Time:^2-^[open^;^[^d^;^d, ^d^]^];", (rtde.default_time >= 4880),
				(rtde.default_time = rtde.max_time), rtde.default_time, rtde.max_time);

			     if rtde.n_mates = 0 then call ioa_ ("^[Implies^;Accepts^]:^2-;", (rtde.is_volume));

			     else call ioa_ ("^[Implies^;Accepts^]:^2-^v(^a, ^)^a;", (rtde.is_volume),
				rtde.n_mates - 1, rtde.mates (*));

			     call ioa_ ("Manual_clear:^-^[yes^;no^];", rtde.manual_clear);
			     call ioa_ ("Advance_notice:^-^[none^;^d^];", (rtde.advance_notice_time = -1),
				rtde.advance_notice_time);
			     call ioa_ ("Canonicalizer:^-^[^a^;^];", (rtdt.version = RTDT_version_3),
				rtde.precanon_proc);

			     call ioa_ ("");

			     call display_subtype (rtde.name, rtde.registration_defaults, 0);

			     do i = 1 to rtde.n_subtypes;

				call ioa_ ("^/type:^2-^a;", rtde.subtype_name (i));
				temp_name = rtrim (rtde.name) || " (" || rtrim (rtde.subtype_name (i)) || ")";
				call display_subtype (rtde.name, rtde.subtype_defaults (i), 5);
			     end;
			end;
		     end;
		end;

		if n_names_to_match = 0 then call ioa_ ("^//* --------------- */");
	     end;

	     call clean_up;
	     if n_names_to_match = 0 then call ioa_ ("^/end;");

	     else do i = 1 to n_names_to_match;
		if matchnames (i) ^= "" then call com_err_ (error_table_$name_not_found, "display_rtdt", matchnames (i));
	     end;

	     return;

display_subtype: proc (item_name, struc, indent);

dcl  item_name char (*) aligned parameter;

dcl 1 struc like rtde.registration_defaults aligned parameter;

dcl  indent fixed bin parameter;

dcl (low_auth_string, high_auth_string) char (128),
     i fixed bin;

		if struc.potential_attributes_given then do;
		     temp_atts (1) = struc.potential_attributes;
		     temp_atts (2) = ""b;
		     call cv_rcp_attributes_$to_string_given_rtde (rtdep, temp_atts, attribute_string, code);
		     if code ^= 0 then do;
			call com_err_ (code, "display_rtdt",
			     "Error displaying potential attributes for ^a", item_name);
			attribute_string = "";
		     end;

		     attribute_string = attribute_string || ";";

		     if attribute_string = ";" then
			call ioa_ ("^vxpotential_attributes: ;", indent);

		     else do i = 1 by 1 while (attribute_string ^= "");
			call ioa_ ("^[^vxpotential_attributes:^/^2-^vx^;^s^2-^vx  ^]^a", (i = 1),
			     indent, indent, knockoff_50_ch (attribute_string));
		     end;
		end;

		if struc.attributes_given then do;
		     temp_atts (1) = struc.attributes;
		     temp_atts (2) = ""b;
		     call cv_rcp_attributes_$to_string_given_rtde (rtdep, temp_atts, attribute_string, code);
		     if code ^= 0 then do;
			call com_err_ (code, "display_rtdt",
			     "Error displaying attributes for ^a", item_name);
			attribute_string = "";
		     end;

		     attribute_string = attribute_string || ";";

		     if attribute_string = ";" then
			call ioa_ ("^vxattributes: ;", indent);

		     else do i = 1 by 1 while (attribute_string ^= "");
			call ioa_ ("^[^vxattributes:^-^vx^;^s^2-^vx  ^]^a", (i = 1),
			     indent, indent, knockoff_50_ch (attribute_string));
		     end;
		end;

		if struc.charge_type_given then call ioa_ ("^vxcharge_type:^-^vx^a;",
		     indent, indent, charge_type_table.charge_types (struc.charge_type));

		if struc.aim_range_given then do;
		     code = 0;
		     if struc.aim_range (1) = SYSTEM_LOW then low_auth_string = "system_low";
		     else if struc.aim_range (1) = SYSTEM_HIGH then low_auth_string = "system_high";
		     else call convert_authorization_$to_string (struc.aim_range (1), low_auth_string, code);
		     if code ^= 0 then do;
			call com_err_ (code, "display_rtdt",
			     "While converting min access class of ^a.; assuming system_low.", item_name);
			low_auth_string = "system_low";
		     end;

		     if struc.aim_range (2) = SYSTEM_LOW then high_auth_string = "system_low";
		     else if struc.aim_range (2) = SYSTEM_HIGH then high_auth_string = "system_high";
		     else call convert_authorization_$to_string (struc.aim_range (2), high_auth_string, code);
		     if code ^= 0 then do;
			call com_err_ (code, "display_rtdt",
			     "While converting max access class of ^a; assuming system_high.", item_name);
			high_auth_string = "system_high";
		     end;

		     call ioa_ ("^vxaccess_range:^-^vx""^a : ^a"";", indent, indent, low_auth_string, high_auth_string);
		end;

		return;

	     end display_subtype;
	     
knockoff_50_ch: proc (string) returns (char (50) varying);

dcl  string char (512) varying parameter;

dcl  i fixed bin,
     temp char (50) varying;

		if length (string) <= 50 then do;
		     temp = string;
		     string = "";
		     return (temp);
		end;

		i = 51 - index (reverse (substr (string, 1, 50)), ",");
		temp = substr (string, 1, i);
		string = substr (string, i+1);

		return (temp);
	     end knockoff_50_ch;
	     
crump:	     proc (code, reason);

dcl  code fixed bin (35) parameter,
     reason char (*) parameter;

		call com_err_ (code, "display_rtdt", reason, dirname, ename);
		call clean_up;
		goto return_hard;
	     end crump;
	end;					/* end begin block */

return_hard:
	return;

     end display_rtdt;




		    dump_abs_data.pl1               10/27/83  1614.3rew 10/27/83  1441.7       85428



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


/* DUMP_ABS_DATA - Program to dump >sc1>absentee_data
   Written 751022 by PG
   Modified by T. Casey, May 1978, to dump resource list information.
   Modified by T. Casey, November 1978 for MR7.0 absentee enhancements.
   Modified by T. Casey, June 1981, for MR9.0, to dump version 2 abs_data structure.
*/

dump_abs_data:
     procedure;

/* automatic */

declare (adp, arg_ptr) ptr,
        (aix, argno, n, queuex) fixed bin,
         arg_len fixed bin (21),
         code fixed bin (35),
         date_time char (24),
         dname char (168),
         ename char (32),
         line char (136) varying,
         long bit (1) aligned;

dcl  fq fixed bin init (-1);
dcl  lq fixed bin init (4);

/* based */

declare  arg_string char (arg_len) based (arg_ptr);

/* builtins */

declare (addr, length, null, substr, unspec) builtin;

/* conditions */

declare  cleanup condition;

/* pictures */

declare  five_digits picture "zzzz9";

/* internal static */

declare  my_name char (13) internal static initial ("dump_abs_data");

dcl  lc_reasons (0:3) char (16) int static options (constant) init (
     "zero",
     "user_limit",
     "project_limit",
     "group_limit");

/* external static */

dcl  error_table_$badopt ext fixed bin (35);

/* entries */

declare  clock_ entry () returns (fixed bin (71)),
         com_err_ entry options (variable),
         cv_dec_check_ entry (char (*) aligned, fixed bin (35)) returns (fixed bin (35)),
         cu_$arg_count entry returns (fixed bin),
         cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
         date_time_ entry (fixed bin (71), char (*)),
         expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)),
         hcs_$initiate entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35)),
         hcs_$terminate_noname entry (ptr, fixed bin (35)),
         ioa_ entry options (variable);
dcl  request_id_ entry (fixed bin (71)) returns (char (19));

/* include files */

%include abs_data;

/* program */

	long = "0"b;
	dname = ">system_control_1";
	ename = "absentee_data";
	adp = null;

	do argno = 1 to cu_$arg_count ();
	     call cu_$arg_ptr (argno, arg_ptr, arg_len, code);
	     if code = 0 then do;
		if arg_string = "-lg" | arg_string = "-long" then
		     long = "1"b;
		else if arg_string = "-q" | arg_string = "-queue" then do;
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, arg_ptr, arg_len, code);
		     if code ^= 0 then do;
			call com_err_ (code, my_name, "after -queue");
			return;
		     end;
		     if arg_string = "fg" | arg_string = "foreground" then fq, lq = -1;
		     else fq, lq = cv_dec_check_ ((arg_string), code);
		     if code ^= 0 then do;
badq:			call com_err_ (0, my_name, "Illegal queue number: ""^a""", arg_string);
			return;
		     end;
		     if fq < -1 | fq > 4 then goto badq;
		end;
		else if substr (arg_string, 1, 1) = "-" then do;
		     call com_err_ (error_table_$badopt, my_name, "^a", arg_string);
		     return;
		end;
		else do;
		     call expand_pathname_ (arg_string, dname, ename, code);
		     if code ^= 0 then do;
			call com_err_ (code, my_name, "^a", arg_string);
			return;
		     end;
		end;
	     end;
	     else call com_err_ (code, my_name);
	end;					/* end loop through args */

	on cleanup call clean_up;

	call hcs_$initiate (dname, ename, "", 0, 1, adp, code);
	if adp = null then do;
	     call com_err_ (code, my_name, "^a>^a", dname, ename);
	     return;
	end;

	if absentee_data.version ^= ABS_DATA_version_2 then do; /* check for wrong version */
	     call com_err_ (0, my_name, "Incorrect structure version (^d) in ^a>^a", absentee_data.version, dname, ename);
	     return;
	end;

	call date_time_ (clock_ (), date_time);
	call ioa_ ("^/Dump of ^a>^a - ^a^/", dname, ename, date_time);

	call ioa_ ("last:^21t^d", absentee_data.last);
	line = "
FREE LIST:  ";
	do n = absentee_data.tail_free repeat (abs_info.prev_free) while (n ^= 0);
	     aip = addr (absentee_data.entry (n));
	     five_digits = n;
	     if length (line) > 70
	     then do;
		call ioa_ (line);
		line = (18)" ";
	     end;
	     line = line || five_digits;
	end;

	if length (line) > length (" FREE LIST:  ")
	then call ioa_ (line);

	do queuex = fq to lq;
	     call ioa_ ("^/QUEUE ^d", queuex);

	     line = "      SKIP LIST: ";
	     do n = absentee_data.queue_data (queuex).head_skip repeat (abs_info.next_skip)
		     while (n ^= 0);

		aip = addr (absentee_data.entry (n));
		five_digits = n;
		if length (line) > 70
		then do;
		     call ioa_ (line);
		     line = (17)" ";
		end;
		line = line || five_digits;
	     end;

	     if length (line) > length ("      SKIP LIST: ")
	     then call ioa_ (line);

	     if absentee_data.queue_data (queuex).tail_run ^= 0 then
		call ioa_ ("^2xTAIL RUN:^21t^d", absentee_data.queue_data (queuex).tail_run);

	     line = "     READY LIST: ";
	     do n = absentee_data.queue_data (queuex).head_ready repeat (abs_info.next_ready)
		     while (n ^= 0);

		aip = addr (absentee_data.entry (n));
		five_digits = n;
		if length (line) > 70
		then do;
		     call ioa_ (line);
		     line = (17)" ";
		end;
		line = line || five_digits;
	     end;

	     if length (line) > length ("     READY LIST: ")
	     then call ioa_ (line);

	     if absentee_data.queue_data (queuex).tail_resource ^= 0 then
		call ioa_ ("^2xTAIL RESOURCE:^21t^d", absentee_data.queue_data (queuex).tail_resource);

	     line = "     CPUT LIST: ";
	     do n = absentee_data.queue_data (queuex).head_cput repeat (abs_info.next_cput)
		     while (n ^= 0);

		aip = addr (absentee_data.entry (n));
		five_digits = n;
		if length (line) > 70
		then do;
		     call ioa_ (line);
		     line = (17)" ";
		end;
		line = line || five_digits;
	     end;

	     if length (line) > length ("     CPUT LIST: ")
	     then call ioa_ (line);
	end;

	line = "
DEFER LIST: ";
	do n = absentee_data.head_defer repeat (abs_info.next_defer) while (n ^= 0);
	     aip = addr (absentee_data.entry (n));
	     five_digits = n;

	     if length (line) > 70
	     then do;
		call ioa_ (line);
		line = "            ";
	     end;
	     line = line || five_digits;
	end;

	if length (line) > length (" DEFER LIST: ")
	then call ioa_ (line);

	do aix = 1 to absentee_data.last;
	     aip = addr (absentee_data.entry (aix));

	     if abs_info.queue < fq | abs_info.queue > lq then /* if user specified queue, and entry is from wrong queue */
		goto skip_this_entry;		/* then skip it */

/* Start of future dump_entry internal procedure */

	     call ioa_ ("^/ENTRY ^d", aix);
	     if abs_info.free_list then
		call ioa_ ("^xFREE");
	     else do;
		if long then do;
		     call ioa_ ("next_skip:^21t^d", abs_info.next_skip);
		     call ioa_ ("prev_skip:^21t^d", abs_info.prev_skip);

		     if abs_info.defer_list then do;
			call ioa_ ("next_defer:^21t^d", abs_info.next_defer);
			call ioa_ ("prev_defer:^21t^d", abs_info.prev_defer);
		     end;

		     if abs_info.ready_list then do;	/* if on ready list */
			call ioa_ ("next_ready:^21t^d", abs_info.next_ready);
			call ioa_ ("prev_ready:^21t^d", abs_info.prev_ready);
		     end;

		     if abs_info.cput_list then do;
			call ioa_ ("next_cput:^21t^d", abs_info.next_cput);
			call ioa_ ("prev_cput:^21t^d", abs_info.prev_cput);
		     end;

		     if abs_info.prev_free ^= 0
		     then call ioa_ ("prev_free:^21t^d", abs_info.prev_free);
		end;				/* end -long */

		call ioa_ ("queue:^21t^d", abs_info.queue);

/* CHANGE TO "switches:    sA, sB, ... " */
		if abs_info.waiting_for_resources then
		     call ioa_ ("waiting_for_resources:^21tON");
		if abs_info.can_run then call ioa_ ("can_run:^21tON");

		if abs_info.time ^= 0 then do;
		     call date_time_ (abs_info.time, date_time);
		     call ioa_ ("time:^21t^a", date_time);
		end;
		call ioa_ ("message_id:^21t^24.3b", abs_info.message_id);
		call ioa_ ("request_id:^21t^a", request_id_ (abs_info.request_id));

		if abs_info.last_message_id ^= ""b
		then call ioa_ ("last_message_id:^21t^24.3b", abs_info.last_message_id);

		call ioa_ ("user:^21t^a.^a^[^x(^a)^]", abs_info.person, abs_info.project,
		     (abs_info.group ^= ""), abs_info.group);
		if abs_info.waiting_for_load_ctl then
		     call ioa_ ("deferred:^21t^a", lc_reasons (abs_info.lc_reason));
	     end;

/* end of future dump_entry internal procedure */

skip_this_entry:
	end;

	call ioa_ ("^/END OF ABSENTEE_DATA");

	call clean_up;
	return;

clean_up:
	procedure;

	     if adp ^= null then
		call hcs_$terminate_noname (adp, code);
	     return;

	end clean_up;

/* Make a dump_entry (aix) internal procedure, from the body of text marked above.
   Call it in the 1 to last loop.
   Add alternative options to print the entries in a particular list, in list order.
   Implement that by calling print_entry with the indices of the elements in that list.
   Add options -he (= just print the header (the lists, not the entries);
   .          -nhe (= don't print the header).
*/

     end dump_abs_data;




		    dump_anstbl_.pl1                07/13/88  1112.5rew 07/13/88  0904.5      278406



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

/* format: style4 */
dump_anstbl_: proc (anp, hsw, osw, verb, sct, scu, stream);

/* DUMP_ANSTBL_ - subroutine to take a dump of the answer table.

   Called by dump_anstbl command and as_dump_.
   Modified 750506 by PG for new anstbl format
   Modified May 1976 by T. Casey and P. Green to print new anstbl variables.
   Modified June 1977 by Robert Coren to remove obsolete terminal type fields.
   Modified May 1978 by T. Casey to print new vars: pdir_lvix, logout_index, and pdir_quota.
   Modified March 1979 by T. Casey to print new variables added for MR7.0 and MR7.0a.
   Modified  July 1979 by T. Casey for MR8.0 to print process preservation variables.
   Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures. (UNCA)
   Modified January 1981 by E. N. Kittlitz for new answer_table entries
   Modified June 1981 by E. N. Kittlitz for UNCA rate structures
   Modified June 1981 by T. Casey for MR9.0 to print absentee load control variables.
   Modified November 1981, E. N. Kittlitz.  user_table_entry conversion.
   Modified 1984-09-12 BIM for login auth ranges, com channel aim.
   Modified 1984-12-31 Keith Loepere for pdir_dir_quota.
   Modified 1985-01-15 by E. Swenson to add anstbl.session_uid_counter.
   Modified 1985-03-04 by EJ Sharpe to convert audit flags to string representation
*/


/****^  HISTORY COMMENTS:
  1) change(85-11-16,Swenson), approve(87-07-13,MCR7737),
     audit(87-05-06,Parisek), install(87-08-04,MR12.1-1055):
     Added support for displaying new fields and upgraded to new date time
     code.  Also converted inline code for time breakdowns to use of
     subroutine.
  2) change(87-04-20,GDixon), approve(87-07-13,MCR7741),
     audit(87-05-06,Parisek), install(87-08-04,MR12.1-1055):
      A) Reordered output to reflect reorganization of
         user_table_entry.incl.pl1 and changes for user_table_header.incl.pl1.
      B) Improved date handling to detect unset dates and report them as such.
  3) change(87-05-13,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-14,Hartogs), install(87-08-04,MR12.1-1055):
      A) Modified to accommodate new layout of table headers and user table
         entry.
      B) Fold longer lines in a more readable fashion.
  4) change(87-05-15,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-14,Hartogs), install(87-08-04,MR12.1-1055):
      A) Handle ute.line_type.
      B) Interpret ute.preempted.
  5) change(87-05-20,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-14,Hartogs), install(87-08-04,MR12.1-1055):
      A) Correct ioa_ctl string for anstbl.update_pending.
      B) Enlarge sch_tty to hold 32 character channel names.
      C) Allow sch_tty to be a starname.
  6) change(88-03-18,Parisek), approve(88-03-18,MCR7849),
     audit(88-03-22,Lippard), install(88-07-13,MR12.2-1047):
     Add ute.lowest_ring to display items.
                                                   END HISTORY COMMENTS */


dcl  anp ptr,					/* ptr to answer table */
     hsw bit (1),					/* TRUE if header to be dumpted */
     osw bit (1),					/* TRUE if dump in octal too */
     verb fixed bin,				/* output verbe */
     sct char (*),					/* select tty chan */
     scu char (*),					/* select user */
     stream char (*);				/* output stream name */

dcl  S char (32) aligned,				/* stream name */
     out entry options(variable) variable,
     hdr bit (1),					/* header switch */
     oct bit (1),					/* octal */
     mode fixed bin,				/* output mode */
     time char (16),				/* temp */
     (on_flags, off_flags) char (128) varying aligned,	/* temp */
     rs_name char (32),
     code fixed bin (35),
     line_length fixed bin,
     tp ptr,
     vstr char (512) varying,
     audit_str char (512),
     i fixed bin,
     sch_tty char (32),
     sch_user char (32),
     sch_project char (32);

dcl  table_name char (13) aligned;
dcl  table_type fixed bin;
dcl  table_size fixed bin;
dcl  max_rs_number fixed bin;

/* builtins */

dcl  (addr, addrel, after, before, binary, char, clock, convert, fixed, hbound,
      index, lbound, length, ltrim, null, rel, rtrim, size, string, substr,
      unspec) builtin;

/* entries */

dcl  convert_access_audit_flags_$to_string entry (bit (36) aligned, char (*), fixed bin (35));
dcl  date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);
dcl  display_access_class_ entry (bit (72) aligned) returns (character (32) aligned);
dcl  display_access_class_$range entry ((2) bit (72) aligned) returns (character (32) aligned);
dcl  format_attributes_ entry (ptr, char (*) var);
dcl  get_line_length_$switch	entry (ptr, fixed bin(35)) returns(fixed bin);
dcl  ioa_$ioa_stream entry options (variable);
dcl  match_star_name_ entry (char(*), char(*), fixed bin(35));
dcl  request_id_ entry (fixed bin (71) aligned) returns (char (19));
dcl  system_info_$max_rs_number entry (fixed bin);
dcl  system_info_$rs_name entry (fixed bin, char (*), fixed bin (35));

/* structures and int static */

dcl  NL_SP char(2) int static options(constant) init("
 ");
dcl  SP_COMMA char(2) int static options(constant) init(" ,");

dcl  1 last_flag aligned based,
       2 name char(20) varying,
       2 (lower_x, upper_x) fixed bin,
       2 range char(32) varying;

dcl  1 to based (tp) aligned,
       2 w1 fixed bin,
       2 w2 fixed bin,
       2 w3 fixed bin,
       2 w4 fixed bin,
       2 w5 fixed bin,
       2 w6 fixed bin,
       2 w7 fixed bin,
       2 w8 fixed bin;

dcl  table_names (3) char (13) aligned int static options (constant) init (
	"ANSWER",
	"ABSENTEE USER",
	"DAEMON USER");

dcl  two_digits picture "99";


	table_type = PT_INTERACTIVE;			/* answer table */
	ansp = anp;
	table_size = anstbl.current_size;

common:
	table_name = table_names (table_type);
	line_length = get_line_length_$switch (null, code);
	if code ^= 0 then line_length = 79;
	call system_info_$max_rs_number (max_rs_number);	/* get number of RS */

	mode = verb;
	S = stream;
	out = ioa_$ioa_stream;
	hdr = hsw;
	oct = osw;
	sch_user = before (scu, ".");
	sch_project = after (scu, ".");
	sch_tty = sct;

	call out(S, "^/DUMP OF ^a TABLE - ^a^/", table_name,
	     cv_date (clock ()));

	if ^hdr then go to ents;

	if table_type = PT_INTERACTIVE then
	     uthp = ansp;
	else if table_type = PT_ABSENTEE then
	     uthp = autp;
	else if table_type = PT_DAEMON then
	     uthp = dutp;

	call out(S, "header_version:^21t^d", uth.header_version);
	call out(S, "entry_version:^21t^d", uth.entry_version);
	call out(S, "user_table_type:^21t^d (^a)",
	     uth.user_table_type, TABLE_NAMES(uth.user_table_type));
	call out(S, "header_length:^21t^d words", uth.header_length);
	call out(S, "max_size:^21t^d entries", uth.max_size);
	call out(S, "current_size:^21t^d entries", uth.current_size);
	call out(S, "number_free:^21t^d entries", uth.number_free);
	call out(S, "first_free:^21t^d", uth.first_free);
	call out(S, "as_procid:^21t^w", uth.as_procid);

	if table_type = PT_INTERACTIVE then do;		/* answer table */
	     call out(S, "nlin:^21t^d", anstbl.nlin);
	     call out(S, "mxlin:^21t^d", anstbl.mxlin);
	     call out(S, "n_users:^21t^d", anstbl.n_users);
	     call out(S, "max_users:^21t^d", anstbl.max_users);
	     call out(S, "n_units:^21t^d", anstbl.n_units);
	     call out(S, "max_units:^21t^d", anstbl.max_units);
	     call out(S, "n_sessions:^21t^d", anstbl.n_sessions);
	     call out(S, "sysdir:^21t^a", anstbl.sysdir);
	     call out(S, "as_tty:^21t^a", anstbl.as_tty);
	     call out(S, "login_word:^21t^a", anstbl.login_word);
	     call out(S, "session:^21t^a", anstbl.session);
	     call out(S, "special_message:^21t^a",
	        rtrim(anstbl.special_message, NL_SP));
	     call out(S, "message_update_time:^21t^a",
		cv_date (anstbl.message_update_time));
	     call out(S, "message_lng:^21t^d", anstbl.message_lng);
	     call out(S, "lock_count:^21t^d", anstbl.lock_count);
	     call out(S, "update_pending:^21t^[ON^;OFF^]",
		anstbl.update_pending);
	     call out(S, "update_channel:^21t^24.3b",
		unspec (anstbl.update_channel));
	     call out(S, "acct_update_chn:^21t^24.3b",
		unspec (anstbl.acct_update_chn));
	     call out(S, "acct_last_update_time:^21t^a",
	          cv_date (anstbl.acct_last_update_time));
	     call out(S, "acct_alarm_fail:^21t^d", anstbl.acct_alarm_fail);
	     call out(S, "current_time:^21t^a",
		cv_date (anstbl.current_time));
	     call out(S, "processid_index:^21t^d", anstbl.processid_index);
	     call out(S, "session_uid_counter:^21t^d",
		anstbl.session_uid_counter);
	     call out(S, "shift:^21t^d", anstbl.shift);
	     call out(S, "auto_maxu:^21t^d", anstbl.auto_maxu);
	     call out(S, "extra_units:^21t^d", anstbl.extra_units);
	     call out(S, "response_high:^21t^d", anstbl.response_high);
	     call out(S, "response_low:^21t^d", anstbl.response_low);
	     call out(S, "ls_request_server_event_channel:^21t^24.3b",
		unspec (anstbl.ls_request_server_event_channel));
	     call out(S, "ls_request_server_process_id:^21t^w",
		anstbl.ls_request_server_process_id);
	     call out(S, "login_server_present:^21t^[ON^;OFF^]",
		anstbl.login_server_present);
	     if oct then call odump (ansp, fixed (rel (addr (anstbl.entry (1)))));
	end;

	else if table_type = PT_ABSENTEE then do;	/* absentee user table */
	     call out(S, "n_abs_run:^21t^d", autbl.n_abs_run);
	     call out(S, "max_abs_users:^21t^d", autbl.max_abs_users);
	     call out(S, "n_background_abs:^21t^d", autbl.n_background_abs);
	     call out(S, "n_sec_fg:^21t^d", autbl.n_sec_fg);
	     call out(S, "idle_units:^21t^d", autbl.idle_units);
	     call out(S, "abs_units:^21t^d", autbl.abs_units);
	     call out(S, "n_abs(1:4):^21t^(^d^x^)", autbl.n_abs);
	     call out(S, "qres(1:4):^21t^(^d^x^)", autbl.qres);
	     call out(S, "rsc_waiting(-1:4):^21t^(^d^x^)",
		autbl.rsc_waiting);
	     call out(S, "qerr(-1:4):^21t^(^d^x^)", autbl.qerr);
	     call out(S, "cpu_limit(1:4):^21t^(^d^x^)", autbl.cpu_limit);
	     call out(S, "defer_channel:^21t^24.3b",
		unspec (autbl.defer_channel));
	     call out(S, "absentee_rq_chn:^21t^24.3b",
		unspec (autbl.absentee_rq_chn));
	     call out(S, "last_queue_searched:^x^d",
		autbl.last_queue_searched);
	     on_flags, off_flags = "";
	     if autbl.debugging = 1 then
		on_flags = "debugging, ";
	     else if autbl.debugging = 0 then
		off_flags = "debugging, ";
	     else call out(S, "debugging:^21t^d",autbl.debugging);
	     call display_flags (on_flags, off_flags, string(autbl.control),
		AUTBL_CONTROL_NAMES, "control");
	     if oct then call odump (ansp, fixed (rel (addr (autbl.entry (1)))));
	end;

	else if table_type = PT_DAEMON then do;		/* daemon user table */
	     call out(S, "active_count:^21t^d", dutbl.active_count);
	     if oct then call odump (ansp, fixed (rel (addr (dutbl.entry (1)))));
	end;

ents:	do i = 1 to table_size;
	     if table_type = PT_INTERACTIVE then
		utep = addr (anstbl.entry (i));
	     else if table_type = PT_ABSENTEE then
		utep = addr (autbl.entry (i));
	     else utep = addr (dutbl.entry (i));

	     if ute.active = NOW_FREE then
		goto skip_entry;

	     if mode > 0 then			/* be selective */
		if mode = 9 then do;
		     if sch_tty ^= "" then do;
			call match_star_name_ (ute.tty_name, sch_tty,
			     code);
			if code ^= 0 then go to skip_entry;
		     end;
		     else if sch_user ^= "" then do;
			if ute.person ^= sch_user then go to skip_entry;
			else if sch_project ^= "" then
			     if ute.project ^= sch_project then go to skip_entry;
		     end;
		     else if sch_project ^= "" then
			if ute.project ^= sch_project then go to skip_entry;
		     if ute.active <= 0 then go to skip_entry;
		end;				/* mode 9 */
		else if mode = 1 then if ute.active < 0 then go to skip_entry;
		     else if mode = 2 then if ute.lock_value <= 0 then go to skip_entry;
			else if mode = 3 then if ute.active <= 3 then go to skip_entry;
			     else if mode = 4 then if ute.active <= 2 then go to skip_entry;
				else go to skip_entry;

/* Variables which give state of this entry */
	     call out(S, "^/ENTRY ^d at ^p  ^[(^a.^a)^]", i, utep,
		(ute.person || ute.project ^= ""), ute.person, ute.project);
	     call out(S, "active:^21t^d (^a)",
		ute.active, ACTIVE_VALUES (ute.active));
	     if ute.process_type ^= table_type then
		call out(S, "process_type:^21t^d (SHOULD BE ^d)",
		ute.process_type, table_type);
	     call out(S, "ute_index:^21t^d ^[(SHOULD BE ^d)^]",
		ute.ute_index, i^=ute.ute_index, i);
	     if ute.active = NOW_FREE then
		call out(S, "next_free:^21t^d", ute.next_free);
	     else if ute.next_free ^= 0 then
		call out(S, "next_free:^21t^d (SHOULD BE 0)",
		ute.next_free);

/* Information user gave about person_id associated with this entry. */
	     call out(S, "person:^21t^a", ute.person);
	     call out(S, "project:^21t^a", ute.project);
	     call out(S, "tag:^21t^a", ute.tag);

	     on_flags = "";
	     off_flags = "";
	     if ute.anonymous = 0 then
		off_flags = "anonymous, ";
	     else if ute.anonymous = 1 then
		on_flags = "anonymous, ";
	     else call out(S, "anonymous:^21t^d", ute.anonymous);

	     if MASK_CTL_NAMES (binary (ute.mask_ctl,2)) ^= "" then do;
		on_flags = on_flags ||
		     MASK_CTL_NAMES (binary(ute.mask_ctl,2));
		on_flags = on_flags || ", ";
	     end;

	     call display_flags (on_flags, off_flags,
		substr(string(ute.login_flags),1,34), PW_FLAG_NAMES,
		"login_flags");

	     if ute.generated_pw ^= "" then
		call out(S, "generated_pw:^21t^a", ute.generated_pw);
	     if ute.old_password ^= "" then
		time = "(scramble)";
	     else time = "";
	     call out(S, "old_password:^21t^a", time);
	     call out_line("process_authorization:^21t^a", 21,
		display_access_class_ (ute.process_authorization));

/* Information user gave about process associated with this entry. */
	     call out(S, "outer_module:^21t^a", ute.outer_module);
	     call out(S, "home_dir:^21t^a", ute.home_dir);
	     call out(S, "init_proc:^21t^a",
		substr (ute.init_proc, 1, ute.ip_len));
	     call out(S, "subsystem:^21t^a",
		substr (ute.init_proc, ute.ip_len + 1));
	     call format_attributes_ (addr (ute.ur_at), vstr);
	     call out_line("ur_at:^21t^a", 21, vstr);
	     call format_attributes_ (addr (ute.at), vstr);
	     call out_line("attributes:^21t^a", 21, vstr);
	     call out(S, "initial_ring:^21t^d", ute.initial_ring);
	     call out(S, "arg_count:^21t^d", ute.arg_count);
	     call out(S, "ln_args:^21t^d", ute.ln_args);
	     call out(S, "arg_lengths_ptr:^21t^p", ute.arg_lengths_ptr);
	     call out(S, "args_ptr:^21t^p", ute.args_ptr);

/* Most of the following information is relevant only to absentee processes */
	     if table_type = PT_ABSENTEE then do;	/* absentee user table is longer than the other 2 */
		call out(S, "input_seg:^21t^a", ute.input_seg);
		call out(S, "output_seg:^21t^a", ute.output_seg);
		call out(S, "request_id:^21t^a",
		     request_id_ (ute.request_id));
		if ute.reservation_id ^= 0 then
		     call out(S, "reservation_id:^21t^24.3b",
		     unspec (ute.reservation_id));
		call out(S, "message_id:^21t^24.3b", ute.message_id);
		call out(S, "deferred_time:^21t^a",
		     cv_date (ute.deferred_time));
		call out(S, "max_cpu_time:^21t^a",
		     cv_usecs (ute.max_cpu_time * 1000000));
		call out(S, "queue:^21t^d", ute.queue);
		call out(S, "real_queue:^21t^d", ute.real_queue);
		call display_flags ("", "", string(ute.abs_attributes),
		     ABS_ATTRIBUTE_NAMES, "abs_attributes");
		call display_flags ("", "", string(ute.abs_flags),
		     ABS_FLAG_NAMES, "abs_flags");
		call out(S, "abs_group:^21t^a", ute.abs_group);
		if ute.sender ^= "" then
		     call out(S, "sender:^21t^a", ute.sender);
		if ute.proxy_person || ute.proxy_project ^= "" then
		     call out(S, "proxy:^21t^a.^a", ute.proxy_person,
		     ute.proxy_project);
	     end;					/* end of absentee specific items */

/* Information about process actually created */
	     call out(S, "proc_id:^21t^12.3b", ute.proc_id);
	     call out(S, "session_uid:^21t^d", ute.session_uid);
	     call out_line("process_authorization_range:^21t^a", 21,
		display_access_class_$range (
		ute.process_authorization_range));
	     call convert_access_audit_flags_$to_string (ute.audit,
		audit_str, code);
	     if code ^= 0
	     then call out(S, "audit:^21t^12.3b (illegal format)",
		ute.audit);
	     else call out_line("audit:^21t^a", 21, rtrim(audit_str));
	     if ute.lot_size ^= 0 then
		call out(S, "lot_size:^21t^d", ute.lot_size);
	     if ute.kst_size ^= 0 then
		call out(S, "kst_size:^21t^d", ute.kst_size);
	     if ute.cls_size ^= 0 then
		call out(S, "cls_size:^21t^d", ute.cls_size);
	     call out(S, "sus_channel:^21t^24.3b", unspec (ute.sus_channel));
	     call out(S, "lowest_ring:^21t^d", ute.lowest_ring);	     
	     call out(S, "highest_ring:^21t^d", ute.highest_ring);
	     call out(S, "pdir_lvix:^21t^d", ute.pdir_lvix);
	     call out(S, "pdir_quota:^21t^d", ute.pdir_quota);
	     call out(S, "pdir_dir_quota:^21t^d", ute.pdir_dir_quota);

/* Information about primary terminal associated with this entry */
	     call out(S, "tty_name:^21t^a", ute.tty_name);
	     call out(S, "terminal_type:^21t^a", ute.terminal_type);
	     call out(S, "line_type:^21t^a (^d)", line_types(ute.line_type),
	        ute.line_type);
	     call out(S, "tty_id_code:^21t^a", ute.tty_id_code);
	     call out(S, "network_connection_type:^21t^a",
		NETWORK_TYPE_VALUES(ute.network_connection_type));
	     call out(S, "channel:^21t^p", ute.channel);

/* Variables useful for dialed terminals */
	     call out(S, "ndialed_consoles:^21t^d", ute.ndialed_consoles);
	     if ute.dial_qualifier ^= "" then do;
		call out(S,
		"dial_qualifier:^21t^a in ring ^d",
		ute.dial_qualifier, ute.dial_server_ring);
		call display_flags ("", "", string(ute.dial_server_flags),
		     DIAL_SERVER_FLAG_NAMES, "dial_server_flags");
	     end;
	     call out(S, "dial_ev_chn:^21t^24.3b", unspec (ute.dial_ev_chn));

/* Information about usage/accounting. */
	     call out(S, "pdtep:^21t^p", ute.pdtep);
	     call out(S, "cpu_this_process:^21t^a",
		cv_usecs (ute.cpu_this_process));
	     call out(S, "cpu_usage:^21t^a", cv_usecs (ute.cpu_usage));
	     call out(S, "mem_usage:^21t^f", ute.mem_usage / 1e3);
	     call out(S, "mem_this_process:^21t^f",
		ute.mem_this_process / 1e3);
	     call out(S, "last_update_time:^21t^a",
		cv_date (ute.last_update_time));
	     call out(S, "session_cost:^21t$^.2f", ute.session_cost);
	     call out(S, "ndevices:^21t^d", ute.ndevices);
	     call out(S, "device_head:^21t^d", ute.device_head);
	     call out(S, "device_tail:^21t^d", ute.device_tail);

	     if max_rs_number > 0 then do;
		call system_info_$rs_name ((ute.rs_number), rs_name, code);
		call out(S, "rate structure: ^21t^d (^a)",
		     ute.rs_number, rs_name);
	     end;

/* Information for dialup_ (control variables). */
	     call out(S, "event:^21t^24.3b", unspec (ute.event));
	     call out(S, "uprojp:^21t^p", ute.uprojp);
	     call out(S, "login_time:^21t^a", cv_date (ute.login_time));
	     call out(S, "cant_bump_until:^21t^a",
		cv_date (ute.cant_bump_until));
	     call out(S, "recent_fatal_error_time: ^a",
		cv_date (ute.recent_fatal_error_time));
	     call out(S, "recent_fatal_error_count: ^d",
		ute.recent_fatal_error_count);
	     if ute.failure_reason ^= 0 then
		call out(S, "failure_reason:^21t^d", ute.failure_reason);
	     call out(S, "count:^21t^d", ute.count);
	     call out(S, "n_processes:^21t^d", ute.n_processes);
	     call out(S, "lock_value:^21t^d", ute.lock_value);
	     call out(S, "login_result:^21t^d (^a)", ute.login_result,
		LOGIN_RESULT_VALUES (ute.login_result));
	     call out(S, "login_code:^21t^a", ute.login_code);
	     call out(S, "preempted:^21t^d (^a)", ute.preempted,
		PREEMPT_VALUES(ute.preempted));
	     call out(S, "destroy_flag:^21t^d (^a)",
		ute.destroy_flag, TRA_VEC_VALUES (ute.destroy_flag));
	     call out(S, "logout_type:^21t^a", ute.logout_type);
	     call out(S, "logout_index:^21t^d", ute.logout_index);
	     call out(S, "disconnect rel min:^21t^d",
		ute.disconnection_rel_minutes);
	     call out(S, "next_disconnected_ate_index:^21t^d",
		ute.next_disconnected_ate_index);
	     call out(S, "work_class:^21t^d", ute.work_class);
	     call out(S, "group:^21t^a", ute.group);
	     call out(S, "whotabx:^21t^d", ute.whotabx);
	     call display_flags ("", "", string(ute.uflags), UFLAG_NAMES,
		"uflags");

/* Information used by load_ctl_ for the process */
	     call out(S, "user_weight:^21t^d", ute.user_weight);
	     call out(S, "standby_line:^21t^d", ute.standby_line);
	     call out(S, "bump_grace:^21t^a", cv_usecs (ute.bump_grace));

/* Information for login server */
	     call out(S, "ls our_handle:^21t^24.3b",
		ute.login_server_info.our_handle);
	     call out(S, "ls his_handle:^21t^24.3b",
		ute.login_server_info.his_handle);
	     call out(S, "ls termination_event_channel:^21t^24.3b",
		unspec (ute.login_server_info.termination_event_channel));
	     call out(S, "ls response_event_channel:^21t^24.3b",
		unspec (ute.login_server_info.response_event_channel));
	     call out(S, "ls process_id:^21t^w",
		ute.login_server_info.process_id);
	     if oct then call odump (utep, size (ute));
skip_entry:
	end;

	call out(S, "^/END ^a TABLE^/", table_name);
	return;

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


dump_autbl_: entry (anp, hsw, osw, verb, sct, scu, stream);

	table_type = PT_ABSENTEE;			/* 2 = absentee */
	autp = anp;				/* autbl is based on p */
	table_size = autbl.current_size;
	goto common;

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


dump_dutbl_: entry (anp, hsw, osw, verb, sct, scu, stream);

	table_type = PT_DAEMON;			/* 3 = daemon */
	dutp = anp;				/* dut is based on dutp */
	table_size = dutbl.current_size;
	goto common;

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

cv_date:	procedure (clock_value) returns (char(250) varying);

dcl  clock_value fixed bin(71);
	
	if clock_value = 0 then
	     return ("(unset)");
	else return (date_time_$format ("date_time", clock_value, "", ""));

	end cv_date;

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


cv_usecs:
     procedure (P_usecs) returns (char (32));

dcl  P_usecs fixed bin (71) parameter;			/* number of micro seconds */

dcl  code fixed bin (35) automatic;
dcl  time char (32) automatic;
dcl  1 time_offset_auto aligned like time_offset automatic;

dcl  date_time_$from_clock_interval entry (fixed bin (71), fixed bin (71), ptr,
	fixed bin (35));
dcl  ioa_$rsnnl entry () options (variable);

	Ptime_offset = addr (time_offset_auto);
	unspec (time_offset) = ""b;
	time_offset.version = Vtime_offset_2;
	time_offset.flag.hr = 1;
	time_offset.flag.min = 1;
	time_offset.flag.sec = 1;
	call date_time_$from_clock_interval (0, P_usecs, Ptime_offset, code);
	if code ^= 0 then
	     return ("-Invalid Time-");
	else do;
	     call ioa_$rsnnl ("^d hours, ^d mins, ^d secs", time, (0),
		time_offset.val.hr, time_offset.val.min, time_offset.val.sec);
	     return (time);
	end;

/* format: off */
%include time_offset;
/* format: on */
     end cv_usecs;

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


display_flags:
     	procedure (init_on_flags, init_off_flags, flag_bits, flag_names,
	     heading);

dcl (init_on_flags, init_off_flags) char(*) varying;
dcl  flag_bits bit(36) aligned;
dcl  flag_names (*) char (*) varying;
dcl  heading char(*);

dcl  j fixed bin;
dcl (on_flags, off_flags) char(512) varying;
dcl  1 (on_lflags, off_lflags) aligned like last_flag;

	call FLAG_init (init_on_flags, on_flags, on_lflags);
	call FLAG_init (init_off_flags, off_flags, off_lflags);
	do j = lbound (flag_names, 1) to hbound (flag_names, 1);
	     if substr (flag_bits, j, 1) then
		call FLAG_set (on_flags, on_lflags, flag_names(j));
	     else call FLAG_set (off_flags, off_lflags, flag_names(j));
	end;
	do j = j to length(flag_bits);		/* print any new flags whose names we don't know yet */
	     if substr (flag_bits, j, 1) then do;
		two_digits = j;
		call FLAG_set (on_flags, on_lflags,
		     heading || "(" || two_digits || ")");
	     end;
	end;
	call FLAG_emit (on_flags, on_lflags);
	call FLAG_emit (off_flags, off_lflags);
	if on_flags ^= "" then
	     on_flags = rtrim(on_flags, SP_COMMA);
	if off_flags ^= "" then
	     off_flags = rtrim(off_flags, SP_COMMA);
	if on_flags ^= "" then do;
	     call out_line(heading || ":^21tON:  ^a", 26, on_flags);
	     if off_flags ^= "" then
		call out_line("^21tOFF: ^a", 26, off_flags);
	end;
	else if off_flags ^= "" then 
	     call out_line(heading || ":^21tOFF: ^a", 26, off_flags);

	end display_flags;

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

FLAG_emit:
     	procedure (flag_string, lflag);

dcl  flag_string_init char(*) varying;
dcl  flag_string char(512) varying;
dcl  flag_name char(*) varying;
dcl  1 lflag aligned like last_flag;

	if lflag.name ^= "" then
	     call FLAG_ARRAY_emit (flag_string, lflag);	     
	return;
	

FLAG_init:
     	entry (flag_string_init, flag_string, lflag);

	flag_string = flag_string_init;
	call FLAG_ARRAY_init (lflag);
	return;


FLAG_set:	entry (flag_string, lflag, flag_name);

	if index(flag_name, "(") > 0 then do;		/* new flag array*/
	     if lflag.name ^= "" then do;		/* old flag array*/
		if before(flag_name, "(") = lflag.name then 
						/* same flag     */
		     call FLAG_ARRAY_set_upper (flag_name, lflag);
		else do;				/* different flag*/
		     call FLAG_ARRAY_emit (flag_string, lflag);
		     call FLAG_ARRAY_set_lower (flag_name, lflag);
		end;
	     end;
	     else					/* no old flag   */
		call FLAG_ARRAY_set_lower (flag_name, lflag);
	end;
	else do;
	     if lflag.name ^= "" then			/* old flag array*/
		call FLAG_ARRAY_emit (flag_string, lflag);
	     flag_string = flag_string || flag_name;
	     flag_string = flag_string || ", ";
	     end;
	end FLAG_emit;

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


FLAG_ARRAY_emit:
     	procedure (flag_string, lflag);
	
dcl  flag_name char(*) varying;
dcl  flag_string char(512) varying;
dcl  1 lflag aligned like last_flag;

dcl  flag_x fixed bin;

	flag_string = flag_string || lflag.name;
	flag_string = flag_string || "(";
	if lflag.range ^= "" then do;
	     flag_string = flag_string || lflag.range;
	     flag_string = flag_string || ";";
	     end;
	flag_string = flag_string || ltrim(char(lflag.lower_x));
	if lflag.lower_x ^= lflag.upper_x then do;
	     flag_string = flag_string || ":";
	     flag_string = flag_string || ltrim(char(lflag.upper_x));
	     end;
	flag_string = flag_string || ")";
	flag_string = flag_string || ", ";
	

FLAG_ARRAY_init:
	entry (lflag);

	lflag.name = "";
	lflag.lower_x, lflag.upper_x = 0;
	lflag.range = "";
	return;
	

FLAG_ARRAY_set_lower:
	entry (flag_name, lflag);

	flag_x = convert (flag_x, before (after (flag_name, "("), ")"));
	lflag.name = before (flag_name, "(");
	lflag.lower_x, lflag.upper_x = flag_x;
	lflag.range = "";
	return;

FLAG_ARRAY_set_upper:
	entry (flag_name, lflag);

	flag_x = convert (flag_x, before (after (flag_name, "("), ")"));
	if flag_x = lflag.upper_x + 1 then
	     lflag.upper_x = flag_x;
	else do;
	     if lflag.range ^= "" then
		lflag.range = ";";
	     lflag.range = lflag.range || ltrim(char(lflag.lower_x));
	     if lflag.lower_x ^= lflag.upper_x then do;
		lflag.range = lflag.range || ":";
		lflag.range = lflag.range || ltrim(char(lflag.upper_x));
	     end;
	     lflag.lower_x, lflag.upper_x = flag_x;
	end;
          end FLAG_ARRAY_emit;

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


odump: proc (loc, nw);
dcl  loc ptr, nw fixed bin;

dcl  kk fixed bin;

	do kk = 0 to nw - 1 by 8;
	     tp = addrel (loc, kk);
	     call out(S, "^4o ^w ^w ^w ^w ^w ^w ^w ^w", kk,
		to.w1, to.w2, to.w3, to.w4,
		to.w5, to.w6, to.w7, to.w8);
	end;

     end odump;

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


out_line:	procedure (ioa_ctl, continue_col, value);
	
dcl  ioa_ctl char(*);
dcl  continue_col fixed bin;
dcl  value char(*) varying;

dcl  cur_ioa char(60) varying;
dcl  cur_line char(512) varying;
dcl  data_region fixed bin;
dcl  remainder char(512) varying;

dcl  NON_COMMA_CHARS char(97) int static options(constant) init(
 "!""#$%&'()=~|1234567890-^\`@{}[]+*/.<>;:_
	abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ");

	cur_ioa = ioa_ctl;
	data_region = line_length - (continue_col-1);
	remainder = value;
	do while (length(remainder) > data_region);
	     cur_line = substr(remainder,1,data_region);
	     cur_line = rtrim(cur_line, NON_COMMA_CHARS);
	     if cur_line = "" then do;
		cur_line = before (remainder, ",");
		if cur_line ^= remainder then
		     cur_line = cur_line || ",";
	     end;
	     remainder = after (remainder, cur_line);
	     cur_line = ltrim(cur_line);
	     call out(S, cur_ioa, cur_line);
	     cur_ioa = "^" || ltrim(char(continue_col)) || "t^a";
	     end;
	if remainder ^= "" then do;
	     remainder = ltrim(remainder);
	     call out(S, cur_ioa, remainder);
	end;
	end out_line;

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

/* format: off */
 %include absentee_user_table;
 %include answer_table;
 %include daemon_user_table;
 %include dialup_values;
 %include line_types;
 %include net_event_message;
 %include ttyp;
 %include user_attributes;
 %include user_table_entry;
 %include user_table_header;

dcl	1 uth			aligned like ut_header based(uthp),
	uthp			ptr;

     end dump_anstbl_;




		    dump_cdt_.pl1                   10/25/89  1201.0r w 10/25/89  1004.1      236574



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

/* Subroutine to dump the CDT, all fields.
   THVV
   Modified by Mike Grady 5/11/76 to convert to version 2 CDT
   Modified by T. Casey, November 1976 to dump some variables omitted from previous version.
   Modified by Robert Coren, June 1977, for new terminal type fields and dont_read_answerback attribute.
   Modified by T. Casey, September 1977, to get device charge name from installation_parms.
   Modified January 1979 by Larry Johnson for multiplexer data.
   Modified April 1979 by Larry Johnson for new things in fnpe's.
   Modified 1979 May 25 by Art Beattie to accomodate change in cdt.incl.pl1.
   Modified November 1979 by T. Casey for MR8.0 to dump process preservation variables.
   Modified January 1981 by E. N. Kittlitz to eliminate cdte.phone_no.
   Modified July 1981 by T. Casey for MR9.0 to dump some new cdte variables.
   Modified December 1981 (but barely) for trees in the cdt by Benson I. Margulies.
   Modified August 1982 (even less) by E. N. Kittlitz for masked channel state.
   Modified August 1982 by E. N. Kittlitz for check_acs.
   Modified January 1983 by Keith Loepere for generic_destination.
   Modified 831216 by E. N. Kittlitz for required_access_class.
   Modified 84-03-22 BIM for full AIM support, removed obsolete fields.
*/


/****^  HISTORY COMMENTS:
  1) change(87-03-31,Beattie), approve(87-04-06,MCR7656),
     audit(87-07-14,Parisek), install(87-08-04,MR12.1-1055):
     Display new variables that support use of IOCBs in answering service.
                                                   END HISTORY COMMENTS */


/* format: style4 */

dump_cdt_: procedure (Info_ptr, Code);

/* parameters */

dcl  Info_ptr pointer;
dcl  Code fixed bin (35);

/* automatic */

dcl  (i, n) fixed bin;
declare  found_a_match bit (1) aligned;
dcl  (time, avg) float bin;
dcl  indent fixed bin;
dcl  (fnpx, cdtx) fixed bin;
dcl  fnp_find_sw bit (1) aligned;
dcl  temp_dev_name char (8);
dcl  code fixed bin (35);
dcl  error character (100) aligned;

dcl  1 devtab_copy (16) aligned,
       2 device_id char (8) unal,
       2 device_price (0:7) float bin;

dcl  two_digits picture "99";

dcl  visited (2711) bit (1) unaligned;
dcl  tcount fixed bin;

dcl  1 CI aligned like condition_info;

/* internal static */

dcl  fnp_tags (8) char (1) int static options (constant) init
	("a", "b", "c", "d", "e", "f", "g", "h");

dcl  attribute_flag_names (5) char (32) varying int static options (constant) init
	("ck_answerback",
	"audit_access_error",
	"hardwired",
	"set_modes",
	"dont_read_answerback");

dcl  option_flag_names (9) char (32) varying int static options (constant) init
	("execute_initial_command",
	"attached_by_operator",
	"private_line",
	"bsc_ebcdic",
	"bsc_transparent",
	"vip_poll_select",
	"autobaud",
	"generic_destination_present",
	"use_iocb");

dcl  access_check_flag_names (5) char (32) varying init (
	"dial_out",
	"priv_attach",
	"dial_server",
	"login",
	"dial_slave") int static options (constant);

dcl  dialup_flag_names (11) char (32) varying int static options (constant) init
	("ppm",
	"cpo",
	"wakeup_handler",
	"save_arg",
	"nosave_arg",
	"detach_after_hangup",
	"leave_edited",
	"hold_arg",
	"no_hold_arg",
	"immediate_arg",
	"current_access_class_valid");

/* entries */

dcl  convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  find_condition_info_ entry (ptr, ptr, fixed bin (35));
dcl  ioa_$ioa_switch entry options (variable);
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  convert_authorization_$to_string_range_short entry ((2) bit (72) aligned, character (*),
	fixed binary (35));
dcl  convert_authorization_$to_string_short entry (bit (72) aligned, character (*), fixed binary (35));
dcl  system_info_$device_prices entry (fixed bin, ptr);
dcl  cdt_mgr_$find_cdt_channel entry (ptr, char (32), fixed bin, bit (1) aligned, fixed bin (35));
dcl  match_star_name_ entry (char (*), char (*), fixed bin (35));

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

/* builtins */

dcl  (addr, divide, fixed, float, hbound, lbound, length, low, ltrim, null, rtrim, string, substr) builtin;

dcl  sub_error_ condition;

/* include files */

%include dump_cdt_args_;

%page;
%include cdt;

%page;
%include author_dcl;
%page;
%include dialup_values;
%page;
%include multiplexer_types;
%page;
%include condition_info_header;
%include sub_error_info;
%include condition_info;

/* ====================================================== */

	Code = 0;
	dca_ptr = Info_ptr;
	cdtp = dump_cdt_args.cdt_ptr;
	indent = 0;

	call system_info_$device_prices ((0), addr (devtab_copy));

	if dump_cdt_args.hdr then do;
	     call ioa_$ioa_switch (switch, "^/Channel Definition Table^/");
	     call ioa_$ioa_switch (switch, "author.proc_group_id:^32t^a", cdt.author.proc_group_id);
	     call ioa_$ioa_switch (switch, "author.lock:^32t^w", cdt.author.lock);

	     call ioa_$ioa_switch (switch, "author.last_install_time:^32t^a", edit_time (cdt.author.last_install_time));
	     call ioa_$ioa_switch (switch, "^31a^a", "author.table:", cdt.author.table);
	     call ioa_$ioa_switch (switch, "author.w_dir:^32t^a", cdt.author.w_dir);
	     call ioa_$ioa_switch (switch, "max_size:^32t^d", cdt.max_size);
	     call ioa_$ioa_switch (switch, "current_size:^32t^d", cdt.current_size);
	     call ioa_$ioa_switch (switch, "version:^32t^d", cdt.version);
	     call ioa_$ioa_switch (switch, "freep:^32t^d", cdt.freep);
	     call ioa_$ioa_switch (switch, "n_cdtes:^32t^d", cdt.n_cdtes);
	     call ioa_$ioa_switch (switch, "meters_last_reset:^32t^a", edit_time (cdt.meters_last_reset));

	     if cdt.realtime_in_dialup ^= 0 then do;
		n = cdt.entries_to_dialup;
		time = cdt.realtime_in_dialup / 1e6;
		avg = time / n;
		call ioa_$ioa_switch (switch, "realtime_in_dialup:^32t^.1f sec^51t^.1f sec avg",
		     time, avg);
		time = cdt.cpu_in_dialup / 1e6;
		avg = time / n;
		call ioa_$ioa_switch (switch, "cpu_in_dialup:^32t^.1f sec^51t^.1f sec avg",
		     time, avg);
		call ioa_$ioa_switch (switch, "pf_in_dialup:^32t^d^51t^d avg",
		     cdt.pf_in_dialup, divide (cdt.pf_in_dialup, n, 17, 0));
		call ioa_$ioa_switch (switch, "pp_in_dialup:^32t^d^51t^d avg",
		     cdt.pp_in_dialup, divide (cdt.pp_in_dialup, n, 17, 0));
		call ioa_$ioa_switch (switch, "entries_to_dialup:^32t^d", cdt.entries_to_dialup);
	     end;
	     call ioa_$ioa_switch (switch, "FNP_required_up_time:^32t^d minutes", cdt.acceptable_fnp_tbf);
	     call ioa_$ioa_switch (switch, "Spare_channel_count:^32t^d", cdt.spare_channel_count);
	     call ioa_$ioa_switch (switch, "");
	end;

	if ^dump_cdt_args.all & ^dump_cdt_args.starname	/* one chan */
	then do;
	     if dump_cdt_args.channel_name = ""
	     then return;				/* just the header */
	     call cdt_mgr_$find_cdt_channel (cdtp, (dump_cdt_args.channel_name), cdtx, fnp_find_sw, code);
	     if code ^= 0
	     then do;
		Code = code;
		return;
	     end;

	     if fnp_find_sw
	     then do;
		if ^dump_cdt_args.subtree
		then call print_fnpe (-cdtx);
		else do;
		     if ^dump_cdt_args.brief
		     then call print_fnpe (-cdtx);
		     call show_children (addr (cdt.fnp_entry (-cdtx).threads), cdtx, "1"b);
		end;
	     end;
	     else do;
		if ^dump_cdt_args.subtree
		then call print_cdte (addr (cdt.cdt_entry (cdtx)));
		else do;
		     if ^dump_cdt_args.brief
		     then call print_cdte (addr (cdt.cdt_entry (cdtx)));
		     call show_children (addr (cdt.cdt_entry (cdtx).threads), cdtx, "0"b);
		end;
	     end;
	     return;
	end;


	if dump_cdt_args.all
	then do;
	     call dump_tree;
	     return;
	end;

/* Starname, may be fnp */

	found_a_match = "0"b;

	do fnpx = 1 to hbound (cdt.fnp_entry, 1);
	     fnpep = addr (cdt.fnp_entry (fnpx));
	     if fnpe.state ^= FNP_FREE
	     then do;
		call match_star_name_ (substr (collate (), rank ("a") + fnpx, 1), (dump_cdt_args.channel_name), code);
		if code = 0 then do;
		     found_a_match = "1"b;
		     if ^dump_cdt_args.subtree then
			if ^dump_cdt_args.brief then call print_fnpe (fnpx);
			else call ioa_$ioa_switch (switch, "^2xFNP ^a (^d,^p)", substr (collate (), rank ("a") + fnpx, 1), fnpx, fnpep);
		     else do;
			if ^dump_cdt_args.brief then call print_fnpe (fnpx);
			if fnpe.threads.daughter_count = 0 & fnpe.threads.daughter = 0
			then ;
			else call show_children (addr (fnpe.threads), -fnpx, "1"b);
		     end;
		end;
	     end;
	end;

/* Or it may be a non-FNP */

	do i = 1 to cdt.current_size;
	     cdtep = addr (cdt.cdt_entry (i));
	     if cdte.in_use ^= NOW_FREE then do;
		call match_star_name_ ((cdte.name), (dump_cdt_args.channel_name), code);
		if code = 0 then do;
		     found_a_match = "1"b;
		     if ^dump_cdt_args.subtree
		     then if ^dump_cdt_args.brief
			then call print_cdte (cdtep);
			else call ioa_$ioa_switch (switch, "Channel ^a (^d,^p)",
				cdte.name, i, cdtep);
		     else do;
			if ^dump_cdt_args.brief
			then call print_cdte (cdtep);
			call show_children (addr (cdt.cdt_entry (i).threads), cdtx, "0"b);
		     end;
		end;
	     end;
	end;

	if ^found_a_match
	then Code = error_table_$nomatch;
	return;

print_fnpe: proc (n);

dcl  n fixed bin;
dcl  mpx_type fixed bin;
dcl  bb72 bit (72) aligned based;

	fnpep = addr (cdt.fnp_entry (n));
	mpx_type = fnpe.mpx_type;
	if mpx_type = 0 then mpx_type = MCS_MPX;

	call ioa_$ioa_switch (switch, "^/FNPE at ^p (FNP ^a)^/", fnpep, edit_desc (n, fnp_tags));

	if fnpe.type ^= 0 | mpx_type = MCS_MPX then
	     call ioa_$ioa_switch (switch, "^5xtype:^26x^d (^a)", fnpe.type, edit_desc (fnpe.type, fnp_types));
	if fnpe.memory ^= 0 | mpx_type = MCS_MPX then
	     call ioa_$ioa_switch (switch, "^5xmemory:^24x^dK", fnpe.memory);
	if fnpe.nlslas ^= 0 | (mpx_type = MCS_MPX & fnpe.type ^= DN6670) then
	     call ioa_$ioa_switch (switch, "^5xlslas:^25x^d", fnpe.nlslas);
	if fnpe.nhslas ^= 0 | mpx_type = MCS_MPX then
	     call ioa_$ioa_switch (switch, "^5xhslas:^25x^d", fnpe.nhslas);
	call ioa_$ioa_switch (switch, "^5xboot event chan:^15x^24.3b", addr (fnpe.boot_ev_chan) -> bb72);
	if mpx_type = MCS_MPX then
	     call ioa_$ioa_switch (switch, "^5xcoreimage:^21x^a", fnpe.coreimage);
	else if fnpe.coreimage ^= "" then
	     call ioa_$ioa_switch (switch, "^5xadditional_info:^15x^a", fnpe.coreimage);
	mpxep = addr (fnpe.mpxe);
	call print_mpxe (fnpe.service_type, mpx_type);
	call ioa_$ioa_switch (switch, "^/");
	return;

     end print_fnpe;

print_mpxe: proc (a_service, a_type);

dcl  a_service fixed bin;
dcl  a_type fixed bin;

dcl  fnp_states (0:4) char (15) int static options (constant) init (
	"not configured",
	"unknown",
	"down",
	"boot started",
	"up");
dcl  mpx_service_types (0:7) char (12) int static options (constant) init (
	"", "active", "", "", "", "", "", "inactive");

	call ioa_$ioa_switch (switch, "^vx^5xMultiplexer data:", indent
	     );
	call ioa_$ioa_switch (switch, "^vx^6xservice_type:^37t^d (^a)", indent, a_service,
	     edit_desc (a_service, mpx_service_types));
	call ioa_$ioa_switch (switch, "^vx^6xmpx_type:^37t^d (^a)", indent, a_type, edit_desc (a_type, mpx_types));
	call ioa_$ioa_switch (switch, "^vx^6xstate:^37t^d (^a)", indent, mpxe.state, edit_desc (mpxe.state, fnp_states));
	call print_time ("initial load:", mpxe.time_initial_load);
	call print_time ("last load:", mpxe.time_last_load);
	call print_time ("last crash:", mpxe.time_last_crash);
	call print_time ("load started:", mpxe.time_load_start);
	call ioa_$ioa_switch (switch, "^vx^6xflags.go:^37t^d", indent, fixed (mpxe.flags.go));
	call ioa_$ioa_switch (switch, "^vx^6xflags.listening:^37t^d", indent, fixed (mpxe.flags.listening));
	call ioa_$ioa_switch (switch, "^vx^6xcurrent_service_type:^37t^d (^a)", indent, mpxe.current_service_type,
	     edit_desc (mpxe.current_service_type, mpx_service_types));
	if mpxe.current_mpx_type ^= 0 then
	     call ioa_$ioa_switch (switch, "^vx^6xcurrent_mpx_type:^37t^d (^a)", indent, mpxe.current_mpx_type,
		edit_desc (mpxe.current_mpx_type, mpx_types));
	call ioa_$ioa_switch (switch, "^vx^6xn_bootloads:^37t^d", indent, mpxe.n_bootloads);
	call ioa_$ioa_switch (switch, "^6xlast_tbf:^37t^d", mpxe.last_tbf);
	return;




print_time: proc (name, time);

dcl  name char (*),
     time fixed bin (71);

	     call ioa_$ioa_switch (switch, "^vx^6x^a^37t^a", indent, name, edit_time (time));
	     return;

	end print_time;

     end print_mpxe;

print_cdte: proc (CDTEp);

dcl  (hrs, mins, secs) fixed bin;
dcl  auth_string char (200);
dcl  bb72 bit (72) based;
dcl  code fixed bin (35);
dcl  CDTEp pointer;
dcl  1 CDTE aligned like cdte based (CDTEp);

/* ----------------------------------------------- */

	call ioa_$ioa_switch (switch, "^vx^/CDTE at ^p^/", indent, CDTEp);

	call ioa_$ioa_switch (switch, "^vx^5xin_use:^24x^d (^a)", indent, CDTE.in_use, edit_desc (CDTE.in_use, uses));
	call ioa_$ioa_switch (switch, "^vx^5xname:^26x^a", indent, CDTE.name);
	if CDTE.current_service_type = MPX_SERVICE |
	     (CDTE.service_type = MPX_SERVICE & CDTE.current_service_type = 0) then do; /* running mpx, or mpx in new cdt */
	     mpxep = addr (CDTE.initial_command);
	     call print_mpxe ((CDTE.mpx_service), (CDTE.mpx_type));
	end;
	call convert_authorization_$to_string_range_short (CDTE.access_class, auth_string, code);
	if auth_string = "" then auth_string = "system_low";
	call ioa_$ioa_switch (switch, "^vx^5xaccess_class:^18x^a", indent, auth_string);
	call ioa_$ioa_switch (switch, "^vx^5xcomment:^23x^a", indent, CDTE.comment);
	if CDTE.charge_type < lbound (devtab_copy.device_id, 1) then temp_dev_name = "none";
	else if CDTE.charge_type > hbound (devtab_copy.device_id, 1) then temp_dev_name = "?";
	else temp_dev_name = devtab_copy.device_id (CDTE.charge_type);
	call ioa_$ioa_switch (switch, "^vx^5xcharge_type:^19x^d (^a)", indent, CDTE.charge_type, temp_dev_name);
	call ioa_$ioa_switch (switch, "^vx^5xservice_type:^18x^d (^a)", indent, CDTE.service_type,
	     edit_desc ((CDTE.service_type), service_types));
	call ioa_$ioa_switch (switch, "^vx^5xcurrent_service_type:^10x^d (^a)", indent, CDTE.current_service_type,
	     edit_desc ((CDTE.current_service_type), service_types));
	call ioa_$ioa_switch (switch, "^vx^5xline_type:^21x^d (^a)", indent, CDTE.line_type,
	     edit_desc ((CDTE.line_type), line_types));
	if CDTE.flags.ck_answerback then
	     call ioa_$ioa_switch (switch, "^vx^5xanswerback:^20x^a", indent, CDTE.answerback);
	call ioa_$ioa_switch (switch, "^vx^5xterminal_type:^17x^a", indent, string_edit ((CDTE.initial_terminal_type)));
	call ioa_$ioa_switch (switch, "^vx^5xbaud_rate:^21x^d", indent, CDTE.baud_rate);
	if CDTE.modem_type > 0 then call ioa_$ioa_switch (switch, "^vx^5xmodem_type:^20x^d (^a)", indent, CDTE.modem_type,
		edit_desc ((CDTE.modem_type), dataset_names));
	if string (CDTE.flags.attributes) then
	     call ioa_$ioa_switch (switch, "^vx^5xflags.attributes:^37t^a", indent,
		flag_names (string (CDTE.flags.attributes), attribute_flag_names));
	if string (CDTE.flags.options) then
	     call ioa_$ioa_switch (switch, "^vx^5xflags.options:^37t^a", indent,
		flag_names (string (CDTE.flags.options), option_flag_names));
	if string (CDTE.flags.access_control) then
	     call ioa_$ioa_switch (switch, "^vx^5xflags.access_control:^37t^a", indent, flag_names (string (CDTE.flags.access_control), access_check_flag_names));
	if CDTE.flags.execute_initial_command then
	     call ioa_$ioa_switch (switch, "^vx^5xinitial_command:^15x^a", indent, CDTE.initial_command);
	if CDTE.flags.generic_destination_present then
	     call ioa_$ioa_switch (switch, "^vx^5xgeneric_destination:^11x^a", indent, addr (CDTE.initial_command) -> generic_destination);
	call ioa_$ioa_switch (switch, "^vx^5xevent:^25x^24.3b", indent, addr (CDTE.event) -> bb72);
	call ioa_$ioa_switch (switch, "^vx^5xtra_vec:^23x^d (^a)", indent, CDTE.tra_vec,
	     edit_desc ((CDTE.tra_vec), tra_vec_names));
	call ioa_$ioa_switch (switch, "^vx^5xcount:^25x^d", indent, CDTE.count);
	if string (CDTE.dialup_flags) then
	     call ioa_$ioa_switch (switch, "^vx^5xdialup_flags:^37t^a", indent,
		flag_names (string (CDTE.dialup_flags), dialup_flag_names));
	call ioa_$ioa_switch (switch, "^vx^5xtwx:^27x^d", indent, CDTE.twx);
	call ioa_$ioa_switch (switch, "^vx^5xstate:^20x^5x^d (^a)", indent, CDTE.state, edit_desc (CDTE.state, states));
	call ioa_$ioa_switch (switch, "^vx^5xcurrent_terminal_type:^9x^a", indent, string_edit ((CDTE.current_terminal_type)));
	call ioa_$ioa_switch (switch, "^vx^5xcur_line_type:^17x^d (^a)", indent, CDTE.cur_line_type,
	     edit_desc ((CDTE.cur_line_type), line_types));
	call convert_authorization_$to_string_short (CDTE.current_access_class (1), auth_string, code);
	if auth_string = "" then auth_string = "system_low";
	call ioa_$ioa_switch (switch, "^vx^5xcurrent_access_class:^10x^a", indent, auth_string);
	call ioa_$ioa_switch (switch, "^vx^5xtty_id_code:^19x^a", indent, string_edit (CDTE.tty_id_code));
	call ioa_$ioa_switch (switch, "^vx^5xprocess:^23x^p", indent, CDTE.process);
	if CDTE.dialed_to_procid ^= ""b then
	     call ioa_$ioa_switch (switch, "^vx^5xdialed_to_procid:^14x^w", indent, CDTE.dialed_to_procid);
	call ioa_$ioa_switch (switch, "^vx^5xnext_channel:^15x^3x^d", indent, CDTE.next_channel);
	call ioa_$ioa_switch (switch, "^vx^5xdial_ctl_ring:^14x^3x^d", indent, CDTE.dial_ctl_ring);
	call ioa_$ioa_switch (switch, "^vx^5xuser_name:^21x^a", indent, string (CDTE.user_name));
	if CDTE.disconnected_ate_index ^= 0 then
	     call ioa_$ioa_switch (switch, "^vx^5xdisconnected_ate_index:^37t^d", indent, CDTE.disconnected_ate_index);
	call ioa_$ioa_switch (switch, "^vx^5xn_dialups:^21x^d", indent, CDTE.n_dialups);
	call ioa_$ioa_switch (switch, "^vx^5xn_logins:^22x^d", indent, CDTE.n_logins);
	secs = float (CDTE.dialed_up_time, 63);
	mins = divide (secs, 60, 35, 0);
	secs = secs - mins * 60;
	hrs = divide (mins, 60, 35, 0);
	mins = mins - hrs * 60;
	call ioa_$ioa_switch (switch, "^vx^5xdialed_up_time:^16x^d hrs ^d mins ^d secs.", indent, hrs, mins, secs);
	call ioa_$ioa_switch (switch, "^vx^5xdialup_time:^19x^a", indent, edit_time (CDTE.dialup_time));
	if CDTE.disconnected_proc_command ^= 0 then
	     call ioa_$ioa_switch (switch, "^vx^5xdisconnected_proc_command:^37t^d", indent, CDTE.disconnected_proc_command);
	if CDTE.disconnected_proc_number ^= 0 then
	     call ioa_$ioa_switch (switch, "^vx^5xdisconnected_proc_number:^37t^d", indent, CDTE.disconnected_proc_number);
	if CDTE.n_disconnected_procs ^= 0 then
	     call ioa_$ioa_switch (switch, "^vx^5xn_disconnected_procs:^37t^d", indent, CDTE.n_disconnected_procs);
	call ioa_$ioa_switch (switch, "^vx^5xrecent_wakeup_count:^37t^d", indent, CDTE.recent_wakeup_count);
	call ioa_$ioa_switch (switch, "^vx^5xrecent_wakeup_time:^37t^a", indent, edit_time (CDTE.recent_wakeup_time));
	if CDTE.dial_ev_chn ^= 0 then
	     call ioa_$ioa_switch (switch, "^vx^5xdial_ev_chn:^37t^24.3b", indent, addr (CDTE.dial_ev_chn) -> bb72);
	if CDTE.use_iocb then
	     call ioa_$ioa_switch (switch, "^vx^5xiocbp:^37t^p", indent, CDTE.iocbp);

	return;

%include line_types;

%include dataset_names;


dcl  service_types (9) char (12) static options (constant) init (
	"login",
	"ftp",
	"mc",
	"slave",
	"dial",
	"dial out",
	"inactive",
	"multiplexer",
	"tandd");

dcl  states (-1:5) char (15) int static options (constant) init
	("masked", "", "hung up", "listening", "", "", "dialed up");

dcl  uses (-2:7) char (18) int static options (constant) init
	("deleted", "not configured", "unused, free", "hung up", "listening",
	"dialed", "logged in, no proc", "logged in & proc",
	"dialing", "dialed out");

dcl  tra_vec_names (0:25) char (32) int static options (constant) init (
	"",
	"wait_dialup",
	"wait_answerback",
	"wait_login_line",
	"wait_login_args",
	"wait_old_password",
	"wait_password",
	"wait_new_password",
	"wait_logout_sig",
	"wait_logout",
	"wait_logout_hold",
	"wait_detach",
	"wait_new_proc",
	"wait_remove",
	"wait_fin_priv_attach",
	"wait_dial_release",
	"wait_dial_out",
	"wait_hangup",
	"wait_slave_request",
	"wait_greeting_msg",
	"wait_delete_channel",
	"wait_connect_request",
	"wait_tandd_hangup",
	"wait_fin_tandd_attach",
	"wait_discard_wakeups",
	"wait_before_hangup");

     end print_cdte;

string_edit: proc (s) returns (char (128) var);

dcl  s char (*) aligned;

	if s = low (length (s)) then return ("");
	else return (rtrim (s));

     end string_edit;




edit_time: proc (time) returns (char (32) var);

dcl  time fixed bin (71);
dcl  time_string char (24);

	if time = 0 then return ("never");
	call date_time_ (time, time_string);
	return (rtrim (time_string));

     end edit_time;




edit_desc: proc (n, desc) returns (char (32) var);

dcl  n fixed bin;
dcl  desc (*) char (*);

	if n < lbound (desc, 1) | n > hbound (desc, 1) then
	     if n = 0 then return ("");		/* probably just unmitialized */
	     else return ("?");
	else return (rtrim (desc (n)));

     end edit_desc;

flag_names: proc (flags, flag_name_array) returns (char (256) varying);

dcl  flags bit (*) unaligned;
dcl  flag_name_array (*) char (32) varying;
dcl  return_string char (256) varying;

dcl  j fixed bin;

	return_string = "";

	do j = 1 to hbound (flag_name_array, 1);	/* go thru the ones we know the names of */
	     if substr (flags, j, 1) then do;		/* if flag is on, add its name to the return string */
		return_string = return_string || flag_name_array (j);
		return_string = return_string || ",";	/* separate concatenations get better code */
	     end;
	end;
	do j = j to length (flags)			/* go thru the ones we don't know the names of */
	     while (substr (flags, j));		/* as long as there are any more nonzero ones */
	     if substr (flags, j, 1) then do;		/* if unknown flag is on */
		two_digits = j;			/* convert its position to a printable number */
		return_string = return_string || "flag";
		return_string = return_string || ltrim (two_digits);
		return_string = return_string || ",";
	     end;
	end;
	substr (return_string, length (return_string), 1) = ";";
	return (return_string);

     end flag_names;

dump_tree:
     procedure;					/* This does mode=0, whole cdt, treewise */

	tcount = 0;
	indent = 0;
	call ioa_$ioa_switch (switch, "FNP Entries:");
	indent = 2;

	do fnpx = 1 to hbound (cdt.fnp_entry, 1);
	     fnpep = addr (cdt.fnp_entry (fnpx));
	     if fnpe.state ^= FNP_FREE
	     then do;
		call ioa_$ioa_switch (switch, "^2xFNP ^a", substr (collate (), rank ("a") + fnpx, 1));
		if ^dump_cdt_args.brief then call print_fnpe (fnpx);
		if fnpe.threads.daughter_count = 0 & fnpe.threads.daughter = 0
		then ;
		else call show_children (addr (fnpe.threads), -fnpx, "1"b);
	     end;
	end;

/* Other tops */

	indent = 2;
	call ioa_$ioa_switch (switch, "^/Other top level channels:");
	call show_children (addr (cdt.threads), 0, "0"b);


	call ioa_$ioa_switch (switch);
	do cdtx = 1 to cdt.current_size;
	     if cdt.cdt_entry (cdtx).in_use ^= NOW_FREE & ^visited (cdtx)
	     then call ioa_$ioa_switch (switch, "Unthreaded channel: ^a at index ^d.", cdt.cdt_entry (cdtx).name, cdtx);
	end;

	if tcount ^= cdt.n_cdtes
	then call ioa_$ioa_switch (switch, "Total seen is ^d, but cdt.n_cdtes is ^d.", tcount, cdt.n_cdtes);

	return;

     end dump_tree;

show_children:
     procedure (tp, tx, fnp);
declare  cp pointer;
declare  tp pointer;
declare  tx fixed bin;
declare  fx fixed bin;
declare  ffnp_sw bit (1) aligned;
declare  fnp bit (1) aligned;
declare  x fixed bin;
declare  last_sister fixed bin;
declare  dcount fixed bin;				/* daughter count */
declare  1 t aligned like channel_threads based (tp);


	call ioa_$ioa_switch (switch, "^vx^d daughters.", indent, t.daughter_count);
	dcount = 0;
	if t.daughter_count = 0
	then do;
	     if t.daughter ^= 0
	     then do;
		call ioa_$ioa_switch (switch, "^vxdaughter count zero but there are daughters.", indent);
		goto CHASE;
	     end;
	     return;
	end;
CHASE:
	last_sister = 0;

	do x = t.daughter repeat (cdt.cdt_entry (x).threads.next_sister) while (x ^= 0);
	     cp = addr (cdt.cdt_entry (x));
	     call ioa_$ioa_switch (switch, "^vx(^d)^a", indent, x, cp -> cdte.name);
	     if ^dump_cdt_args.brief
	     then call print_cdte (cp);
	     dcount = dcount + 1;
	     tcount = tcount + 1;
	     visited (x) = "1"b;

	     if cp -> cdte.threads.mother ^= tx
	     then call ioa_$ioa_switch (switch, "^vxthreads.mother = ^d, but mother = ^d.", indent, cp -> cdte.mother, tx);
	     if cp -> cdte.threads.prev_sister ^= last_sister
	     then call ioa_$ioa_switch (switch, "^vxthreads.prev_sister = ^d, but prev_sister = ^d.", indent,
		     cp -> cdte.threads.prev_sister, last_sister);
	     last_sister = x;
	     if cp -> cdte.threads.daughter ^= 0
	     then do;
		indent = indent + 2;
		call show_children (addr (cp -> cdte.threads), x, "0"b);
		indent = indent - 2;
	     end;
	     on sub_error_
		begin;
		call find_condition_info_ (null, addr (CI), (0));
		sub_error_info_ptr = CI.info_ptr;
		call convert_status_code_ (sub_error_info.status_code, "", error);
		call ioa_$ioa_switch (switch, "^vxError: ^a ^a",
		     indent, error, sub_error_info.info_string);
		go to ERROR;
	     end;

	     call cdt_mgr_$find_cdt_channel (cdtp, (cp -> cdte.name), fx, ffnp_sw, code);
	     if code = 0
	     then do;
		if fx ^= x			/* wrong place */
		then call ioa_$ioa_switch (switch, "^vxcdt_mgr_ thinks this is cdtx = ^d.", indent, fx);
		if ffnp_sw
		then call ioa_$ioa_switch (switch, "^vxcdt_mgr_ thinks this is a FNP.", indent);
	     end;
ERROR:
	end;					/* the loop */
	if dcount ^= t.daughter_count
	then call ioa_$ioa_switch (switch, "^vxthreads.daughter_count = ^d, but daughter_count = ^d.", indent, t.daughter_count, dcount);

	return;
     end show_children;
     end dump_cdt_;




		    dump_cmf_.pl1                   10/25/89  1201.0r w 10/25/89  1005.0      108144



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

/* dump_cmf_, a subroutine to dump the CDT in the form of a CMF,
   such that cv_cmf could regenerate the CDT.

   Coded 5/11/76 by Mike Grady
   Modified November 1976 by T. Casey to generate Baud statements.
   Modified June 1977 by Robert Coren to use new terminal type field and new attributes.
   Modified April 1979 by Larry Johnson for new fnpe stuff.
   Modified 1979 May 25 by Art Beattie to accomodate change in cdt.incl.pl1.
   Modified 1/82 BIM for cdt threads.
   Modified January 1983 by Keith Loepere for generic_destination.
   Modified 84-03-22 BIM for removal of obsolete fields, full AIM.
*/

/* format: style2 */

dump_cmf_:
     proc (acdtp, switch);

	dcl     (acdtp, switch)	 ptr parameter;

	dcl     com_err_		 entry () options (variable),
	        date_time_		 entry (fixed bin (71), char (*)),
	        ioa_$ioa_switch	 entry options (variable),
	        ioa_$rsnnl		 entry options (variable),
	        system_info_$device_prices
				 entry (fixed bin, ptr),
	        system_info_$access_ceiling
				 entry (bit (72) aligned),
	        aim_check_$equal	 entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned),
	        convert_authorization_$from_string
				 entry (bit (72) aligned, character (*), fixed binary (35)),
	        convert_authorization_$to_string_range_short
				 entry ((2) bit (72) aligned, character (*), fixed binary (35));

	dcl     cdt_et_$salvage_cdt	 fixed bin (35) ext static;

	dcl     line		 char (160),
	        vline		 char (160) varying;

	dcl     (i, j, len, ndev)	 fixed bin,
	        code		 fixed bin (35);
	dcl     (dft_baud, next_baud, this_baud)
				 fixed bin;

	dcl     system_high		 bit (72) aligned,
	        system_low		 bit (72) aligned,
	        auth_bits		 bit (72) aligned;

	dcl     auth_done		 bit (1);

	dcl     lidx		 fixed bin,
	        count		 fixed bin;

	dcl     1 ac_table		 (10) aligned,
		2 auth_bits	 bit (72) aligned,
		2 count		 fixed bin;

	dcl     date_string		 char (24),
	        auth		 char (100);

	dcl     1 dvt		 (16) aligned,
		2 devid		 char (8),
		2 dev_prices	 (0:7) float;

	dcl     bb72		 bit (72) aligned based;

	dcl     service_types	 (8) char (12) static options (constant)
				 init ("login", "ftp", "mc", "slave", "", "autocall", "inactive", "multiplexer");
%page;
%include cdt;
%page;
%include author_dcl;
%page;
%include ttyp;
%page;
%include dataset_names;
%page;
%include line_types;
%page;
%include dialup_values;
%page;
%include multiplexer_types;


	cdtp = acdtp;
	line = "/* Automatically generated Channel Master File";
	call append_line;
	call date_time_ (clock (), date_string);
	line = "   Generated by display_cdt on " || date_string || " */";
	call append_line;
	line = "";
	call append_line;

	call system_info_$device_prices (ndev, addr (dvt));

	line = "Service:	login;";
	call append_line;
	line = "Charge:	none;";
	call append_line;
	line = "Terminal_type: none;";
	call append_line;
	line = "Line_type: none;";
	call append_line;
	line = "Attributes: none;";
	call append_line;
	line = "Check_acs: none;";
	call append_line;
	line = "Baud: 300;";
	call append_line;
	dft_baud = 300;

/* try and compute the correct access class */

	call system_info_$access_ceiling (system_high);	/* get sys high */
	call convert_authorization_$from_string (system_low, "system_low", code);
	line = "Access_class: ""system_low"";";		/* secure default is no access. Individuals will all be stated. Verbose, but effective. */
	call append_line;

	call ioa_$rsnnl ("FNP_required_up_time: ^d;", line, len, cdt.acceptable_fnp_tbf);
	call append_line;
	call ioa_$rsnnl ("Spare_channel_count: ^d;", line, len, cdt.spare_channel_count);
	call append_line;

	line = "";
	call append_line;

	do i = 1 to 8;				/* dump FNPs */
	     fnpep = addr (cdt.fnp_entry (i));
	     if fnpe.state ^= FNP_FREE
	     then call dump_fnpe;			/* recurses */
	end;

	line = "/* Other top level multiplexers: */";
	call append_line;
	line = "";
	call append_line;
	call dump_subtree (addr (cdt.threads), "Top level chain");

	line = "end;";
	call append_line;

	return;

dump_fnpe:
     proc;

	dcl     mpx_type		 fixed bin;

	mpx_type = fnpe.mpx_type;
	if mpx_type = 0
	then mpx_type = MCS_MPX;

	line = "FNP:	" || substr (collate (), rank ("A") + i, 1) || ";";
	call append_line;
	if fnpe.type ^= 0 | mpx_type = MCS_MPX
	then do;
		call ioa_$rsnnl ("   type:	^a;", line, len, fnp_types (fnpe.type));
		call append_line;
	     end;
	if fnpe.memory ^= 0 | mpx_type = MCS_MPX
	then do;
		call ioa_$rsnnl ("   memory: ^d;", line, len, fnpe.memory);
		call append_line;
	     end;
	if fnpe.nlslas ^= 0 | (fnpe.mpx_type = MCS_MPX & fnpe.type ^= DN6670)
	then do;
		call ioa_$rsnnl ("   lsla:	^d;", line, len, fnpe.nlslas);
		call append_line;
	     end;
	if fnpe.nhslas ^= 0 | mpx_type = MCS_MPX
	then do;
		call ioa_$rsnnl ("   hsla:	^d;", line, len, fnpe.nhslas);
		call append_line;
	     end;
	if mpx_type = MCS_MPX
	then do;
		call ioa_$rsnnl ("   image:	^a;", line, len, fnpe.coreimage);
		call append_line;
	     end;
	else if fnpe.coreimage ^= ""
	then do;
		call ioa_$rsnnl ("   additional_info: ""^a"";", line, len, fnpe.coreimage);
		call append_line;
	     end;
	if fnpe.service_type = INACTIVE
	then do;
		line = "   service: inactive;";
		call append_line;
	     end;
	if fnpe.mpx_type ^= 0
	then do;
		call ioa_$rsnnl ("   multiplexer_type: ^a;", line, len, mpx_types (fnpe.mpx_type));
		call append_line;
	     end;
	line = "";
	call append_line;
	if fnpe.daughter ^= 0
	then call dump_subtree (addr (fnpe.threads), "FNP " || substr (collate (), rank ("A") + i, 1));
	return;

     end dump_fnpe;


dump_subtree:
     procedure (tp, cname);

	declare tp		 pointer;
	declare 1 threads		 aligned like channel_threads based (tp);
	declare cname		 character (32) aligned;
	declare x			 fixed bin;
	declare ccount		 fixed bin;

	if threads.daughter_count = 0 | threads.daughter = 0
	then return;				/* for lazy callers */

	ccount = 0;
	do x = threads.daughter repeat (cdt.cdt_entry (x).next_sister) while (x ^= 0);
	     ccount = ccount + 1;
	     if ccount > threads.daughter_count | ccount > cdt.n_cdtes
	     then do;
		     call com_err_ (cdt_et_$salvage_cdt, "dump_cmf_", "Too many daughters(^d) for ^a", ccount, cname);
		     go to RETURN;
		end;
	     call dump_cdte (addr (cdt.cdt_entry (x)));
	     if cdt.cdt_entry (x).daughter ^= 0
	     then call dump_subtree (addr (cdt.cdt_entry (x).threads), cdt.cdt_entry (x).name);
	end;
     end dump_subtree;

dump_cdte:
     proc (CDTEp);
	declare CDTEp		 pointer;
	declare 1 CDTE		 aligned like cdte based (CDTEp);

	this_baud = CDTE.baud_rate;
	if CDTE.flags.autobaud
	then this_baud = -1;

	if this_baud ^= dft_baud
	then do;
		next_baud = addr (cdt.cdt_entry (i + 1)) -> CDTE.baud_rate;
		if addr (cdt.cdt_entry (i + 1)) -> CDTE.flags.autobaud
		then next_baud = -1;
		if next_baud = this_baud
		then do;
			dft_baud = this_baud;
			if dft_baud = -1
			then line = "Baud: auto;";
			else if dft_baud = 0
			then line = "Baud: none;";
			else call ioa_$rsnnl ("Baud: ^d;", line, len, dft_baud);
			call append_line;
		     end;
	     end;

	call ioa_$rsnnl ("name: ^a;", line, len, CDTE.name);
	call append_line;
	if this_baud ^= dft_baud
	then do;
		if this_baud = -1
		then line = "   baud: auto;";
		else if this_baud = 0
		then line = "   baud: none;";
		else call ioa_$rsnnl ("^3xbaud: ^d;", line, len, CDTE.baud_rate);
		call append_line;
	     end;
	if CDTE.service_type ^= ANS_SERVICE
	then do;
		call ioa_$rsnnl ("^3xservice: ^a;", line, len, service_types (CDTE.service_type));
		call append_line;
	     end;
	if CDTE.service_type = MPX_SERVICE
	then do;
		call ioa_$rsnnl ("^3xmultiplexer_type: ^a", line, len, mpx_types (CDTE.mpx_type));
		if CDTE.mpx_service = INACTIVE
		then call addto_line (", inactive");
		call addto_line (";");
		call append_line;
	     end;
	if CDTE.charge_type > 0
	then do;
		call ioa_$rsnnl ("^3xcharge: ^a;", line, len, dvt (CDTE.charge_type).devid);
		call append_line;
	     end;
	if CDTE.initial_terminal_type ^= ""
	then do;
		call ioa_$rsnnl ("^3xterminal_type: ^a;", line, len, CDTE.initial_terminal_type);
		call append_line;
	     end;
	if CDTE.line_type > 0 | CDTE.line_type = -1
	then do;
		call ioa_$rsnnl ("^3xline_type: ^a", line, len, line_types (CDTE.line_type));
		if CDTE.line_type = LINE_BSC
		then do;
			if CDTE.flags.bsc_ebcdic
			then call addto_line (", ebcdic");
			else call addto_line (", ascii");
			if CDTE.flags.bsc_transparent
			then call addto_line (", transparent");
			else call addto_line (", nontransparent");
		     end;
		call addto_line (";");
		call append_line;
	     end;
	if CDTE.modem_type > 0
	then do;
		call ioa_$rsnnl ("^3xdataset: ^a", line, len, dataset_names (CDTE.modem_type));
		if CDTE.flags.private_line
		then call addto_line (", private_line;");
		else call addto_line (";");
		call append_line;
	     end;
	if ^(aim_check_$equal (system_low, CDTE.access_class (1))
	     & aim_check_$equal (system_low, CDTE.access_class (2)))
	then do;
		call convert_authorization_$to_string_range_short (CDTE.access_class, auth, code);
		call ioa_$rsnnl ("^3xaccess_class: ""^a"";", line, len, auth);
		call append_line;
	     end;
	if CDTE.flags.ck_answerback & (addr (CDTE.answerback) -> bb72 ^= "0"b & CDTE.answerback ^= "")
	then do;
		call ioa_$rsnnl ("^3xanswerback: ""^a"";", line, len, CDTE.answerback);
		call append_line;
	     end;
	if string (CDTE.flags.attributes)
	then do;
		vline = "   attributes: ";
		if CDTE.flags.audit_access_error
		then vline = vline || "audit,";
		if CDTE.flags.hardwired
		then vline = vline || "hardwired,";
		if CDTE.flags.set_modes
		then vline = vline || "set_modes,";
		if CDTE.flags.ck_answerback
		then vline = vline || "check_answerback,";
		if CDTE.flags.dont_read_answerback
		then vline = vline || "dont_read_answerback,";
		substr (vline, length (vline), 1) = ";";
		line = vline;
		call append_line;
	     end;
	if string (CDTE.flags.access_control)
	then do;
		vline = "   check_acs: ";
		if CDTE.flags.dial_out
		then vline = vline || "dial_out,";
		if CDTE.flags.priv_attach
		then vline = vline || "priv_attach,";
		if CDTE.flags.dial_server
		then vline = vline || "dial_server,";
		if CDTE.flags.slave_dial
		then vline = vline || "slave_dial,";
		if CDTE.flags.login
		then vline = vline || "login,";
		substr (vline, length (vline), 1) = ";";
		line = vline;
		call append_line;
	     end;
	if CDTE.flags.execute_initial_command
	     & (addr (CDTE.initial_command) -> bb72 ^= "0"b & CDTE.initial_command ^= "")
	then do;
		call ioa_$rsnnl ("^3xinitial_command: ""^a"";", line, len, CDTE.initial_command);
		call append_line;
	     end;
	if CDTE.flags.generic_destination_present
	     & (addr (CDTE.initial_command) -> bb72 ^= "0"b & addr (CDTE.initial_command) -> generic_destination ^= "")
	then do;
		call ioa_$rsnnl ("^3xgeneric_destination: ""^a"";", line, len,
		     addr (CDTE.initial_command) -> generic_destination);
		call append_line;
	     end;
	if CDTE.comment ^= ""
	then do;					/* put comment last in case user wants to edit CMF to have entire */
		call ioa_$rsnnl ("^3xcomment: ""^a"";", line, len, CDTE.comment);
						/* channel entry on one line */
		call append_line;
	     end;

	line = "";
	call append_line;
	return;

     end;

append_line:
     proc;

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

     end;




addto_line:
     proc (thing);

	dcl     thing		 char (*);

	line = substr (line, 1, len) || thing;
	len = len + length (thing);
	return;

     end;




RETURN:
	return;

     end dump_cmf_;




		    ed_installation_parms.pl1       10/07/88  1218.8rew 10/07/88  1214.7     1151910



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

/****^  HISTORY COMMENTS:
  1) change(87-03-30,Parisek), approve(87-05-01,MCR7690),
     audit(87-07-15,Beattie), install(87-08-04,MR12.1-1055):
     Add parameter 64 - vchn_requires_accept.
  2) change(87-08-17,Hartogs), approve(88-08-15,MCR7969),
     audit(87-08-24,GDixon), install(88-08-29,MR12.2-1093):
     Error handling for -dr fixed for rate_structure_0. (phx14904)
  3) change(88-09-19,GDixon), approve(88-09-20,MCR8012),
     audit(88-10-06,Farley), install(88-10-07,MR12.2-1142):
     Fix error in initiating the installation_parms (rate_structure_0) segment
     introduced by an earlier change (error_table_$segknown is being reported
     as an error, rather than being ignored).
                                                   END HISTORY COMMENTS */

/* format: style4 */
ed_installation_parms:
     procedure;

/* ED_INSTALLATION_PARMS - program to edit the "installation_parms" segment
   which gives the prices for all system resources, and various other
   system_wide accounting-type constants.

   Modified 740805 by PG for level & category names.
   Modified 741120 by LJS for syserr log copying threshold.
   Modified Aug 1977 by T. Casey for disk and tape device price setting
   Modified May 1978 by T. Casey to add parameters 21, ..., 32: resource prices, rcp_init_flags, and
   .		various times and counters used in answering service operation.
   Modified August 1978 by M. R. Jordan to fix bug in set_rcp_init_flag.
   Modified November 1978 by T. Casey to add parameters 33,...47 for MR7.0 absentee changes.
   Modified March 1979 by C. D. Tavares to change rcp_init_flags and handling
   Modified July 1979 by J. N. R. Barnecut for MR8.0 to support multiple rate structures. (UNCA)
   Modified May 1980 by J. N. R. Barnecut to ensure devices and resources are kept in same positions. (UNCA)
   Modified 22 September 1980 by G. Palter to add parameter 48 -- abs_default_queue
   Modified 6 April 1981 by E. N. Kittlitz to add parameters 49,50 -- cwe_count, cwe_time
   Modified 3 June 1981 by E. N. Kittlitz for UNCA rate structures, re-organization.
   .    Added parameters 51-55: rates, devices, resources, rate_structure_name, all_structures.
   .    mr9_default establishes version, converts abs cpu limits from fixed bin (17) to fixed bin (35).
   .    Program extensively re-structured, although many sub-tasks stayed the same.
   Modified 22 February 1982 by E. N. Kittlitz for bug fixes.
   Modified May 1982 by E. N. Kittlitz for retype prices change.
   Modified 1984-06-19 BIM for strict_trusted_path, remove ARPA
   Modified 1984-12, BIM: pdir quota values, operator login values.
   Modified 1985-01-09, BIM: message coordinator access control.
   Modified 1985-03-01 by E. Swenson for password flags.
*/

/* automatic */

dcl  all_sw bit (1) aligned;
dcl  all_abs_queue_sw bit (1) aligned;
dcl  all_rates_sw bit (1) aligned;
dcl  all_structures_sw bit (1) aligned;
dcl  argp ptr;
dcl  arg char (argl) based (argp);
dcl  argl fixed bin (21);
dcl  argno fixed bin;
dcl  change_request bit (1) aligned;
dcl  char32 char (32);
dcl  char48 char (48);
dcl  char8 char (8);
dcl  comm char (32);
dcl  copy_ip (ipl) fixed bin based;
dcl  critical_op bit (1) aligned;
dcl  cur_rs_ptr ptr;
dcl  did_something bit (1) aligned;
dcl  dn char (168);
dcl  dnvar char (168) varying;
dcl  ec fixed bin (35);
dcl  edit_rs bit (1) aligned;
dcl  en char (32);
dcl  i fixed bin;
dcl  ip ptr defined (rs_ptrs (0));			/* working copy of installation_parms */
dcl  ip1 ptr defined (rs_ptrs1 (0));
dcl  ipl fixed bin;
dcl  j fixed bin;
dcl  k fixed bin;
dcl  keywx fixed bin;
dcl  nargs fixed bin;
dcl  path char (168) init ("");
dcl  print_comm char (32);
dcl  rs_ptrs (0:9) ptr;				/* rate structure pointers */
dcl  rs_ptrs1 (0:9) ptr;
dcl  rsp ptr;
dcl  rsp1 ptr;
dcl  selected_rs_ptr ptr;
dcl  suppress_nl bit (1) aligned;

dcl  (cleanup, program_interrupt) condition;

/* internal static constants */

dcl  NOLIMIT fixed bin (35) int static options (constant) init (-999999);
dcl  MILLION fixed bin (35) int static init (1000000);
dcl  SECONDS_PER_MONTH float bin (27) init (30 * 24 * 3600) int static options (constant);
dcl  ADD fixed bin init (1) static options (constant);
dcl  CHANGE fixed bin init (2) static options (constant);
dcl  PRINT fixed bin init (3) static options (constant);
dcl  RETYPE fixed bin init (4) static options (constant);
dcl  NO_SPECIAL_DEVICES bit (1) aligned init ("0"b) static options (constant);
dcl  SPECIAL_DEVICES_OK bit (1) aligned init ("1"b) static options (constant);
dcl  NOT_RS_ID fixed bin init (-2) static options (constant);
dcl  ID_NOT_FOUND fixed bin init (-1) static options (constant);
dcl  ALL_RS bit (1) aligned init ("1"b) static options (constant);
dcl  THIS_RS bit (1) aligned init ("0"b) static options (constant);
dcl  SET_HI bit (1) aligned init ("1"b) static options (constant);
dcl  NO_SET_HI bit (1) aligned init ("0"b) static options (constant);
dcl  COMPLAIN bit (1) aligned init ("1"b) static options (constant);

dcl  daynam char (21) int static options (constant) init ("MonTueWedThuFriSatSun");
dcl  me char (24) int static options (constant) init ("ed_installation_parms");
dcl  ip_rings (3) fixed bin (3) init (4, 5, 5) int static options (constant);

/* internal static */

dcl  told_user bit (1) aligned internal static init ("0"b);

/* based structures */

dcl  based_integer fixed bin based;

/* builtins */

declare  (addr, before, bit, char, currentsize, dim, dimension, divide, fixed, hbound, index, lbound, length, ltrim, bin,
         null, ptr, rel, reverse, rtrim, string, substr, verify, unspec) builtin;

/*  external variables */

dcl  error_table_$badopt fixed bin (35) ext static;
dcl  error_table_$inconsistent ext fixed bin (35);
dcl  error_table_$incorrect_access fixed bin (35) ext static;
dcl  error_table_$segknown fixed bin (35) ext static;
dcl  error_table_$segnamedup fixed bin (35) ext static;

/* entries */

dcl  absolute_pathname_ entry (char (*), char (*), fixed bin (35));
dcl  ask_ entry options (variable);
dcl  ask_$ask_clr entry ();
dcl  ask_$ask_flo entry options (variable);
dcl  ask_$ask_int entry options (variable);
dcl  ask_$ask_line entry options (variable);
dcl  ask_$ask_n entry options (variable);
dcl  ask_$ask_yn entry options (variable);
dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cv_$mwvf entry (float bin) returns (char (15));
dcl  cv_dec_ entry (char (*)) returns (fixed bin (35));
dcl  cv_float_ entry (char (*), fixed bin (35), float bin (27));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));

dcl  hcs_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$delentry_seg entry (ptr, fixed bin (35));
dcl  hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));
dcl  hcs_$set_ring_brackets entry (char (*), char (*), (3) fixed bin (3), fixed bin (35));
dcl  hcs_$set_safety_sw_seg entry (ptr, bit (1), fixed bin (35));
dcl  hcs_$truncate_seg entry (ptr, fixed bin (19), fixed bin (35));
dcl  initiate_file_ entry (character (*), character (*), bit (*), pointer, fixed binary (24),
	fixed binary (35));
dcl  ioa_ entry options (variable);
dcl  nd_handler_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35));
%page;
/* The following two static arrays, keyw and keyn, map the keywords and their
   (zero or more) abbreviations into key numbers that map into the label arrays.
   These two arrays must be kept in sync if keywords or abbreviations are added,
   and the values in the keyn array must always be in increasing order.
   Notice that each array is the other one with its value and comment columns interchanged.
   Another array valid_rs_id must also be updated when adding an identifier
   which may be used when editing a rate structure.
   There are also arrays sequence_ALL and sequence_RATES which may require updating
   when adding a new identifier.
*/

dcl  keyw (119) char (32) int static options (constant) init ("all",
						/* 1 */
	"installation_id",				/* 2 */
	"inst",					/* 2 */
	"shift_table",				/* 3 */
	"shif",					/* 3 */
	"prices",					/* 4 */
	"titles",					/* 5 */
	"level_names",				/* 6 */
	"leve",					/* 6 */
	"inactive_time",				/* 7 */
	"inac",					/* 7 */
	"warning_time",				/* 8 */
	"warn",					/* 8 */
	"login_time",				/* 9 */
	"logi",					/* 9 */
	"tries",					/* 10 */
	"update_time",				/* 11 */
	"upda",					/* 11 */
	"device_prices",				/* 12 */
	"devprice",				/* 12 */
	"devp",					/* 12 */
	"config_table",				/* 13 */
	"conf",					/* 13 */
	"queue_prices",				/* 14 */
	"abs_queue_parameters",			/* 15 */
	"abs_",					/* 15 */
	"category_names",				/* 16 */
	"cate",					/* 16 */
	"access_ceiling",				/* 17 */
	"acce",					/* 17 */
	"log_parameters",				/* 18 */
	"log_",					/* 18 */
	"trusted_path_login",			/* 19 */
	"device_names",				/* 20 */
	"devname",				/* 20 */
	"devn",					/* 20 */
	"resource_prices",				/* 21 */
	"rscprice",				/* 21 */
	"rscp",					/* 21 */
	"resource_names",				/* 22 */
	"rscname",				/* 22 */
	"rscn",					/* 22 */
	"resource_wait_time",			/* 23 */
	"rsctime",				/* 23 */
	"rsct",					/* 23 */
	"fpe_time",				/* 24 */
	"fpetime",				/* 24 */
	"fpet",					/* 24 */
	"fpe_count",				/* 25 */
	"fpecount",				/* 25 */
	"fpec",					/* 25 */
	"trm_real_time",				/* 26 */
	"trmrealtime",				/* 26 */
	"trmr",					/* 26 */
	"trm_cpu_time",				/* 27 */
	"trmcputime",				/* 27 */
	"trmc",					/* 27 */
	"unload_on_detach",				/* 28 */
	"unlo",					/* 28 */
	"authentication_level",			/* 29 */
	"auth",					/* 29 */
	"default_pdir_seg_quota",			/* 30 */
	"df_pdsq",				/* 30 */
	"rsc_mgmt_enabled",				/* 31 */
	"rsc_",					/* 31 */
	"auto_registration",			/* 32 */
	"auto",					/* 32 */
	"enable_ss_volume_mount",			/* 33 */
	"foreground_queue_position",			/* 34 */
	"fore",					/* 34 */
	"idle_time_constant",			/* 35 */
	"idle",					/* 35 */
	"sus_cpu_time",				/* 36 */
	"susc",					/* 36 */
	"sus_real_time",				/* 37 */
	"susr",					/* 37 */
	"max_abs",				/* 38 */
	"min_abs",				/* 39 */
	"pct_abs",				/* 40 */
	"max_qres",				/* 41 */
	"min_qres",				/* 42 */
	"pct_qres",				/* 43 */
	"abs_cpu_max_limit",			/* 44 */
	"abscpumx",				/* 44 */
	"abs_timax",				/* 45 */
	"abs_cpu_default_limit",			/* 46 */
	"abscpudf",				/* 46 */
	"foreground_cpu_default_limit",		/* 47 */
	"fgcpudf",				/* 47 */
	"abs_default_queue",			/* 48 */
	"absdfq",					/* 48 */
	"cwe_time",				/* 49 */
	"cwet",					/* 49 */
	"cwe_count",				/* 50 */
	"cwec",					/* 50 */
	"rates",					/* 51 */
	"devices",				/* 52 */
	"device",					/* 52 */
	"resources",				/* 53 */
	"resource",				/* 53 */
	"rate_structure_names",			/* 54 */
	"rate_structure_name",			/* 54 */
	"rsn",					/* 54 */
	"all_structures",				/* 55 */
	"default_pdir_dir_quota",			/* 56 */
	"df_pddq",				/* 56 */
	"require_operator_login",			/* 57 */
	"operator_inactive_time",			/* 58 */
	"op_inac",				/* 58 */
	"validate_daemon_commands",			/* 59 */
	"password_min_length",			/* 60 */
	"pwml",					/* 60 */
	"password_gpw_length",			/* 61 */
	"pwgl",					/* 61 */
	"password_change_interval",			/* 62 */
	"pwci",					/* 62 */
	"password_expiration_interval",		/* 63 */
	"pwei",					/* 63 */
	"vchn_requires_accept"			/* 64 */
	);

%page;

dcl  keyn (119) fixed bin int static options (constant) init (1,
						/* all */
	2,					/* installation_id */
	2,					/* inst */
	3,					/* shift_table */
	3,					/* shif */
	4,					/* prices */
	5,					/* titles */
	6,					/* level_names */
	6,					/* leve */
	7,					/* inactive_time */
	7,					/* inac */
	8,					/* warning_time */
	8,					/* warn */
	9,					/* login_time */
	9,					/* logi */
	10,					/* tries */
	11,					/* update_time */
	11,					/* upda */
	12,					/* device_prices */
	12,					/* devprice */
	12,					/* devp */
	13,					/* config_table */
	13,					/* conf */
	14,					/* queue_prices */
	15,					/* abs_queue_parameters */
	15,					/* abs_ */
	16,					/* category_names */
	16,					/* cate */
	17,					/* access_ceiling */
	17,					/* acce */
	18,					/* log_parameters */
	18,					/* log_ */
	19,					/* trusted_path_login */
	20,					/* device_names */
	20,					/* devname */
	20,					/* devn */
	21,					/* resource_prices */
	21,					/* rscprice */
	21,					/* rscp */
	22,					/* resource_names */
	22,					/* rscname */
	22,					/* rscn */
	23,					/* resource_wait_time */
	23,					/* rsctime */
	23,					/* rsct */
	24,					/* fpe_time */
	24,					/* fpetime */
	24,					/* fpet */
	25,					/* fpe_count */
	25,					/* fpecount */
	25,					/* fpec */
	26,					/* trm_real_time */
	26,					/* trmrealtime */
	26,					/* trmr */
	27,					/* trm_cpu_time */
	27,					/* trmcputime */
	27,					/* trmc */
	28,					/* unload_on_detach */
	28,					/* unlo */
	29,					/* authentication_level */
	29,					/* auth */
	30,					/* default_pdir_quota */
	30,					/* df_pdsq */
	31,					/* rsc_mgmt_enabled */
	31,					/* rsc_ */
	32,					/* auto_registration */
	32,					/* auto */
	33,					/* enable_ss_volume_mount */
	34,					/* foreground_queue_position */
	34,					/* fore */
	35,					/* idle_time_constant */
	35,					/* idle */
	36,					/* sus_cpu_time */
	36,					/* susc */
	37,					/* sus_real_time */
	37,					/* susr */
	38,					/* max_abs */
	39,					/* min_abs */
	40,					/* pct_abs */
	41,					/* max_qres */
	42,					/* min_qres */
	43,					/* pct_qres */
	44,					/* abs_cpu_max_limit */
	44,					/* abscpumx */
	45,					/* abs_timax */
	46,					/* abs_cpu_default_limit */
	46,					/* abscpudf */
	47,					/* foreground_cpu_default_limit */
	47,					/* fgcpudf */
	48,					/* abs_default_queue */
	48,					/* absdfq */
	49,					/* cwe_time */
	49,					/* cwet */
	50,					/* cwe_count */
	50,					/* cwec */
	51,					/* rates */
	52,					/* devices */
	52,					/* device */
	53,					/* resources */
	53,					/* resource */
	54,					/* rate_structure_names */
	54,					/* rate_structure_name */
	54,					/* rsn */
	55,					/* all_structures */
	56,					/* default_pdir_dir_quota */
	56,					/* df_pddq */
	57,					/* require_operator_login */
	58,					/* operator_inactive_time */
	58,					/* op_inac */
	59,					/* validate_daemon_commands */
	60,					/* password_min_length */
	60,					/* pwml */
	61,					/* password_gpw_length */
	61,					/* psgl */
	62,					/* password_change_interval */
	62,					/* pwci */
	63,					/* password_expiration_interval */
	63,					/* pwei */
	64					/* vchn_requires_accept */
	);
%page;

/* valid_for_rs contains the indices of all change identifiers which may be
   used while editing a rate_structure. They must be in ascending order.
   A flag of 999 must be the last element. */

dcl  valid_for_rs (13) fixed bin static options (constant) init (1, 4, 12, 14, 20, 21, 22, 51, 52, 53, 54, 55, 999);

/* sequence_ALL defines the order in which individual requests will be made
   if the 'all' request is issued. */

dcl  sequence_ALL (54) fixed bin static options (constant)
	init (1, 2, 5, 7, 8, 9, 10, 49, 50, 11, 4, 14, 52, 53, 3, 6,
	16, 17, 18, 19, 57, 64, 58, 59, 60, 61, 62, 63,
	13, 23, 30, 56, 24, 25, 26, 27, 37, 36, 28,
	29, 31, 32, 33, 35, 34, 47, 48, 15, 38, 39, 40, 41, 42, 43);

/* sequence_RATES controls the order in which operations are performed when the
   identifier 'rates' (or 'all' when editing a rate_structure) is used.
   It contains only indices of rate_structure identifiers, in the same order
   as sequence_ALL. */

dcl  sequence_RATES (5) fixed bin static options (constant) init (51, 4, 14, 12, 21);

/*  sequence_ABS_Q controls the abs_queue_parameters identifier */

dcl  sequence_ABS_Q (4) fixed bin static options (constant) init (15, 44, 45, 46);
%page;
/*
   DIVERS POINTS

   This program supports the editing of installation_parms and up to
   nine additional rate_structures.  The accounting system is designed to
   charge for resources based upon pricing information contained
   in the rate_structure to which a user or project is assigned.
   The default pricing is contained in installation_parms, and is considered
   to be rate_structure 0.  If a site defines other rate_structures,
   they are numbered 1 through 9.

   The rate_structure definition is the same as installation_parms.
   However, certain fields are designated as invalid in a rate_structure.
   Additional rate_structures exist in segments names rate_structure_N.
   When accounting, a routine accesses all pricing information by using the
   rate_structure segment appropriate to the user/project being charged.

   Rate_structure names appear in installation_parms.rate_structures.
   There are installation_parms.nrates structures (<= 9), where
   structure 0 is "default" (i.e. installation_parms).

   This program is designed to allow the user to alter the fields of
   one rate_structure at a time.  The user indicates which rate_structure
   is under consideration via the "rate_structure" command.  In general,
   all subsequent editing requests act upon the last-specified rate_structure.

   Terminology: installation_parms is rate_structure 0. Its name is initially
   "default".  Within this program, the notion of editing a rate_structure is
   typically defined as editing a rate_structure other than installation_parms.
   There are a number of operations on rate_structure field which can
   only be performed while editing the default rate_structure (i.e.
   installation_parms).  In general, any operation which affects more than
   one rate_structure (such as renaming or retyping device information)
   can only be performed while editing installation_parms.

   WITHIN this program: the requests of principal interest are: add, change,
   print and retype.  These requests are dispatched to the procedure do_any.
   The do_any procedure does first-level checks to determine if a valid
   field identifier has been specified.  It also determines whether or
   not the field is "defined" in non-default rate_structures.
   An identifier is valid for a rate_structure only if its index appears in
   the array valid_for_rs.  (This technique is used to avoid having to add
   a control for every new identifier (most of which will be non-rate_structure).

   The do_any procedure calls the appropriate processor for the request given.
   If there is any conflict, an individual processor is responsible for
   detecting an invalid use of a non-rate_structure field.
   There are several field identifiers which correspond to a group of
   field identifiers.  Examples are "all", "abs_queue_parameters" and "rates".
   In these cases, do_any will make a number of calls to the designated
   processor.  The identifier "all_structures" causes do_any to loop
   over all rate_structures (including installation_parms).

   THERE are a number of internal procedures with entries.  Said entries
   have names of the form int_proc$$entry_name.
*/
%page;

/* INITIALIZATION */

	call ask_$ask_clr ();			/* make sure nothing in ask_ buffer */
	ip = null;				/* initialize pointers */
	ip1 = null;
	rs_ptrs (*), rs_ptrs1 (*) = null;
	edit_rs = "0"b;				/* and switches */
	selected_rs_ptr, cur_rs_ptr = null;
	critical_op = "0"b;

	on cleanup call clean_up;

	dn = "";

	call cu_$arg_count (nargs);			/* look for control arguments */
	if nargs > 0 then
	     do argno = 1 to nargs;
	     call cu_$arg_ptr (argno, argp, argl, ec);	/* next, please */
	     if ec ^= 0 then do;
		call com_err_ (ec, me);		/* horrors! */
		go to exit;
	     end;
	     else if arg = "-directory" | arg = "-dr" then do;
						/* containing directory? */
		if path ^= "" then			/* already have a path? */
		     go to er2;			/* inconsitent... */
		else do;
		     argno = argno + 1;		/* go for directory name */
		     call cu_$arg_ptr (argno, argp, argl, ec);
		     if ec ^= 0 then do;		/* user's fingers wore out */
			call com_err_ (ec, me);	/* display our distress */
			go to exit;		/* clean up */
		     end;
		     else do;			/* where to go */
			call absolute_pathname_ (arg, dn, ec);
			if ec ^= 0 then do;
			     call com_err_ (ec, me, "^a", arg);
			     go to exit;
			end;
			en = "installation_parms";
		     end;
		end;
	     end;
	     else if substr (arg, 1, 1) = "-" then do;	/* look like a control arg? */
		call com_err_ (error_table_$badopt, me, "^a", arg);
						/* well, it isn't */
		go to exit;
	     end;
	     else if dn ^= "" then do;		/* pathname? */
er2:
		call com_err_ (error_table_$inconsistent, me,
		     "pathname and -directory arguments may not both be specified.");
		go to exit;
	     end;
	     else do;				/* pathname, and it makes sense */
		path = arg;
		call expand_pathname_ (path, dn, en, ec);
		if ec ^= 0 then do;
		     call com_err_ (ec, me, "^a", path);
		     go to exit;
		end;
	     end;
	end;

	else do;					/* default path */
	     path = "installation_parms";
	     call expand_pathname_ (path, dn, en, ec);
	     if ec ^= 0 then do;
		call com_err_ (ec, me, "^a", path);
		go to exit;
	     end;
	end;

	if dn = ">" then
	     dnvar = ">";
	else dnvar = rtrim (dn) || ">";


/* Find all rate structures.
   NOTE: When i is set to 0 (the first trip), we get the value of
   rs_ptrs (0), i.e. also the value of the pointer "ip".  Then,
   we have an installation_parms structure 'defined', and can
   loop from 1 - installation_parms.nrates. */

	do i = 0, 1 repeat i + 1 while (i <= installation_parms.nrates);
	     if i = 0 then do;
		en = "installation_parms";		/* make or initiate installation_parms */
		call hcs_$make_seg (dn, en, "", RW_ACCESS_BIN, rsp1, ec);
		if ec = 0 then do;			/* segment was just created */
		     rsp1 -> installation_parms.version = installation_parms_version_2;
create_addname:					/* add the name rate_structure_0 to installation_parms */
		     call hcs_$chname_file (dn, "installation_parms", "", "rate_structure_0", ec);
		     if ec ^= 0 & ec ^= error_table_$segnamedup & ec ^= error_table_$incorrect_access then do;
						/* not on installation_parms? */
			call nd_handler_ (me, dn, "rate_structure_0", ec);
						/* try to get the name freed */
			if ec = 0 then go to create_addname;
						/* try again */
		     end;
		     call hcs_$set_ring_brackets (dn, en, ip_rings, ec);
						/* so try to set rings */
		     if ec ^= 0 then call com_err_ (ec, me, "Setting ring brackets of ^a.", en);
		end;				/* set the version, so we don't 'convert' later */
		else if ec ^= error_table_$segknown then do;
		     call com_err_ (ec, me, "rate_structure_^d ^a.", i, dnvar || rtrim (en));
		     go to exit;
		end;
	     end;
	     else do;				/* if installation_parms says there an RS */
		en = "rate_structure_" || ltrim (char (i));
						/* then the RS segment MUST exist */
		call initiate_file_ (dn, en, R_ACCESS, rsp1, (0), ec);
	     end;
	     if rsp1 = null then do;			/* something go wrong? */
		call write_error (ec, i, dnvar || rtrim (en));
		go to exit;
	     end;
	     call hcs_$make_seg ("", "", "", RW_ACCESS_BIN, rsp, ec);
						/* now get temporaries */
	     if rsp = null then do;
		call write_error (ec, i, "temporary segment");
		go to exit;
	     end;
	     ipl = currentsize (rsp1 -> installation_parms);
						/* copy contents to temp segment */
	     unspec (rsp -> copy_ip) = unspec (rsp1 -> copy_ip);
	     rs_ptrs (i) = rsp;
	     rs_ptrs1 (i) = rsp1;
	     if i = 0 then do;			/* some gullibility checks */
		selected_rs_ptr, cur_rs_ptr = ip;
		if installation_parms.version ^= installation_parms_version_2 then do;
		     if installation_parms.version ^= installation_parms_version_1 then do;
			call ioa_ ("The installation_parms segment is either damaged or a pre-MR9.0 version.^/If it is damaged, recover it from backup. If it is pre-MR9.0, MR10.2 or earlier must be used to convert it.");
			go to exit;
		     end;
		     else do;
			call ioa_ ("Converting installation parms to MR11 format.");
			installation_parms.version = installation_parms_version_2;

			installation_parms.trusted_path_login = "0"b;
			installation_parms.require_operator_login = "0"b;
			installation_parms.vchn_requires_accept = "0"b;
			installation_parms.operator_inactive_time = installation_parms.inactive_time;
			installation_parms.syserr_log_copy_threshold = 0;
			installation_parms.validate_daemon_commands = "0"b;
			installation_parms.password_min_length = 0; /* no minimum */
			installation_parms.password_gpw_length = 6;
			installation_parms.password_change_interval = 0; /* no change interval */
			installation_parms.password_expiration_interval = 0; /* no expiration */
			call set_pdir_quota_defaults; /* knows about communications */
		     end;
		end;
		if installation_parms.nrates < 0 | installation_parms.nrates > hbound (rs_ptrs, 1) then do;
		     call com_err_ (0, me,
			"Invalid number of rate_structures at offset ^o (8): ^d. Forcing value to 0.",
			bin (rel (addr (installation_parms.nrates)), 18), installation_parms.nrates);
		     installation_parms.nrates = 0;
		end;
	     end;
	end;


/* Handler for PROGRAM_INTERRUPT condition
   If a 'critical' operation is in progress, we ask the user whether or
   not we should really punt.  If not critical, or user says it's OK,
   we non-local goto back to the main loop.  Otherwise, restart. */

	on program_interrupt
	     begin;
dcl  yn char (4);
	     if critical_op then do;			/* HOT? */
		call ioa_ ("Terminating the current operation may leave tables in an inconsistent state.");
		call ask_$ask_yn ("Do you want to terminate? (""no"" will restart the operation)  ", yn);
		if yn = "yes" then go to main1;	/* we warned you */
	     end;
	     else go to main1;			/* safe to zap, so do it */
	end;

%page;

/* MAIN REQUEST LOOP */

main1:
	call ask_$ask_clr ();
main:
	if ^told_user then do;			/* Should we give instructions? */
	     call ioa_ ("Hit QUIT and use ""program_interrupt"" to return this request loop.");
	     told_user = "1"b;			/* never again in this process */
	end;

	cur_rs_ptr = selected_rs_ptr;			/* make sure we're using the proper rate_structure */
	edit_rs = (cur_rs_ptr ^= ip);			/* editing a rate_structure? */
	critical_op = "0"b;
	all_sw = "0"b;				/* OFF until: all, all_structures */
	all_abs_queue_sw = "0"b;			/* OFF until: all, all_structures, abs_queue_parameters */
	all_rates_sw = "0"b;			/* OFF until: all, all_structures, rates */
	all_structures_sw = "0"b;			/* OFF until: all_structures */
	change_request = "0"b;			/* OFF unless 'change' command */
	call ask_ ("type ", comm);			/* get command */
	if comm = "q" then do;
exit:
	     call clean_up;
	     return;
	end;
	else if comm = "w" then do;			/* write? */
	     call ask_$ask_n (char8, j);		/* write -force? */
	     if j ^= 0 then
		if ^(char8 = "-force" | char8 = "-fc") then j = 0;
	     do i = installation_parms.nrates to 0 by -1; /* write all rate_structures */
						/* and then installation_parms */
		ipl = currentsize (rs_ptrs (i) -> rate_structure);
						/* HOW big was it? */
		call hcs_$truncate_seg (rs_ptrs1 (i), (ipl), ec);
						/* tidy up end */
		if ec ^= 0 then do;			/* nice way to detect no-write */
		     call write_error (ec, i, "");	/* let user know */
		     if j ^= 0 then go to main1;	/* if not -force */
		end;
		unspec (rs_ptrs1 (i) -> copy_ip) = unspec (rs_ptrs (i) -> copy_ip);
						/* copy to real segment */
		call hcs_$set_bc_seg (rs_ptrs1 (i), 36 * ipl, ec);
						/* show 'em how big it is */
		if ec ^= 0 then do;			/* any little problems? */
		     call write_error (ec, i, "");
		     if j = 0 then go to main1;	/* give up, or -force ? */
		end;
		call hcs_$set_safety_sw_seg (rs_ptrs1 (i), "1"b, ec);
		if ec ^= 0 then do;			/* ok or not */
		     call write_error (ec, i, "");
		     if j = 0 then go to main1;	/* not -force? */
		end;
	     end;
	end;
	else if comm = "a" | comm = "add" then call do_any (ADD);
	else if comm = "c" | comm = "change" then call do_any (CHANGE);
	else if comm = "p" | comm = "pr" | comm = "print" then call do_any (PRINT);
	else if comm = "r" | comm = "retype" then call do_any (RETYPE);
	else if comm = "default" then go to default;	/* defaults of some kind */
	else if comm = "v" | comm = "verify" then call verify_structures;
	else if comm = "h" | comm = "help" then do;	/* help of some kind */
	     call ioa_ ("Requests: change ID, print ID, retype ID, add ID, w, q");
						/* basic requests */
	     call ioa_ ("help {-long}, default, mrXX_default, rate_structure RSN, copy, verify");
	     if edit_rs then call ioa_ ("Use: ""rate_structure ."" to edit the ""installation_parms"" segment.");
	     call ioa_ ("  Valid ids: all");		/* special case first */
	     call ask_$ask_n (char32, k);		/* user wants long output? */
	     if k ^= 0 & (char32 = "long" | char32 = "-long" | char32 = "-lg") then
		k = 1;				/* long, it is */
	     else k = 0;				/* 2 to 1 user types it later... */
	     j = 1;
	     do i = 2 to hbound (keyw, 1);		/* print all keywords */
		do while (keyn (i) > valid_for_rs (j) & j < hbound (valid_for_rs, 1));
		     j = j + 1;			/* next valid RS id */
		end;
		if ^edit_rs | keyn (i) = valid_for_rs (j) then
						/* not RS, or OK for RS */
		     if k ^= 0 | keyn (i) ^= keyn (i - 1) then
						/* not same 'ID', or -long */
			call ioa_ ("^13x^[^2x^]^a", (keyn (i) = keyn (i - 1)), keyw (i));
						/* with short forms indented */
	     end;
	     go to main1;
	end;
	else if comm = "rates" | comm = "rate_structure" then do;
	     call ask_$ask_n (char32, i);		/* trying to go somewhere? */
	     if i = 0 then				/* no - just lost */
		call ioa_ ("Editing rate_structure ""^a"".", ptr_rs_name (cur_rs_ptr));
	     else do;
		call ask_ ("", char32);		/* pick it off the line */
		i = rstab$$defined (char32, COMPLAIN);	/* does it exist? */
		if i < 0 then go to main1;		/* oh my, no it doesn't */
		selected_rs_ptr = rs_ptrs (i);	/* all works out at label main */
	     end;
	end;
	else if comm = "copy" then go to copy_rs;	/* from 1 RS to another */
	else do;
	     call ioa_ ("Illegal command ""^a"". Type help for instructions.", comm);
	     go to main1;
	end;

	go to main;				/* beg for more */
%page;

/* DEFAULT HANDLING for INSTALLATION_PARMS */

default:
	if edit_rs then go to default_rs;

/* will this change device table or resource table? VERY dangerous */

	if installation_parms.nrscp > 0 | installation_parms.ndevices > hbound (dev_id, 1)
	     | installation_parms.version < 0 | installation_parms.version > installation_parms_version_1
	     | installation_parms.version = 0 & ptr (ip, 1076) -> based_integer > 0 then do;
	     call ioa_ ("This operation may make other system tables invalid.");
	     call ask_$ask_yn ("Do you want to proceed?  ", char8);
	     if char8 ^= "yes" then go to main1;
	end;
	installation_parms.installation_id = "Installation and location";
	installation_parms.company = "Company Name";
	installation_parms.department = "Department Name";
	installation_parms.companyds = "C o m p a n y   N a m e";
	installation_parms.departmentds = "D e p a r t m e n t";
	call set_std_shifttab;
	do i = 0 to 7;
	     rate_structure.cpu_price (i) = 240e0;
	     rate_structure.log_base_price (i) = 1.25e0;
	     rate_structure.io_ops_price (i) = 0e0;
	     rate_structure.core_price (i) = 15e0;
	end;
	rate_structure.ndevices = hbound (dev_id, 1);	/* define those devices for which charging is built in */
	do i = 1 to 16;
	     if i <= rate_structure.ndevices then
		rate_structure.device_id (i) = dev_id (i);
	     else rate_structure.device_id (i) = "dev" || ltrim (char (i));
						/* fill in non-garbage for undefined ones */
	     do j = 0 to 7;
		rate_structure.device_price (i, j) = 1e0;
						/* initialize for all shifts */
	     end;
	end;
	installation_parms.default_pdir_dir_quota,
	     installation_parms.default_pdir_seg_quota = 1000;
	installation_parms.operator_inactive_time,
	     installation_parms.inactive_time = 3600;
	installation_parms.warning_time = 300;
	installation_parms.login_time = 360;
	installation_parms.acct_update = 900;
	installation_parms.login_tries = 6;
	rate_structure.disk_price = .19290120e-6;
	rate_structure.registration_price = 0e0;
	rate_structure.dolsign = "$";
	do i = 1 to 4;
	     rate_structure.abs_cpu_price (i) = 200e0;
	     rate_structure.abs_mem_price (i) = 15e0;
	     rate_structure.iod_rec_price (i) = 1.80e0;
	     installation_parms.abs_timax (i) = 16000000;
	     installation_parms.abs_cpu_default_limit (i) = 1200;
						/* 1200 seconds = 20 minutes */
	end;

	do i = 1 to hbound (installation_parms.level_names (*), 1);
	     installation_parms.level_names (i) = "level_" || ltrim (char (i));
	     installation_parms.short_level_names (i) = "l" || ltrim (char (i));
						/* man-or-boy common sub-expression test */
	end;

	installation_parms.level_names (0) = "";	/* level zero is blank */
	installation_parms.short_level_names (0) = "";

	do i = lbound (installation_parms.category_names (*), 1) to hbound (installation_parms.category_names (*), 1);
	     installation_parms.category_names (i) = "category_" || ltrim (char (i));
	     installation_parms.short_category_names (i) = "c" || ltrim (char (i));
	end;

	installation_parms.access_authorization_ceiling = ""b;
						/* Level 0, no categories */

	installation_parms.ncon = 1;
	installation_parms.cpu (1) = 8;
	installation_parms.shift (1) = 7;
	installation_parms.x1 (1) = 0;
	installation_parms.kmem (1) = 16384;
	installation_parms.kbulk (1) = 16384;
	installation_parms.x2 (1) = 0;
	installation_parms.maxa (1) = 3;
	installation_parms.maxq (1) = 3;
	installation_parms.maxu_base (1) = 900;
	installation_parms.response_high (1) = 300;
	installation_parms.response_low (1) = 100;
	installation_parms.x3 (1) = 0;
	installation_parms.syserr_log_copy_threshold = 0; /* use default value in ring 0. */

/* Following parameters added for MR6.5 */

	unspec (installation_parms.rcp_init_flags) = ""b; /* all flags off */
	installation_parms.nrscp = 0;			/* no resource prices defined */
	installation_parms.rsc_timer_seconds = 300;	/* 5 minutes between tries for resource reservations */
	installation_parms.fatal_error_loop_count = 3;	/* any user who gets 3 fatal process errors */
	installation_parms.fatal_error_loop_seconds = 60; /* within one minute, gets logged out */
	installation_parms.term_real_time_seconds = 120;	/* allow 2 minutes to signal finish after getting trm_ signal */
	installation_parms.term_cpu_time_seconds = 5;	/* and only 5 seconds of cpu time (in case of runaway process) */

/* Following parameters added for MR7.0 */

	do i = 1 to 4;
	     if installation_parms.abs_cpu_default_limit (i) > MILLION then
						/* if limit is still in microseconds */
		installation_parms.abs_cpu_default_limit (i) =
		     divide (installation_parms.abs_cpu_default_limit (i), MILLION, 35, 0);
						/* convert it to seconds */
	end;

	installation_parms.foreground_queue_position = 0; /* foreground queue comes after Q 0, before Q 1 */
	installation_parms.foreground_cpu_default_limit = installation_parms.abs_cpu_default_limit (3);
						/* current shift 3 limit is better than none at all */
	installation_parms.idle_time_constant_seconds = 900;
						/* average the idle units over the last 5 minutes */
	installation_parms.sus_cpu_time_seconds = 5;	/* allow suspended process to use up to 5 cpu seconds */
	installation_parms.sus_real_time_seconds = 180;	/* and up to 3 minutes for it to respond, before destroying it */

	do i = 0 to 7;				/* go thru shifts */
	     installation_parms.max_abs (i) = -1;	/* -1 means "use the abs_maxu in the config array" */
	     installation_parms.min_abs (i) = 0;
	     installation_parms.pct_abs (i) = 0;
	     do j = 1 to 4;				/* go thru queues */
		installation_parms.abs_cpu_max_limit (i, j) = installation_parms.abs_cpu_default_limit (j);
						/* keeping the effective limits the same as they are now */
		installation_parms.max_qres (i, j) = 0; /* no slots reserved, by default */
		installation_parms.min_qres (i, j) = 0;
		installation_parms.pct_qres (i, j) = 0;
	     end;
	end;

/* Following parameters added for MR8.0 */

	if substr (installation_parms.rcp_init_flags.pad1, 1, 1) then
						/* old skip_validation bit */
	     installation_parms.rcp_init_flags.authentication_level = No_authentication;
	else if substr (installation_parms.rcp_init_flags.pad1, 2, 1) then
						/* old exact_authentication bit */
	     installation_parms.rcp_init_flags.authentication_level = Automatic_authentication;
	else installation_parms.rcp_init_flags.authentication_level = Nominal_authentication;

	installation_parms.rcp_init_flags.pad1 = ""b;	/* zero obsolete bits */

	if edit_rs then go to cant_comm_rs;

	installation_parms.default_absentee_queue = 3;	/* for enter_abs_request, etc. */
	installation_parms.chn_wakeup_error_loop_count = 10;
						/* to control Answering Service hacking */
	installation_parms.chn_wakeup_error_loop_seconds = 3;
						/* ditto */
	installation_parms.nrates = 0;		/* only RS 0 (installation_parms) */
	installation_parms.rate_structures (*) = "";	/* all RS names are blank */
	installation_parms.rate_structures (0) = "default";
						/* except the zero-th */
	installation_parms.trusted_path_login = "0"b;
	installation_parms.require_operator_login = "0"b;
	installation_parms.vchn_requires_accept = "0"b;
	installation_parms.validate_daemon_commands = "0"b;
	installation_parms.operator_inactive_time = installation_parms.inactive_time;
	installation_parms.password_min_length = 0;	/* none */
	installation_parms.password_gpw_length = 6;	/* compatibility */
	installation_parms.password_change_interval = 0;	/* none */
	installation_parms.password_expiration_interval = 0; /* none */

	call verify_structures;			/* make a fast check */

	go to main;

cant_comm_rs:
	call ioa_ ("""^a"" is not allowed while editing a rate_structure.", comm);
	go to main1;
%page;

/* DEFAULT HANDLING for RATE-STRUCTURES */

default_rs:					/* default for a rate_structure working installation_parms */
	rsp = ip;
	go to copy_rs1;

copy_rs:						/* copy anywhere but into installation_parms */
	if cur_rs_ptr = ip then do;
	     call ioa_ ("A copy into the default rate structure is not allowed.  Use default or change all.");
	     go to main1;
	end;
crs1a:
	call ask_ ("from^-", char32);			/* what is user's desire? */
	i = rstab$$defined (char32, COMPLAIN);		/* is it feasible? */
	if i < 0 then go to crs1a;			/* 'fraid not */
	rsp = rs_ptrs (i);				/* pointer to it */
	if rsp = cur_rs_ptr then do;			/* how silly */
	     call ioa_ ("A copy from the same rate structure is not allowed.");
	     call ask_$ask_clr ();
	     go to crs1a;
	end;

copy_rs1:						/* copy all pricing info */
	do i = 0 to 7;
	     rate_structure.cpu_price (i) = rsp -> rate_structure.cpu_price (i);
	     rate_structure.log_base_price (i) = rsp -> rate_structure.log_base_price (i);
	     rate_structure.io_ops_price (i) = rsp -> rate_structure.io_ops_price (i);
	     rate_structure.core_price (i) = rsp -> rate_structure.core_price (i);
	end;
	rate_structure.disk_price = rsp -> rate_structure.disk_price;

	rate_structure.registration_price = rsp -> rate_structure.registration_price;
	rate_structure.ndevices = rsp -> rate_structure.ndevices;
	rate_structure.devtab (*) = rsp -> rate_structure.devtab (*);
	rate_structure.abs_cpu_price (*) = rsp -> rate_structure.abs_cpu_price (*);
	rate_structure.abs_mem_price (*) = rsp -> rate_structure.abs_mem_price (*);
	rate_structure.iod_rec_price (*) = rsp -> rate_structure.iod_rec_price (*);
	rate_structure.nrscp = rsp -> rate_structure.nrscp;
						/* Keep resources in order and position. */
	rate_structure.resource (*).name = rsp -> rate_structure.resource (*).name;
	rate_structure.resource (*).price = rsp -> rate_structure.resource (*).price;
	go to main;
%page;

/*  OPERATION SUPERVISOR */

do_any:
     procedure (OP);

dcl  OP fixed bin;
dcl  IX fixed bin;
dcl  i fixed bin;
dcl  seq_ptr ptr;
dcl  seq_size fixed bin;
dcl  sequence (seq_size) fixed bin based (seq_ptr);

/* This internal procedure calls the correct processor for OP */

worker:
	procedure (IX);				/* dispatch */
						/* keep everything pl1-quick */
dcl  IX fixed bin;

	     did_something = "1"b;			/* assume the best */
	     suppress_nl = "0"b;			/* ditto */
	     if OP = ADD then call do_add (IX);
	     else if OP = CHANGE then call do_change (IX);
	     else if OP = PRINT then call do_print (IX);
	     else if OP = RETYPE then call do_retype (IX);
	     return;

	end worker;


/* BEGIN do_any */

	if OP = ADD then do;			/* get a nice long name for request */
	     print_comm = "add";
	end;
	else if OP = CHANGE then do;
	     print_comm = "change";
	     change_request = "1"b;			/* this really is change, not retype */
	end;
	else if OP = PRINT then do;
	     print_comm = "print";
	end;
	else if OP = RETYPE then do;
	     print_comm = "retype";
	end;
	else do;
	     call com_err_ (0, me, "Internal error. Argument to ""do_any"" is ^d.", OP);
	     return;
	end;

	call ask_ ("id  ", char32);			/* OP on what? */
	keywx = checkid (char32, COMPLAIN);		/* is it legit? */
	if keywx < 0 then go to main1;		/* something was wrong */

do_any_common:
	if keywx = 1 | keywx = 15 | keywx = 51 then do;	/* ALL, ABS_QUEUE_PARAMETERS, RATES */
	     if keywx = 1 then do;			/* all */
		if edit_rs then go to do_rates;	/* simulate 'rates ' */
		all_rates_sw = "1"b;		/* all => rates */
		all_abs_queue_sw = "1"b;		/* all => abs_queue_parameters */
		all_sw = "1"b;			/* indicate 'all' */
		seq_ptr = addr (sequence_ALL);	/* where is the sequence array? */
		seq_size = hbound (sequence_ALL, 1);	/* and how big? */
	     end;
	     else if keywx = 15 then do;		/* abs_queue_parameters */
		all_abs_queue_sw = "1"b;		/* indicate 'abs_queue_parameters' */
		seq_ptr = addr (sequence_ABS_Q);	/* pointer to sequence array */
		seq_size = hbound (sequence_ABS_Q, 1);	/* size thereof */
	     end;
	     else if keywx = 51 then do;		/* rates */
do_rates:
		all_rates_sw = "1"b;		/* indicate all rates */
		seq_ptr = addr (sequence_RATES);	/* pointer to sequence array */
		seq_size = hbound (sequence_RATES, 1);	/* size thereof */
	     end;

	     do i = 1 to seq_size;			/* NOW, do each sub-request */
		call worker (sequence (i));		/* appropriate processor for OP */
		if ^suppress_nl & did_something then call ioa_ ("");
						/* blank line, if required */
	     end;
	end;
	else if keywx = 55 then do;
	     all_structures_sw = "1"b;		/* indicate 'all_structures' */
	     all_sw = "1"b;				/* => all */
	     all_rates_sw = "1"b;			/* => rates */
	     all_abs_queue_sw = "1"b;			/* => abs_queue_parameters */
	     do i = 0 to installation_parms.nrates;	/* now, for each rate_structure */
		cur_rs_ptr = rs_ptrs (i);		/* setup pointer ro RS */
		edit_rs = (cur_rs_ptr ^= ip);		/* flag if not IP */
		call do_any$$given_index (OP, 1);	/* 'all' for this rate_structure */
	     end;
	     cur_rs_ptr = selected_rs_ptr;		/* back to whatever it was */
	     edit_rs = (cur_rs_ptr ^= ip);
	end;
	else do;
	     call worker (keywx);			/* run-of-the-mill */
	end;

	return;

do_any$$given_index:
     entry (OP, IX);				/* alternate entry - have index already */

	keywx = IX;
	go to do_any_common;

     end do_any;
%page;

/* PROCESS SINGLE ADD REQUEST */

do_add:
     procedure (IX);

dcl  IX fixed bin;

dcl  (i, j) fixed bin;
dcl  devnm char (8);
dcl  rscnm char (32);

	if IX < lbound (add, 1) | IX > hbound (add, 1) then do;
	     call com_err_ (0, me, "Internal error. do_add index ^d.", IX);
	     return;
	end;

	go to add (IX);

add (1):						/* all */
add (2):						/* installation_id */
add (3):						/* shift_table */
add (4):						/* prices */
add (5):						/* titles */
add (6):						/* level_names */
add (7):						/* inactive_time */
add (8):						/* warning_time */
add (9):						/* login_time */
add (10):						/* tries */
add (11):						/* update_time */
add (14):						/* queue_prices */
add (15):						/* abs_queue_parameters */
add (16):						/* category_names */
add (17):						/* access_ceiling */
add (18):						/* log_parameters */
add (19):						/* trusted_path_login */
add (23):						/* resource_wait_time */
add (24):						/* fpe_time */
add (25):						/* fpe_count */
add (26):						/* trm_real_time */
add (27):						/* trm_cpu_time */
add (28):						/* unload_on_detach */
add (29):						/* authentication_level */
add (30):						/* default_pdir_seg_quota */
add (56):						/* default_pdir_dir_quota */
add (31):						/* rsc_mgmt_enabled */
add (32):						/* auto_registration */
add (33):						/* enable_ss_volume_mount */
add (34):						/* foreground_queue_position */
add (35):						/* idle_time_constant */
add (36):						/* sus_cpu_time */
add (37):						/* sus_real_time */
add (38):						/* max_abs */
add (39):						/* min_abs */
add (40):						/* pct_abs */
add (41):						/* max_qres */
add (42):						/* min_qres */
add (43):						/* pct_qres */
add (44):						/* abs_cpu_max_limit */
add (45):						/* abs_timax */
add (46):						/* abs_cpu_default_limit */
add (47):						/* foreground_cpu_default_limit */
add (48):						/* abs_default_queue */
add (49):						/* cwe_time */
add (50):						/* cwe_count */
add (51):						/* rates */
add (55):						/* all_structures */
add (57):						/* require_operator_login */
add (58):						/* operator_inactive */
add (59):						/* validate_daemon_commands */
add (60):						/* password_min_length */
add (61):						/* password_gpw_length */
add (62):						/* password_change_interval */
add (63):						/* password_expiration_interval */
add (64):						/* vchn_requires_accept */

	call ioa_ ("""add ^a"" is not allowed.  Try ""retype"".", idt (keywx));
	go to main1;

add (12):						/* device_prices */
	go to add (52);

add (13):						/* config table */
	if installation_parms.ncon = 51 then do;
	     call ioa_ ("config table full");
	     call ask_$ask_clr ();
	     return;
	end;
	i = installation_parms.ncon + 1;
	call input_config_element (i);
	if installation_parms.cona (i).cpu > 0 then installation_parms.ncon = i;
	call sort_config_table;
	return;

add (20):						/* device_names */
	go to add (52);

add (21):						/* resource_prices */
add (22):						/* resource_names */
	go to add (53);

add (52):						/* devices */
	if edit_rs then go to cant_add_rs;
	if installation_parms.ndevices = 16 then do;
	     call ioa_ ("device table full");
	     call ask_$ask_clr ();
	     return;
	end;
add52a:
	call ask_ ("device^-", devnm);
	j = devtab$$undefined (devnm, NO_SPECIAL_DEVICES, COMPLAIN);
						/* best not exist */
	if j >= 0 then go to add52a;			/* oh dear, it does */
	call input_device_price (installation_parms.ndevices + 1, devnm, ALL_RS, SET_HI);
	return;

add (53):						/* resources */
	if edit_rs then go to cant_add_rs;
	call ask_ ("resource^-", rscnm);
	j = rsctab$$undefined (rscnm, COMPLAIN);	/* best not exist */
	if j >= 0 then go to add (53);		/* horrors! it does */
	call input_resource_price (installation_parms.nrscp + 1, rscnm, ALL_RS, SET_HI);
	return;

add (54):						/* rate_structure_name */
	if edit_rs then go to cant_add_rs;
	if installation_parms.nrates >= hbound (installation_parms.rate_structures, 1) then do;
	     call ioa_ ("An attempt to add more than ^n rate structures has been made and ignored.",
		hbound (installation_parms.rate_structures, 1));
	     go to main1;
	end;
	j = installation_parms.nrates + 1;
add54a:
	call ask_ ("new rate_structure name  ", rscnm);
	i = rstab$$undefined (rscnm, COMPLAIN);		/* ensure no such RS already */
	if i >= 0 then go to add54a;			/* oh dear - try again */

	en = "rate_structure_" || ltrim (char (j));	/* make the live segment */
	call hcs_$make_seg (dn, en, "", RW_ACCESS_BIN, rsp1, ec);
	if rsp1 = null then do;
	     call write_error (ec, j, dnvar || rtrim (en));
	     return;
	end;
	call hcs_$set_ring_brackets (dn, en, ip_rings, ec);
						/* make sure it's accessible to ring 5 */
	if ec ^= 0 then call com_err_ (ec, me, "Setting ring brackets of ^a.", en);
	call hcs_$make_seg ("", "", "", RW_ACCESS_BIN, rsp, ec);
						/* make the temp copy */
	if rsp = null then do;
	     call write_error (ec, j, "temporary segment");
	     return;
	end;

	critical_op = "1"b;				/* critical while we setup the RS */
	rs_ptrs1 (j) = rsp1;
	rs_ptrs (j) = rsp;

/* make new RS look like all the rest, with 0.0 prices */
	rsp -> rate_structure.rate_structure_number = j;	/* unique */
	rsp -> rate_structure.rate_structures (*) = installation_parms.rate_structures (*);
	rsp -> rate_structure.cpu_price (*) = 0e0;
	rsp -> rate_structure.log_base_price (*) = 0e0;
	rsp -> rate_structure.io_ops_price (*) = 0e0;
	rsp -> rate_structure.core_price (*) = 0e0;
	rsp -> rate_structure.disk_price = 0e0;
	rsp -> rate_structure.registration_price = 0e0;
	rsp -> rate_structure.dolsign = "$";
	rsp -> rate_structure.ndevices = installation_parms.ndevices;
	rsp -> rate_structure.devtab (*).device_id = installation_parms.devtab (*).device_id;
	rsp -> rate_structure.devtab (*).device_price (*) = 0e0;
	rsp -> rate_structure.abs_cpu_price (*) = 0e0;
	rsp -> rate_structure.abs_mem_price (*) = 0e0;
	rsp -> rate_structure.iod_rec_price (*) = 0e0;
	rsp -> rate_structure.nrscp = installation_parms.nrscp;
	rsp -> rate_structure.resource (*).name = installation_parms.resource (*).name;
	rsp -> rate_structure.resource (*).price = 0e0;

	do i = j to 0 by -1;			/* add new rate_structure to all structures */
	     rs_ptrs (i) -> rate_structure.nrates = j;
	     rs_ptrs (i) -> rate_structure.rate_structures (j) = rscnm;
	end;

	critical_op = "0"b;
	call ioa_ ("rate_structure ""^a"" defined.  All prices are 0.0.", rscnm);
	return;

cant_add_rs:
	call ioa_ ("""^a ^a"" is not allowed while editing a rate_structure.", print_comm, idt (IX));
	go to main1;

     end do_add;
%page;

/* PROCESS SINGLE CHANGE REQUEST */

do_change:
     procedure (IX);

dcl  IX fixed bin;

dcl  (i, i1, i2, i3, i4, j, k, n) fixed bin;
dcl  rscnm char (32);
dcl  devnm char (8);

	if IX < lbound (change, 1) | IX > hbound (change, 1) then do;
	     call com_err_ (0, me, "Internal error. do_change index ^d.", IX);
	     return;
	end;

	go to change (IX);

change (2):					/* installation_id */
change (5):					/* titles */
change (7):					/* inactive_time */
change (8):					/* warning_time */
change (9):					/* login_time */
change (10):					/* tries */
change (11):					/* update_time */
change (15):					/* abs_queue_parameters */
change (17):					/* access_ceiling */
change (18):					/* log_parameters */
change (19):					/* trusted_path_login */
change (23):					/* rsctime */
change (24):					/* fpetime */
change (25):					/* fpecount */
change (26):					/* trmrealtime */
change (27):					/* trmcputime */
change (28):					/* unload_on_detach */
change (29):					/* authentication_level */
change (30):					/* default_pdir_seg_quota */
change (56):					/* default_pdir_dir_quota */
change (31):					/* rsc_mgmt_enabled */
change (32):					/* auto_registration */
change (33):					/* enable_ss_volume_mount */
change (34):					/* foreground_queue_position */
change (35):					/* idle_time_constant */
change (36):					/* sus_cpu_time */
change (37):					/* sus_real_time */
change (38):					/* max_abs */
change (39):					/* min_abs */
change (40):					/* pct_abs */
change (41):					/* max_qres */
change (42):					/* min_qres */
change (43):					/* pct_qres */
change (44):					/* abs_cpu_max_limit */
change (45):					/* abs_timax */
change (46):					/* abs_cpu_default_limits */
change (47):					/* foreground_cpu_default_limit */
change (48):					/* abs_default_queue */
change (49):					/* cwe_time */
change (50):					/* cwe_count */
change (51):					/* rates */
change (57):					/* require_operator_login */
change (58):					/* operator_inactive */
change (59):					/* validate_daemon_commands */
change (60):					/* password_min_length */
change (61):					/* password_gpw_length */
change (62):					/* password_change_interval */
change (63):					/* password_expiration_interval */
change (64):					/* vchn_requires_accept */

	call do_retype (IX);
	return;

change (1):					/* all */
	go to cant_change;

change (3):					/* shift table */
	call ask_ ("day^-", char8);
	i = index (daynam, substr (char8, 1, 3)) - 1;
	if i < 0 then do;
badday:
	     call ioa_ ("^a illegal day", char8);
	     call ask_$ask_clr ();
	     go to change (3);
	end;
	i = divide (i, 3, 17, 0);
badhour:
	call set_half_al ("hour", "", j, 0, 23);
badhalf:
	call ask_$ask_int ("half^-", n);
	if n = 30 then n = 1;
	else if n ^= 0 & n ^= 1 then do;
	     call ioa_ ("illegal half hour ^d. Must be 0 for the hour and 1 or 30 for the half.", n);
	     call ask_$ask_clr ();
	     go to badhalf;
	end;
	call ask_$ask_n (char8, i1);			/* check for type ahead */
	if i1 ^= 0 & char8 = "thru" then do;		/* if "thru" typed ahead */
	     call ask_ ("", char8);			/* get it off the input line */
	     call ask_ ("thru day^-", char8);
	     i2 = divide (index (daynam, substr (char8, 1, 3)) - 1, 3, 17, 0);
	     if i2 < 0 then go to badday;
	     call ask_$ask_int ("thru hour^-", i3);	/* i3 = hour = final value of j */
	     if i3 < 0 | i3 > 23 then go to badhour;
	     call ask_$ask_int ("thru half^-", i4);	/* i4 = half = final value of n */
	     if i4 > 0 then
		i4 = 1;
	     else i4 = 0;
	end;
	else i1 = 0;				/* remember that thru was not given */

	call set_half_al ("shift", "", k, 0, 7);
	call set_shift_field (i, j, k, n);

	if i1 ^= 0 then				/* if "thru" was given */
	     do while (i ^= i2 | j ^= i3 | n ^= i4);	/* set shifts til we reach the thru time */
	     n = n + 1;				/* advance half hour */
	     if n = 2 then do;			/* if next hour */
		n = 0;
		j = j + 1;			/* advance hour */
		if j = 24 then do;			/* if end of day */
		     j = 0;
		     i = i + 1;			/* advance day */
		     if i = 7 then			/* if end of week */
			i = 0;
		end;
	     end;
	     call set_shift_field (i, j, k, n);
	end;
	return;

change (4):					/* prices */
	call set_half_al ("shift", "", k, 0, 7);
	call ask_$ask_flo ("cpu^-", rate_structure.cpu_price (k));
	call ask_$ask_flo ("log^-", rate_structure.log_base_price (k));
	call ask_$ask_flo ("mem^-", rate_structure.core_price (k));
	call ask_$ask_flo ("io ops^-", rate_structure.io_ops_price (k));
	return;

change (6):					/* sensitivity level names */
	call set_half_al ("level", "", i, lbound (installation_parms.level_names, 1),
	     hbound (installation_parms.level_names, 1));
	call enter_level_name (i);
	return;

change (12):					/* device prices */
	call ask_ ("device^-", devnm);
	i = devtab$$defined (devnm, SPECIAL_DEVICES_OK, COMPLAIN);
						/* find that device */
	if i < 0 then go to change (12);		/* I beg your pardon */
	call input_device_price (i, devnm, THIS_RS, NO_SET_HI);
	return;

change (13):					/* config table */
	do while ("1"b);
	     call ask_$ask_int ("ncpu  ", i1);
	     call ask_$ask_int ("nmem  ", i2);
	     call ask_$ask_int ("bulk  ", i3);
	     call ask_$ask_int ("shift ", i4);
	     do i = 1 to installation_parms.ncon;
		if installation_parms.cona.cpu (i) = i1 then
		     if installation_parms.cona.kmem (i) = i2 then
			if installation_parms.cona.kbulk (i) = i3 then
			     if installation_parms.cona.shift (i) = i4 then do;
				call print_config_element (i);
				call input_config_element (i);
				call sort_config_table;
				return;
			     end;
	     end;
	     call ioa_ ("config ^d ^d ^d ^d not found", i1, i2, i3, i4);
	     call ask_$ask_clr ();
	end;

change (14):					/* queue prices */
	call set_half_al ("queue", "", i, 1, 4);
	call ask_$ask_flo ("abs CPU ^d^-", rate_structure.abs_cpu_price (i), i);
	call ask_$ask_flo ("abs mem ^d^-", rate_structure.abs_mem_price (i), i);
	call ask_$ask_flo ("iod records ^d^-", rate_structure.iod_rec_price (i), i);
	return;

change (16):					/* category names */
	call set_half_al ("category", "", i, lbound (installation_parms.category_names, 1),
	     hbound (installation_parms.category_names, 1));
	call enter_category_name (i);
	return;

change (20):					/* device name */
	if edit_rs then go to cant_change_rs;
	call ask_ ("device^-", devnm);
	i = devtab$$defined (devnm, NO_SPECIAL_DEVICES, COMPLAIN);
						/* find it in devtab */
	if i < 0 then go to change (20);		/* couldn't find it */
ch20a:
	call ask_ ("new device name^-", devnm);
	if devnm = installation_parms.device_id (i) then do;
	     k = devtab$$undefined (devnm, NO_SPECIAL_DEVICES, COMPLAIN);
						/* new name must not exist */
	     if k >= 0 then go to ch20a;		/* try again */
	end;
	k = installation_parms.ndevices;
	if devnm = "dev" || ltrim (char (i)) & i = k then k = k - 1;
	critical_op = "1"b;
	do j = installation_parms.nrates to 0 by -1;	/* All rate structures must have the same devices */
	     rs_ptrs (j) -> rate_structure.ndevices = k;
	     rs_ptrs (j) -> rate_structure.device_id (i) = devnm;
	end;
	critical_op = "0"b;
	return;

change (21):					/* resource_prices */
	call ask_ ("resource^-", rscnm);
	i = rsctab$$defined (rscnm, COMPLAIN);		/* find resource */
	if i < 0 then go to change (21);		/* couldn't */
	call input_resource_price (i, rscnm, THIS_RS, NO_SET_HI);
	return;

change (22):					/* rscname */
	if edit_rs then go to cant_change_rs;
	call ask_ ("resource^-", rscnm);
	i = rsctab$$defined (rscnm, COMPLAIN);		/* find resource */
	if i < 0 then go to change (22);		/* not present */
	call ask_ ("new resource name^-", rscnm);
ch22a:
	if rscnm ^= installation_parms.resource (i).name then do;
	     j = rsctab$$undefined (rscnm, COMPLAIN);	/* look out for duplicates */
	     if j >= 0 then go to ch22a;		/* try for another name */
	end;
	critical_op = "1"b;
	do j = installation_parms.nrates to 0 by -1;
	     rs_ptrs (j) -> rate_structure.resource (i).name = rscnm;
	end;
	critical_op = "0"b;
	return;

change (52):					/* devices */
	go to change (12);

change (53):					/* resources */
	go to change (21);

change (54):					/* rate_structure_name */
	if edit_rs then go to cant_change_rs;
	call ask_ ("rate_structure^-", rscnm);
	i = rstab$$defined (rscnm, COMPLAIN);		/* find the RS */
	if i < 0 then go to change (54);		/* doesn't exist */
ch54a:
	call ask_ ("new rate_structure name^-", rscnm);
	if rscnm ^= installation_parms.rate_structures (i) then do;
	     j = rstab$$undefined (rscnm, COMPLAIN);	/* look out for duplicate names */
	     if j >= 0 then go to ch54a;		/* oh dear - found duplicate */
	end;
	critical_op = "1"b;
	do j = installation_parms.nrates to 0 by -1;
	     rs_ptrs (j) -> rate_structure.rate_structures (i) = rscnm;
	end;
	critical_op = "0"b;
	return;

change (55):					/* all_structures */
	go to cant_change;

changed_nothing:
	did_something = "0"b;
	return;

cant_change:
	call ioa_ ("""^a ^a"" is not allowed.", print_comm, idt (IX));
	go to main1;

cant_change_rs:
	call ioa_ ("""^a ^a"" is not allowed while editing a rate_structure.", print_comm, idt (IX));
	go to main1;

     end do_change;
%page;

/* PROCESS SINGLE PRINT REQUEST */

do_print:
     procedure (IX);

dcl  IX fixed bin;

dcl  (i, j, k, m, n) fixed bin;
dcl  c15 char (15);
dcl  char48 char (48);
dcl  no_charge bit (1) aligned;
dcl  (dflt, mx, tmx) bit (1) aligned;
dcl  rscnm char (32);
dcl  devnm char (8);
dcl  pass_sw bit (1) aligned;

	if IX < lbound (print, 1) | IX > hbound (print, 1) then do;
	     call com_err_ (0, me, "Internal error. do_print index ^d.", IX);
	     return;
	end;

	go to print (IX);

print (1):					/* all */
	call ioa_ ("^/^-Installation parameters^/");
	return;

print (2):					/* installation_id */
	call ioa_ ("Installation id:^-^a", installation_parms.installation_id);
	return;

print (3):					/* shift_table */
	call ioa_ ("^4xM^15x8^7xN^11x6");
	do i = 0 to 6;
	     char48 = "";
	     m = 1;
	     do j = 0 to 23;
		do n = 0 to 1;
		     k = fixed (installation_parms.shifttab (48 * i + 2 * j + n + 1), 3);
		     substr (char48, m, 1) = ltrim (char (k));
		     m = m + 1;
		end;
	     end;
	     call ioa_ ("^a ^a", substr (daynam, 3 * i + 1, 3), char48);
	end;
	return;

print (4):					/* prices */
	call ioa_ ("disk price:^-$^f/page-second, $^f/page-30-days", rate_structure.disk_price,
	     rate_structure.disk_price * SECONDS_PER_MONTH);
	call ioa_ ("registration fee:^-^a/user^/", cv_$mwvf (rate_structure.registration_price));
	call ioa_ ("Shift^13xcpu^13xlog^13xmem^10xio ops");
	do i = 0 to 7;
	     if rate_structure.cpu_price (i) + rate_structure.log_base_price (i) + rate_structure.io_ops_price (i)
		+ rate_structure.core_price (i) > 0.0e0 then
		call ioa_ ("^4x^1d ^15a ^15a ^15a ^15a", i, cv_$mwvf (rate_structure.cpu_price (i)),
		     cv_$mwvf (rate_structure.log_base_price (i)), cv_$mwvf (rate_structure.core_price (i)),
		     cv_$mwvf (rate_structure.io_ops_price (i)));
	end;
	return;

print (5):					/* titles */
	call ioa_ ("Company:^-^-^a", installation_parms.company);
	call ioa_ ("Department:^-^a", installation_parms.department);
	call ioa_ ("Companyds:^-^a", installation_parms.companyds);
	call ioa_ ("Departmentds:^-^a", installation_parms.departmentds);
	return;

print (6):					/* level_names */
	call ioa_ ("Level    Short Name    Name");
	do i = lbound (installation_parms.level_names (*), 1) to hbound (installation_parms.level_names (*), 1);
	     call ioa_ ("^3d^6x^8a^6x^a", i, installation_parms.short_level_names (i),
		installation_parms.level_names (i));
	end;
	return;

print (7):					/* inactive_time */
	call ioa_ ("inactive_time:^-^d sec.", installation_parms.inactive_time);
	suppress_nl = "1"b;				/* tight output */
	return;

print (58):
	call ioa_ ("operator_inactive_time:^-^d sec.", installation_parms.operator_inactive_time);
	suppress_nl = "1"b;				/* tight output */
	return;

print (8):					/* warning_time */
	call ioa_ ("warning_time:^-^d sec.", installation_parms.warning_time);
	suppress_nl = "1"b;				/* tight output */
	return;

print (9):					/* login_time */
	call ioa_ ("login_time:^-^d sec.", installation_parms.login_time);
	suppress_nl = "1"b;				/* tight output */
	return;

print (10):					/* tries */
	call ioa_ ("tries:^2-^d", installation_parms.login_tries);
	suppress_nl = "1"b;
	return;

print (11):					/* update_time */
	call ioa_ ("acct_update:^-^d sec.", installation_parms.acct_update);
	return;

print (12):					/* device_prices */
	go to print (52);				/* devices */

print (13):					/* config_table */
	call ioa_ ("  cpu   mem  bulk shift     min     max    base   abs  absq");
	do i = 1 to installation_parms.ncon;
	     call print_config_element (i);
	end;
	return;

print (14):					/* queue_prices */
	call ioa_ ("Queue  Abs CPU  Abs mem   IO recs");
	do i = 1 to 4;
	     call ioa_ ("  ^1d   ^8.2f  ^8.2f ^8.2f", i, rate_structure.abs_cpu_price (i),
		rate_structure.abs_mem_price (i), rate_structure.iod_rec_price (i));
	end;
	return;

print (15):					/* abs_queue_parameters */
	tmx, dflt, mx = "1"b;			/* print all 3 parameters */
	go to print_abs_queue_parameters;

print (16):					/* category_names */
	call ioa_ ("Category Short Name    Name");
	do i = lbound (installation_parms.category_names (*), 1) to hbound (installation_parms.category_names (*), 1);
	     call ioa_ ("^3d^6x^8a^6x^a", i, installation_parms.short_category_names (i),
		installation_parms.category_names (i));
	end;
	return;

print (17):					/* access_ceiling */
	call ioa_ ("Access ceiling:^-level = ^d, categories = ^6.3b",
						/* N.B. Format depends on number of categories */
	     addr (installation_parms.access_authorization_ceiling) -> aim_template.level,
	     addr (installation_parms.access_authorization_ceiling) -> aim_template.categories);
	return;

print (18):					/* log_parameters */
	if installation_parms.syserr_log_copy_threshold = -1 then call ioa_ ("Syserr log copying disabled.");
	else if installation_parms.syserr_log_copy_threshold = 0 then
	     call ioa_ ("Syserr log copying threshold is using default value.");
	else call ioa_ ("Syserr log copying threshold: ^d pages", installation_parms.syserr_log_copy_threshold);
	return;

print (19):					/* trusted_path_login */
	call ioa_ ("trusted_path_login: ^[yes^;no^]. Terminal disconnection is^[ not^] required to change authorization.", installation_parms.trusted_path_login, ^installation_parms.trusted_path_login);
	return;

print (57):
	call ioa_ ("require_operator_login: ^[yes^;no^]. Operators are^[ not^] required to sign on before entering commands.", installation_parms.require_operator_login, ^installation_parms.require_operator_login);
	return;

print (59):
	call ioa_ ("validate_daemon_commands: ^[yes^;no^]. Access to .mcacs segments is^[ not^] required to reply, quit, login, logout, or new_proc daemons.", installation_parms.validate_daemon_commands, ^installation_parms.validate_daemon_commands);
	return;

print (60):
	call ioa_ ("password_min_length: ^[no minimum length^s^;^d^].",
	     (installation_parms.password_min_length = 0),
	     installation_parms.password_min_length);
	return;
print (61):
	call ioa_ ("password_gpw_length: ^d.",
	     installation_parms.password_gpw_length);
	return;
print (62):
	call ioa_ ("password_change_interval: ^[no enforced interval^s^;^d days^].",
	     (installation_parms.password_change_interval = 0),
	     installation_parms.password_change_interval);
	return;
print (63):
	call ioa_ ("password_expiration_interval: ^[no enforced interval^s^;^d days^].",
	     (installation_parms.password_expiration_interval = 0),
	     installation_parms.password_expiration_interval);
	return;
print (64):
	call ioa_ ("vchn_requires_accept: ^[yes^;no^]. virtual channel MC attachments do^[ not^] require ""accept""",
	     installation_parms.vchn_requires_accept, ^installation_parms.vchn_requires_accept);
	return;
print (20):					/* devname */
	if all_rates_sw then go to printed_nothing;	/* device_prices will do it */
	do i = 1 to rate_structure.ndevices;
	     call ioa_ ("^2d)^2x^8a", i, rate_structure.device_id (i));
	end;
	return;

print (21):					/* resource_prices */
	go to print (53);				/* resources */

print (22):					/* rscname */
	if all_rates_sw then go to printed_nothing;	/* resource_prices will do it */
	pass_sw = "1"b;
	do i = 1 to rate_structure.nrscp;
	     if rate_structure.resource (i).price >= 0 then do;
		pass_sw = "0"b;
		call ioa_ ("^3d)^2x^a", i, rate_structure.resource (i).name);
	     end;
	end;
	if pass_sw then call ioa_ ("no resources defined");
	return;

print (23):					/* rsctime */
	call ioa_ ("resource wait time: ^d sec.", installation_parms.rsc_timer_seconds);
	return;


print (24):					/* fpetime */
	call ioa_ ("fatal error loop time: ^d sec.", installation_parms.fatal_error_loop_seconds);
	return;


print (25):					/* fpecount */
	call ioa_ ("fatal error loop count: ^d", installation_parms.fatal_error_loop_count);
	return;

print (26):					/* trmrealtime */
	call ioa_ ("trm_ real time limit: ^d sec.", installation_parms.term_real_time_seconds);
	return;

print (27):					/* trmcputime */
	call ioa_ ("trm_ cpu time limit: ^d sec.", installation_parms.term_cpu_time_seconds);
	return;

print (28):					/* unload_on_detach */
	call ioa_ ("^a:^-^[on^;off^]", idt (28), installation_parms.rcp_init_flags.unload_on_detach);
	return;

print (29):					/* authentication_level */
	call ioa_ ("^a:^-^a", idt (29),
	     authentication_level_names (installation_parms.rcp_init_flags.authentication_level));
	return;

print (30):					/* default_pdir_seg_quota */
	call ioa_ ("^a:^-^d", idt (30), installation_parms.default_pdir_seg_quota);
	return;

print (56):					/* default_pdir_dir_quota */
	call ioa_ ("^a:^-^d", idt (56), installation_parms.default_pdir_dir_quota);
	return;

print (31):					/* rsc_mgmt_enabled */
	call ioa_ ("^a:^-^[on^;off^]", idt (31), installation_parms.rcp_init_flags.resource_mgmt_enabled);
	return;

print (32):					/* auto_registration */
	call ioa_ ("^a:^-^[on^;off^]", idt (32), installation_parms.rcp_init_flags.auto_registration);
	return;

print (33):					/* enable_ss_volume_mount */
						/* COMMENT OUT UNTIL rcp_init_flags.incl.pl1 is modified:
						   call ioa_ ("^a:^-^[on^;off^],idt(33),installation_parms.rcp_init_flags.enable_ss_volume_mount);
						   /* END COMMENT OUT */
	go to printed_nothing;

print (34):					/* foreground_queue_position */
	call print_halfword (idt (34), installation_parms.foreground_queue_position);
	return;

print (35):					/* idle_time_constant */
	call print_halfword (idt (35), installation_parms.idle_time_constant_seconds);
	return;

print (36):					/* sus_cpu_time */
	call ioa_ ("^a: ^d sec.", idt (36), installation_parms.sus_cpu_time_seconds);
	return;

print (37):					/* sus_real_time */
	call ioa_ ("^a: ^d sec.", idt (37), installation_parms.sus_real_time_seconds);
	return;

print (38):					/* max_abs */
	call print_sval (idt (38), installation_parms.max_abs);
	return;

print (39):					/* min_abs */
	call print_sval (idt (39), installation_parms.min_abs);
	return;

print (40):					/* pct_abs */
	call print_sval (idt (40), installation_parms.pct_abs);
	return;

print (41):					/* max_qres */
	call print_sqval (idt (41), installation_parms.max_qres);
	return;

print (42):					/* min_qres */
	call print_sqval (idt (42), installation_parms.min_qres);
	return;

print (43):					/* abs_cpu_default_limit */
	call print_sqval (idt (43), installation_parms.pct_qres);
	return;

print (44):					/* abs_cpu_max_limit */
	if all_abs_queue_sw then go to printed_nothing;
	mx = "1"b;
	tmx, dflt = ""b;
	go to print_abs_queue_parameters;

print (45):					/* abs_timax */
	if all_abs_queue_sw then go to printed_nothing;
	tmx = "1"b;
	mx, dflt = ""b;
	go to print_abs_queue_parameters;

print (46):					/* abs_cpu_default_limit */
	if all_abs_queue_sw then go to printed_nothing;
	dflt = "1"b;
	mx, tmx = ""b;
	go to print_abs_queue_parameters;

print_abs_queue_parameters:				/* Print lines of the following form:
						   Q TIMAX DEFAULT PER-SHIFT MAX CPU TIME LIMITS
						   -         LIMIT  0   1   2   3   4   5   6   7
						   1 timax    dflt mx0 mx1 mx2 mx3 mx4 mx5 mx6 mx7
						*/
	call ioa_ ("Q^[^xABS-TIMAX^]^[^xDEFAULT^]^[^xPER-SHIFT MAX CPU TIME LIMITS^]", tmx, dflt, mx);
	if (dflt | mx) then call ioa_ ("^x^[^10x^]^[^3xLIMIT^]^[^x^6x0^6x1^6x2^6x3^6x4^6x5^6x6^6x7^]", tmx, dflt, mx);
	do i = 1 to 4;
	     call ioa_ ("^d^[^x^9d^;^s^]^[^x^7d^;^s^]^[^x^8(^x^6d^)^]", i, tmx, installation_parms.abs_timax (i), dflt,
		installation_parms.abs_cpu_default_limit (i), mx, installation_parms.abs_cpu_max_limit (*, i));
	end;
	return;

print (47):					/* foreground_cpu_default_limit */
	call ioa_ ("foreground default cpu limit: ^d sec.", installation_parms.foreground_cpu_default_limit);
	return;

print (48):					/* abs_default_queue */
	call print_halfword (idt (48), installation_parms.default_absentee_queue);
	return;

print (49):					/* cwe_time */
	call ioa_ ("^a:^21t^d sec.", idt (49), installation_parms.chn_wakeup_error_loop_seconds);
	suppress_nl = "1"b;				/* tight output */
	return;

print (50):					/* cwe_count */
	call ioa_ ("^a:^21t^d", idt (50), installation_parms.chn_wakeup_error_loop_count);
	suppress_nl = "1"b;				/* tight output */
	return;

print (51):					/* rates */
	call ioa_ ("^/^-rate_structure ""^a""^/", ptr_rs_name (cur_rs_ptr));
	return;

print (52):					/* devices */
	k = 0;
	if ^all_rates_sw then call ask_$ask_n (devnm, k); /* look ahead on line for device name */
	if k ^= 0 then do;				/* if something is there */
	     m, n = devtab$$defined (devnm, SPECIAL_DEVICES_OK, COMPLAIN);
						/* find the device */
	     if m < 0 then go to print (52);		/* sorry, chum */
	     call ask_ ("", char8);			/* clear it off the input line */
	end;
	else do;
	     if ^check_device_names () then		/* check for missing ones, and if we complained about any */
		call ioa_ ("");			/* skip a line */
	     m = 1;
	     n = installation_parms.ndevices;
	end;

	do i = m to n;
	     call ioa_ ("device:^-^a", rate_structure.device_id (i));
	     no_charge = "1"b;			/* check for zero prices on all shifts */
	     do j = 0 to 7;
		if rate_structure.device_price (i, j) > 0.0e0 then do;
		     call ioa_ ("^-shift ^d ^15a/hr", j, cv_$mwvf (rate_structure.device_price (i, j)));
		     no_charge = ""b;		/* at least one shift has nonzero price */
		end;
	     end;
	     if no_charge then call ioa_ ("^2-^7xno charge");
	end;
	return;

print (53):					/* resources */
	k = 0;
	if ^all_rates_sw then call ask_$ask_n (rscnm, k); /* look ahead for a resource name */
	if k ^= 0 then do;				/* if something is there */
	     j, k = rsctab$$defined (rscnm, COMPLAIN);	/* find the resource */
	     if j < 0 then go to print (53);
	     call ask_ ("", char32);			/* it was; remove it from the input line */
	end;
	else do;
	     j = 1;				/* print them all */
	     k = rate_structure.nrscp;
	end;

	pass_sw = "1"b;
	do i = j to k;
	     if rate_structure.resource (i).price >= 0 then do;
		c15 = cv_$mwvf (rate_structure.resource (i).price);
						/* format price */
		if length (ltrim (c15)) < 8 then
		     c15 = substr (c15, 8, 8);	/* right-adjust price in 8 column field */
		else c15 = ltrim (c15);		/* but don't throw away any nonblanks */
		if pass_sw then do;
		     pass_sw = "0"b;
		     call ioa_ ("^3xPRICE^xNAME");
		end;
		call ioa_ ("^8a^x^a", c15, rate_structure.resource (i).name);
	     end;
	end;
	if pass_sw then call ioa_ ("no resources defined");
	return;

print (54):					/* rate_structure_name */
	call ioa_ ("Rate_structure names:");
	do i = 0 to installation_parms.nrates;
	     call ioa_ ("^-^a ^[ (current rate_structure)^]", installation_parms.rate_structures (i),
		(cur_rs_ptr = rs_ptrs (i)));
	end;
	return;

print (55):					/* all_structures */
	go to printed_nothing;

printed_nothing:
	did_something = "0"b;
	return;

cant_print:
	call ioa_ ("""^a ^a"" is not allowed.", print_comm, idt (IX));
	go to main1;

cant_print_rs:
	call ioa_ ("""^a ^a"" is not allowed while editing a rate_structure.", print_comm, idt (IX));
	go to main1;

     end do_print;
%page;

/* PROCESS SINGLE RETYPE REQUEST */

do_retype:
     procedure (IX);

dcl  IX fixed bin;

dcl  (i, j, k, n) fixed bin;
dcl  c1 char (1);
dcl  category_set bit (36) aligned;
dcl  rscnm char (32);
dcl  devnm char (8);
dcl  yn char (4);

	if IX < lbound (retype, 1) | IX > hbound (retype, 1) then do;
	     call com_err_ (0, me, "Internal error. do_retype index ^d.", IX);
	     return;
	end;

	go to retype (IX);

retype (1):					/* all */
	call ioa_ ("^/Retype installation_parms");
	return;

retype (2):					/* installation_id */
	call ask_$ask_line ("Installation id^-", installation_parms.installation_id);
	return;

retype (3):					/* shift_table */
	call ask_ ("standard shifts?^-", c1);
	if c1 = "y" then do;
	     call set_std_shifttab;
	end;
	else do;
	     call ioa_ ("Each digit specifies the shift for that half-hour. Shifts may be 0-7");
	     do i = 0 to 6;
		do j = 0 to 23;
		     do n = 0 to 1;
badshf:
			call ask_$ask_int ("^a ^2d^2d^-", k, substr (daynam, i * 3 + 1, 3), j, 30 * n);
			if k > 7 | k < 0 then do;
			     call ioa_ ("Shifts must be 0-7");
			     call ask_$ask_clr ();
			     go to badshf;
			end;
			call set_shift_field (i, j, k, n);
		     end;
		end;
	     end;
	end;
	return;

retype (4):					/* prices */
	call get_disk_price (rate_structure.disk_price);
	call ask_$ask_flo ("registration^-", rate_structure.registration_price);
	call ask_$ask_yn ("Do you want to retype CPU, log, mem and io ops prices^-", yn);
	if yn ^= "yes" then return;
	call ioa_ ("Input CPU, log, mem, io ops prices for each shift from 0 to 7");
	do i = 0 to 7;
	     call ask_$ask_flo ("CPU ^d^-", rate_structure.cpu_price (i), i);
	     call ask_$ask_flo ("log ^d^-", rate_structure.log_base_price (i), i);
	     call ask_$ask_flo ("mem ^d^-", rate_structure.core_price (i), i);
	     call ask_$ask_flo ("io ops ^d^-", rate_structure.io_ops_price (i), i);
	end;
	return;

retype (5):					/* titles */
	call ask_$ask_line ("company^-^-", installation_parms.company);
	call ask_$ask_line ("department^-", installation_parms.department);
	call ask_$ask_line ("company (ds)^-", installation_parms.companyds);
	call ask_$ask_line ("department (ds)^-", installation_parms.departmentds);
	return;

retype (6):					/* level_names */
	call ioa_ ("Enter names for ^d security levels.", dimension (installation_parms.level_names (*), 1));

	do i = lbound (installation_parms.level_names (*), 1) to hbound (installation_parms.level_names (*), 1);
	     call enter_level_name (i);
	end;

	return;

retype (7):					/* inactive_time */
	call set_half_al (idt (7), "seconds", installation_parms.inactive_time, 0, NOLIMIT);
	return;

retype (58):					/* inactive_time */
	call set_half_al (idt (58), "seconds", installation_parms.operator_inactive_time, 0, NOLIMIT);
	return;

retype (8):					/* warning_time */
	call set_half_al (idt (8), "seconds", installation_parms.warning_time, 0, NOLIMIT);
	return;

retype (9):					/* login_time */
	call set_half_al (idt (9), "seconds", installation_parms.login_time, 0, NOLIMIT);
	return;

retype (10):					/* tries */
	call set_half_al (idt (10), "", installation_parms.login_tries, 1, NOLIMIT);
	return;

retype (11):					/* update_time */
	call set_half_al ("acct update", "seconds", installation_parms.acct_update, 0, NOLIMIT);
	return;

retype (12):					/* device_prices */
	call ioa_ ("Enter device prices for all shifts");
	do i = 1 to rate_structure.ndevices;
	     call input_device_price (i, (installation_parms.devtab (i).device_id), THIS_RS, NO_SET_HI);
	end;
	return;

retype (13):					/* config_table */
	call ioa_ ("Enter config table");
	do i = 1 to hbound (installation_parms.cona, 1);
	     call input_config_element (i);
	     installation_parms.ncon = i - 1;
	     if installation_parms.cona.cpu (i) = 0 then do;
		call check_config_table;
		return;
	     end;
	end;
	call ioa_ ("config table full");
	call ask_$ask_clr ();
	return;

retype (14):					/* queue_prices */
	call ioa_ ("Enter queue prices");
	do i = 1 to 4;
	     call ask_$ask_flo ("abs CPU ^d^-", rate_structure.abs_cpu_price (i), i);
	     call ask_$ask_flo ("abs mem ^d^-", rate_structure.abs_mem_price (i), i);
	     call ask_$ask_flo ("iod records ^d^-", rate_structure.iod_rec_price (i), i);
	end;
	return;

retype (15):					/* abs_queue_parameters */
	call ioa_ ("Enter abs timax (microseconds) and default and max limits (seconds) for queues 1-4");
	return;

retype (16):					/* category_names */
	call ioa_ ("Enter names for ^d security categories.", dimension (installation_parms.category_names (*), 1));
	do i = lbound (installation_parms.category_names (*), 1) to hbound (installation_parms.category_names (*), 1);
	     call enter_category_name (i);
	end;
	return;

retype (17):					/* access_ceiling */
	call set_half_al ("Maximum sensitivity level", "", i, lbound (installation_parms.level_names, 1),
	     hbound (installation_parms.level_names, 1));

retype_category_set:
	category_set = ""b;
	n = divide (dimension (installation_parms.category_names (*), 1), 3, 17, 0);
	call ask_$ask_line ("Categories in use: (^d octal digits) ", char48, n);
	if verify (substr (char48, 1, n), "01234567") ^= 0 then do;
	     call ioa_ ("Must be ^d octal digits. Retype it.", n);
	     call ask_$ask_clr ();
	     go to retype_category_set;
	end;

	do j = 1 to n;
	     substr (category_set, 3 * j - 2, 3) = bit (fixed (index ("01234567", substr (char48, j, 1)) - 1, 3), 3);
	end;

	addr (installation_parms.access_authorization_ceiling) -> aim_template.level = i;
	addr (installation_parms.access_authorization_ceiling) -> aim_template.categories = category_set;
	string (addr (installation_parms.access_authorization_ceiling) -> aim_template.privileges) = ""b;
	return;

retype (18):					/* log_parameters */
	call ask_$ask_int ("syserr log copying threshold:^-", i);
	if i > 256 | i < -1 then do;
	     call ioa_ ("Threshold must be:  -1 (disable log copying)^/^20x0 (use built-in default)");
	     call ioa_ ("^16x1-256 (max size of log in pages before copying begins)^/Please retype.");
	     call ask_$ask_clr ();
	     go to retype (18);
	end;
	installation_parms.syserr_log_copy_threshold = i;
	return;

retype (19):					/* strict_trusted_path */
	call ask_$ask_yn ("trusted path login:^-", yn);
	installation_parms.trusted_path_login = (yn = "yes");
	return;

retype (57):					/* require_operator_login */
	call ask_$ask_yn ("require operator login:^-", yn);
	installation_parms.require_operator_login = (yn = "yes");
	return;

retype (59):					/* validate_daemon_commands */
	call ask_$ask_yn ("validate daemon commands:^-", yn);
	installation_parms.validate_daemon_commands = (yn = "yes");
	return;

retype (60):					/* password_min_length */
	call set_half_al (idt (60), "", installation_parms.password_min_length,
	     0, 8);
	return;
retype (61):					/* password_gpw_length */
	call set_half_al (idt (61), "", installation_parms.password_gpw_length,
	     1, 8);
	return;
retype (62):					/* password_change_interval */
	call ask_$ask_int ("Password Change Interval (in days):^-", i);
	if i < 0 then do;
	     call ioa_ ("Password Change Interval must be greater than zero.");
	     goto retype (62);
	end;
	installation_parms.password_change_interval = i;
	return;
retype (63):					/* password_expiration_interval */
	call ask_$ask_int ("Password Expiration Interval (in days):^-", i);
	if i < 0 then do;
	     call ioa_ ("Password Expiration Interval must be greater than zero.");
	     goto retype (62);
	end;
	installation_parms.password_expiration_interval = i;
	return;
retype (64):
	call ask_$ask_yn ("vchn_requires_accept:^-", yn);
	installation_parms.vchn_requires_accept = (yn = "yes");
	return;
retype (20):					/* devname */
	go to cant_retype_must_change;

retype (21):					/* resource_prices */
	call ioa_ ("Enter resource prices");
	do i = 1 to rate_structure.nrscp;
	     if rate_structure.resource (i).price >= 0e0 then
						/* not a rate structure */
		call input_resource_price (i, (installation_parms.resource (i).name), THIS_RS, NO_SET_HI);
	end;
	return;

retype (22):					/* rscname */
	go to cant_retype_must_change;

retype (23):					/* resource_wait_time */
	call set_halfword ("resource wait time", "seconds", installation_parms.rsc_timer_seconds, 0, NOLIMIT);
	return;

retype (24):					/* fpe_time */
	call set_halfword ("fatal process error loop time", "seconds", installation_parms.fatal_error_loop_seconds, 0,
	     NOLIMIT);
	return;

retype (25):					/* fpe_count */
	call set_halfword ("fatal process error loop count", "", installation_parms.fatal_error_loop_count, 0, NOLIMIT);
	return;

retype (26):					/* trm_real_time */
	call set_halfword ("trm_ real time limit", "seconds", installation_parms.term_real_time_seconds, 0, NOLIMIT);
	return;

retype (27):					/* trm_cpu_time */
	call set_halfword ("trm_ cpu time limit", "seconds", installation_parms.term_cpu_time_seconds, 0, NOLIMIT);
	return;

retype (28):					/* unload_on_detach */
	installation_parms.rcp_init_flags.unload_on_detach = ask_on_off (idt (keywx));
	return;

retype (29):					/* authentication_level */
	installation_parms.rcp_init_flags.authentication_level = enter_authentication_level ();
	return;

retype (30):					/* default_pdir_seg_quota */
	call set_halfword ("default pdir segment quota", "records", installation_parms.default_pdir_seg_quota, 100, NOLIMIT);
	return;

retype (56):					/* default_pdir_dir_quota */
	call set_halfword ("default pdir directory quota", "records", installation_parms.default_pdir_dir_quota, 100, NOLIMIT);
	return;

retype (31):					/* rsc_mgmt_enabled */
	installation_parms.rcp_init_flags.resource_mgmt_enabled = ask_on_off (idt (31));
	return;

retype (32):					/* auto_registration */
	installation_parms.rcp_init_flags.auto_registration = ask_on_off (idt (32));
	return;

retype (33):					/* enable_ss_volume_mount */
	go to retyped_nothing;

retype (34):					/* foreground_queue_position */
	call set_halfword (idt (34), "", installation_parms.foreground_queue_position, 0, 4);
	return;


retype (35):					/* idle_time_constant */
	call set_halfword (idt (35), "seconds", installation_parms.idle_time_constant_seconds, 60, 1800);
	return;


retype (36):					/* sus_cpu_time */
	call set_halfword (idt (36), "seconds", installation_parms.sus_cpu_time_seconds, 1, NOLIMIT);
	return;


retype (37):					/* sus_real_time */
	call set_halfword (idt (37), "seconds", installation_parms.sus_real_time_seconds, 30, NOLIMIT);
	return;


retype (38):					/* max_abs */
	call set_sval (idt (38), installation_parms.max_abs, -1, NOLIMIT);
	return;

retype (39):					/* min_abs */
	call set_sval (idt (39), installation_parms.min_abs, 0, NOLIMIT);
	return;

retype (40):					/* pct_abs */
	call set_sval (idt (40), installation_parms.pct_abs, 0, 100);
	return;

retype (41):					/* max_qres */
	call set_sqval (idt (41), installation_parms.max_qres, 0, NOLIMIT);
	return;

retype (42):					/* min_qres */
	call set_sqval (idt (42), installation_parms.min_qres, 0, NOLIMIT);
	return;

retype (43):					/* pct_qres */
	call set_sqval (idt (43), installation_parms.pct_qres, 0, 100);
	return;

retype (44):					/* abs_cpu_max_limit */
	call set_sqlval (idt (44), installation_parms.abs_cpu_max_limit, 0, NOLIMIT);
	call check_abs_cpu_limit;
	return;

retype (45):					/* abs_timax */
	call set_qval (idt (45), installation_parms.abs_timax, 1000000, NOLIMIT);
	return;

retype (46):					/* abs_cpu_default_limit */
	call set_qval (idt (46), installation_parms.abs_cpu_default_limit, 0, NOLIMIT);
	call check_abs_cpu_limit;
	return;

retype (47):					/* foregound_cpu_default_limit */
	call set_word (idt (47), "seconds", installation_parms.foreground_cpu_default_limit, 0, NOLIMIT);
	return;


retype (48):					/* abs_default_queue */
	call set_halfword (idt (48), "", installation_parms.default_absentee_queue, 1, 4);
	return;


retype (49):					/* cwe_time */
	call set_halfword ("channel wakeup error loop time", "seconds",
	     installation_parms.chn_wakeup_error_loop_seconds, 0, NOLIMIT);
	return;

retype (50):					/* cwe_count */
	call set_halfword ("channel wakeup error loop count", "", installation_parms.chn_wakeup_error_loop_count, 0,
	     NOLIMIT);
	return;


retype (51):					/* rates */
	call ioa_ ("^/Retype rate_structure ^a", ptr_rs_name (cur_rs_ptr));
	return;

retype (52):					/* devices */
	if edit_rs then go to cant_retype_rs;
	call ioa_ ("Warning: this operation changes the positions of devices in device table;");
	call ioa_ ("it should only be done in a special session just after billing has been run.");
	call ask_$ask_yn ("Do you wish to proceed?  ", char8);
	if char8 ^= "yes" then go to main1;
	call ioa_ ("Enter device prices.");
	do i = 1 to hbound (installation_parms.devtab, 1);
	     if i <= hbound (dev_id, 1) then
		devnm = dev_id (i);
	     else do;
deviclp:
		call ask_ ("Enter device id or ""x"" to exit^-", devnm);
		if devnm = "x" then return;
		j = devtab$$undefined (devnm, NO_SPECIAL_DEVICES, COMPLAIN);
						/* unique device name? */
		if j >= 0 then go to deviclp;		/* no - try again */
	     end;
	     call input_device_price (i, devnm, ALL_RS, SET_HI);
	end;
	call ioa_ ("Device table full");
	call ask_$ask_clr ();
	return;

retype (53):					/* resources */
	if edit_rs then go to cant_retype_rs;
	call ioa_ ("Warning: retyping the resource price list might make other system tables invalid.");
	call ask_$ask_yn ("Do you want to retype the resource price list?^-", char8);
	if char8 = "no" then return;
	call ioa_ ("Enter resource names and prices, or ""x"" to exit.");
	i = 0;
rt53a:
	call ask_ ("resource:^-", rscnm);
	if rscnm = "x" then return;
	j = rsctab$$undefined (rscnm, COMPLAIN);	/* unique resource name */
	if j < 0 then do;				/* nope */
	     i = i + 1;
	     call input_resource_price (i, rscnm, ALL_RS, SET_HI);
	end;
	go to rt53a;

retype (54):					/* rate_structure_name */
	go to cant_retype_must_change;

retype (55):					/* all_structures */
	if edit_rs then go to cant_retype_rs;
	go to retyped_nothing;

retyped_nothing:
	did_something = "0"b;
	return;

cant_retype_must_change:
	call ioa_ ("cannot retype ^a; use change", idt (keywx));
	go to main1;

cant_retype:
	call ioa_ ("""^a ^a"" is not allowed.", print_comm, idt (IX));
	go to main1;

cant_retype_rs:
	call ioa_ ("""^a ^a"" is not allowed while editing a rate_structure.", print_comm, idt (IX));
	go to main1;

     end do_retype;
%page;

/* ------------------------------ */

ask_on_off:
     procedure (name) returns (bit (1) aligned);

dcl  name char (*);

	call ask_ ("^a:^-", char8, name);
	do while ("1"b);
	     if char8 = "yes" | char8 = "on" then return ("1"b);
	     else if char8 = "no" | char8 = "off" then return (""b);
	     else do;
		call ask_$ask_clr ();
		call ask_ ("Please answer ""yes"", ""no"", ""on"", or ""off""; ^a: ^x", char8, name);
	     end;
	end;

     end ask_on_off;

/* ------------------------------ */

check_abs_cpu_limit:				/* make sure each default is OK */
     procedure;

dcl  (qok, qbad) (4) bit (1) aligned init ((4) (1)""b);
dcl  nbad fixed bin init (0);
dcl  (s, q) fixed bin;

	do q = 1 to 4;
	     do s = 0 to 7;
		if installation_parms.abs_cpu_default_limit (q) <= installation_parms.abs_cpu_max_limit (s, q) then
		     qok (q) = "1"b;
	     end;
	     if ^qok (q) then do;
		qbad (q) = "1"b;
		nbad = nbad + 1;
	     end;
	end;

	if nbad > 0 then do;
	     call ioa_ ("Warning: the default limit is higher than the max limit");
	     call ioa_ ("on all shifts, for queue^[s^]^[^x1^]^[^x2^]^[^x3^]^[^x4^].", (nbad > 1), qbad);
	     call ioa_ ("If you don't change one of them, jobs using the default will never log in.");
	end;

	return;

     end check_abs_cpu_limit;

/* ------------------------------ */

check_device_names:
     procedure returns (bit (1) aligned);

dcl  (i, j) fixed bin;

	do i = 1 to hbound (dev_id, 1);		/* for each required device name */
	     do j = 1 to rate_structure.ndevices while (dev_id (i) ^= rate_structure.device_id (j));
	     end;
	     if j > rate_structure.ndevices then
		call ioa_ ("Warning: device ""^a"" not in device table. It should be added.", dev_id (i));
	end;
	return ("0"b);

     end check_device_names;

/* ------------------------------ */

checkid:
     procedure (xid, loud_sw) returns (fixed bin (17));

dcl  xid char (*);
dcl  loud_sw bit (1) aligned;

dcl  ib fixed bin;
dcl  i fixed bin;
dcl  keywx fixed bin;

	do ib = 1 to hbound (keyw, 1);
	     if xid = keyw (ib) then do;
		keywx = keyn (ib);			/* key number */
		if edit_rs then do;			/* not valid for rate_structures? */
		     do i = 1 to hbound (valid_for_rs, 1) while (valid_for_rs (i) < keywx);
		     end;
		     if valid_for_rs (i) > keywx then do;
			if loud_sw then do;
			     call ioa_ ("The identifier ""^a"" is not valid while editing a rate_structure.",
				idt (keywx));
			     call ask_$ask_clr ();
			end;
			return (NOT_RS_ID);
		     end;
		end;
		return (keywx);
	     end;
	end;
	if loud_sw then do;
	     call ioa_ ("illegal change id ""^a"". Type help for instructions.", xid);
	     call ask_$ask_clr ();
	end;
	return (ID_NOT_FOUND);

     end checkid;

/* ------------------------------ */

check_config_table:
     procedure;

dcl  (this_ord, highest_ord) fixed bin (71);
dcl  i fixed bin;
dcl  (bad_dup, bad_null, bad_order) bit (1) aligned;

	bad_dup, bad_null, bad_order = ""b;
	highest_ord = -2;

	do i = 1 to installation_parms.ncon;
	     this_ord =
		gen_config_ordinal ((installation_parms.cona (i).cpu), (installation_parms.cona (i).kmem),
		(installation_parms.cona (i).kbulk), (installation_parms.cona (i).shift));
	     if this_ord = -1 then bad_null = "1"b;
	     else if this_ord < highest_ord then bad_order = "1"b;
	     else if this_ord = highest_ord then bad_dup = "1"b;
	     else highest_ord = this_ord;
	end;
	if bad_dup | bad_null | bad_order then do;
	     call ioa_ ("Config table error(s).^[ Duplicate entires.^]^[ Null entries.^]^[ Entries out of order.^]",
		bad_dup, bad_null, bad_order);
	     call sort_config_table;
	end;

     end check_config_table;

/* ------------------------------ */

clean_up:
     procedure;
dcl  i fixed bin;

	if ip = null then return;			/* no segments active */
	do i = hbound (rs_ptrs, 1) to 0 by -1;		/* do installation_parms & copy last */
	     if rs_ptrs (i) ^= null then do;		/* working copy? */
		call hcs_$delentry_seg (rs_ptrs (i), ec);
						/* delete it */
		rs_ptrs (i) = null;			/* remember it's gone */
	     end;
	     if rs_ptrs1 (i) ^= null then do;		/* real segment? */
		call terminate_file_ (rs_ptrs1 (i), (0), TERM_FILE_TERM, ec);
						/* get rid of it */
		rs_ptrs1 (i) = null;		/* forget it */
	     end;
	end;
     end clean_up;

/* ------------------------------ */

devtab$$defined:					/* search devtab */
     procedure (devnm, any_sw, loud_sw) returns (fixed bin);

dcl  devnm char (*);
dcl  any_sw bit (1) aligned;
dcl  loud_sw bit (1) aligned;

dcl  i fixed bin;
dcl  j fixed bin;
dcl  should_find bit (1) aligned;

	should_find = "1"b;				/* we WANT to find it */
	go to devtab_common;

devtab$$undefined:					/* search devtab */
     entry (devnm, any_sw, loud_sw) returns (fixed bin (17));

	should_find = "0"b;				/* don't want to find it */

devtab_common:
	do i = 1 to installation_parms.ndevices;	/* whole devtab */
	     if installation_parms.devtab (i).device_id = devnm then do;
						/* what we're checking for? */
		if should_find then			/* did we want to find it? */
		     if any_sw ^= SPECIAL_DEVICES_OK then do;
						/* have to check for special */
			do j = 1 to hbound (dev_id, 1);
						/* see if special name */
			     if devnm = dev_id (j) then do;
						/* yes, it's special */
				if loud_sw then do; /* complain? */
				     call ioa_ ("""^a"" is a reserved device name.", devnm);
				     call ask_$ask_clr ();
						/* clean up */
				end;
				return (-1);	/* indicate we're unhappy */
			     end;			/* found a special name */
			end;			/* loop to check for special */
		     end;				/* have to check for special */
		if ^should_find & loud_sw then do;	/* shouldn't have found it */
		     call ioa_ ("Device ""^a"" is already defined.", devnm);
		     call ask_$ask_clr ();
		end;
		return (i);
	     end;
	end;
	if should_find & loud_sw then do;		/* should have found it, but we didn't */
	     call ioa_ ("Device ""^a"" is not defined.", devnm);
	     call ask_$ask_clr ();
	end;
	return (-1);
     end devtab$$defined;

/* ------------------------------ */

enter_authentication_level:
     procedure returns (fixed bin);

dcl  i fixed bin,
     ans char (32);

get_again:
	call ask_$ask_line ("Authentication level: ", ans);

	do i = lbound (authentication_level_names, 1) to hbound (authentication_level_names, 1);
	     if (authentication_level_names (i) = ans) then return (i);
	end;

	call ioa_ ("Authentication level must be ^v(^a, ^) or ^a. Reenter level.",
	     dim (authentication_level_names, 1) - 1, authentication_level_names (*));
	call ask_$ask_clr ();
	go to get_again;

     end enter_authentication_level;

/* ------------------------------ */

enter_category_name:
     procedure (i);

dcl  i fixed bin;

dcl  name char (32);
dcl  short_name char (8);

	installation_parms.category_names (i) = "";	/* null out so invalid_name doesn't find a duplicate. */
	installation_parms.short_category_names (i) = "";

change_this_name:
	call ask_$ask_line ("Category ^d: ", name, i);
	if name = "." then do;
reenter_name:
	     call ioa_ ("No categories may be unnamed. Reenter name.");
	     call ask_$ask_clr ();
	     go to change_this_name;
	end;

	call ask_$ask_line (" (short name) Category ^d: ", short_name, i);
	if short_name = "." then go to reenter_name;

	if invalid_name (name, length (installation_parms.category_names (1)), "1"b) then go to change_this_name;

	if invalid_name (short_name, length (installation_parms.short_category_names (1)), "0"b) then
	     go to change_this_name;

	installation_parms.category_names (i) = name;
	installation_parms.short_category_names (i) = short_name;

     end enter_category_name;

/* ------------------------------ */

enter_level_name:
     procedure (i);

dcl  i fixed bin;

dcl  name char (32);
dcl  short_name char (8);

	installation_parms.level_names (i) = "";	/* null out so invalid_name doesn't find a duplicate. */
	installation_parms.short_level_names (i) = "";

change_this_name:
	call ask_$ask_line ("Level ^d: ", name, i);
	if name = "." then
	     if i = 0 then
		name = "";
	     else do;
reenter_name:
		call ioa_ ("Only level 0 may be unnamed. Reenter name.");
		call ask_$ask_clr ();
		go to change_this_name;
	     end;

	call ask_$ask_line (" (short name) Level ^d: ", short_name, i);
	if short_name = "." then
	     if i = 0 then
		short_name = "";
	     else go to reenter_name;

	if invalid_name (name, length (installation_parms.level_names (0)), "1"b) then go to change_this_name;

	if invalid_name (short_name, length (installation_parms.short_level_names (0)), "0"b) then
	     go to change_this_name;

	installation_parms.level_names (i) = name;
	installation_parms.short_level_names (i) = short_name;
	return;

     end enter_level_name;

/* ------------------------------ */

gen_config_ordinal:					/* make a number which describes NCPU, NMEM, NBULK and SHIFT */
						/* of a config-table entry */
     procedure (ncpu, nmem, nbulk, shift) returns (fixed bin (71));

dcl  (ncpu, nmem, nbulk, shift) fixed bin;

	if ncpu < 0 | nmem < 0 | nbulk < 0 | shift < 0 then
						/* something naughty? */
	     return (-1);
	else return ((((ncpu * 100000 + nmem) * 100000) + nbulk) * 10 + shift);

     end gen_config_ordinal;

/* ------------------------------ */

get_disk_price:
     procedure (price);

dcl  price float bin (27);

dcl  char32 char (32);
dcl  f float bin (27);
dcl  i fixed bin;

	call ask_$ask_n (char32, i);
	if i = 0 then				/* no typeahead */
	     call ioa_ ("enter disk price as 'N' (page-second) or 'N/month' (page-30-days)");
	do while ("1"b);				/* keep going until user gets it right */
	     call ask_ ("disk price^-", char32);
	     if index (char32, "/mo") ^= 0 then do;	/* per-30-day month */
		call cv_float_ (rtrim (before (char32, "/mo")), ec, f);
		if ec = 0 then do;
		     price = f / SECONDS_PER_MONTH;	/* units are page-seconds */
		     return;
		end;
	     end;
	     else do;				/* per second */
		call cv_float_ (rtrim (char32), ec, f);
		if ec = 0 then do;
		     price = f;
		     return;
		end;
	     end;
	     call ask_$ask_clr ();			/* error in floating point number */
	end;
     end get_disk_price;

/* ------------------------------ */

get_nums:
     procedure (prompt, n1, n2);

dcl  prompt char (*);
dcl  (n1, n2) fixed bin;
dcl  ia fixed bin;

ask_for_nums:
	call ask_ ("^a", char32, prompt);
	if verify (rtrim (char32), "0123456789-") ^= 0 then do;
bad_nums:
	     call ask_$ask_clr ();
	     call ioa_ ("""^a"" invalid. Give one number or two joined by a hyphen.", char32);
	     go to ask_for_nums;
	end;

	ia = index (char32, "-");
	if ia = 0 then
	     n1, n2 = cv_dec_ (char32);		/* we already checked */
	else do;
	     if ia = 1				/* if leading hyphen */
		| substr (char32, ia + 1) = ""	/* or trailing hyphen */
		| index (substr (char32, ia + 1), "-") ^= 0
						/* or more than one hyphen */
	     then go to bad_nums;			/* go complain */
	     n1 = cv_dec_ ((substr (char32, 1, ia - 1)));
	     n2 = cv_dec_ ((substr (char32, ia + 1)));
	end;

	return;

     end get_nums;

/* ------------------------------ */

get_shift_queue:
     procedure (q_lo, q_hi, s_lo, s_hi);		/* Checks for typed-ahead shift and queue numbers;
						   returns first and last shift in s_lo and s_hi;
						   s_lo = -1 if no shift typed ahead;
						   same for q_lo and q_hi for queues. */

dcl  (q_lo, q_hi, s_lo, s_hi) fixed bin;

dcl  (get_shift, get_queue) bit (1) aligned init (""b);
dcl  x fixed bin;

/* Main entry point - get both shift and queue */

	get_shift, get_queue = "1"b;
	s_lo, q_lo = -1;				/* we haven't gotten either one, yet */

gsq_common:					/* come here from get_shift or get_queue */
	call ask_$ask_n (char32, x);
	if x = 0 then return;			/* if nothing typed ahead */
	if get_shift & char32 = "shift" then do;
	     call ask_ ("", char32);			/* clear it from the line */
	     call get_nums ("shift(s)", s_lo, s_hi);	/* get "s" or "s1-s2" */
	     get_shift = ""b;			/* we have gotten it */
	end;
	else if get_queue & char32 = "queue" then do;
	     call ask_ ("", char32);
	     call get_nums ("queue(s)", q_lo, q_hi);
	     get_queue = ""b;
	end;
	else return;				/* if we wanted both, go back for the other one */
	if get_shift | get_queue then go to gsq_common;
	return;

get_shift:
     entry (s_lo, s_hi);

	s_lo = -1;
	get_shift = "1"b;
	go to gsq_common;

get_queue:
     entry (q_lo, q_hi);

	q_lo = -1;
	get_queue = "1"b;
	go to gsq_common;

     end get_shift_queue;

/* ------------------------------ */

idt:
     procedure (n) returns (char (32));			/* returns primary keyword, given key number */

dcl  n fixed bin;
dcl  ia fixed bin;

	do ia = 1 to hbound (keyn, 1);
	     if keyn (ia) = n then return (keyw (ia));
	end;
	call com_err_ (0, me, "Internal error in ""idt"" function.");
	return ("UNKNOWN!");

     end idt;

/* ------------------------------ */

input_config_element:
     procedure (i);
dcl  i fixed bin;

dcl  j fixed bin;
dcl  ftmp float bin;
	call set_half_al ("ncpu", "", j, -1, 8);
	installation_parms.cona.cpu (i) = j;
	if j <= 0 then return;
	call set_half_al ("mem", "Kwords", j, 0, NOLIMIT);
	installation_parms.cona.kmem (i) = j;
	call set_half_al ("bulk", "Kwords", j, 0, NOLIMIT);
	installation_parms.cona.kbulk (i) = j;
	call set_half_al ("shift", "", j, 0, 7);
	installation_parms.cona.shift (i) = j;
	call ask_$ask_flo ("min   ", ftmp);
	installation_parms.cona.response_low (i) = ftmp * 1e1;
	call ask_$ask_flo ("max   ", ftmp);
	installation_parms.cona.response_high (i) = ftmp * 1e1;
	call ask_$ask_flo ("base  ", ftmp);
	installation_parms.cona.maxu_base (i) = ftmp * 1e1;
	call set_half_al ("absu", "", j, 0, NOLIMIT);
	installation_parms.cona.maxa (i) = j;
	call set_half_al ("absq", "", j, 1, 4);
	installation_parms.cona.maxq (i) = j;
	installation_parms.cona.x1 (i) = 0;
	installation_parms.cona.x2 (i) = 0;
	installation_parms.cona.x3 (i) = 0;

     end input_config_element;

/* ------------------------------ */

input_device_price:
     procedure (devx, devnm, all_sw, set_hi);

dcl  devx fixed bin;
dcl  devnm char (*);
dcl  all_sw bit (1) aligned;
dcl  set_hi bit (1) aligned;

dcl  rsp ptr;
dcl  i fixed bin;
dcl  s fixed bin;
dcl  (hi, lo) fixed bin;
dcl  save_crit bit (1) aligned;

/* maybe allow copy or zero? */

	save_crit = critical_op;
	critical_op = critical_op | (all_sw = ALL_RS);
	if all_sw = ALL_RS then do;			/* one, or all RS? */
	     hi = installation_parms.nrates;
	     lo = 0;
	end;
	else hi, lo = rate_structure.rate_structure_number;

	do i = lo to hi;				/* run the gamut */
	     rsp = rs_ptrs (i);			/* which RS now? */
	     if all_sw = ALL_RS & installation_parms.nrates > 0 then
						/* tell user which one, if more than one */
		call ioa_ ("rate_structure ""^a""", ptr_rs_name (rsp));
	     rsp -> rate_structure.device_id (devx) = devnm;
	     do s = 0 to 7;				/* get price for each shift */
		call ask_$ask_flo ("^a shift ^d^-", rsp -> rate_structure.device_price (devx, s), devnm, s);
	     end;
	end;

	if set_hi = SET_HI then			/* do installation_parms last */
	     do i = hi to lo by -1;			/* set number of devices */
	     rs_ptrs (i) -> rate_structure.ndevices = devx;
	end;
	critical_op = save_crit;			/* restore old critical indicator */
     end input_device_price;

/* ------------------------------ */

input_resource_price:
     procedure (rscx, rscnm, all_sw, set_hi);

dcl  rscx fixed bin;
dcl  rscnm char (*);
dcl  all_sw bit (1) aligned;
dcl  set_hi bit (1) aligned;

dcl  f float bin (27);
dcl  i fixed bin;
dcl  rsp ptr;
dcl  (hi, lo) fixed bin;
dcl  save_crit bit (1) aligned;

	save_crit = critical_op;
	critical_op = critical_op | (all_sw = ALL_RS);
	if all_sw = ALL_RS then do;			/* which RS? */
	     hi = installation_parms.nrates;
	     lo = 0;
	end;
	else hi, lo = rate_structure.rate_structure_number;

	do i = lo to hi;				/* for each appropriate RS */
	     rsp = rs_ptrs (i);			/* point to RS */
	     if all_sw = ALL_RS & installation_parms.nrates > 0 then
						/* more than one - tell user which */
		call ioa_ ("rate_structure ""^a""", ptr_rs_name (rsp));
	     call ask_$ask_flo ("Price of ^a:^-", f, rscnm);
						/* price, please */
	     rsp -> rate_structure.resource (rscx).price = f;
	     rsp -> rate_structure.resource (rscx).name = rscnm;
	end;

	if set_hi then				/* do installation_parms last */
	     do i = hi to lo by -1;			/* set number of resources */
	     rs_ptrs (i) -> rate_structure.nrscp = rscx;
	end;

	critical_op = save_crit;			/* restore saved indicator */
	return;

     end input_resource_price;

/* ------------------------------ */

invalid_name:					/* check level and category names for duplicates, valid chars, etc. */
     procedure (bv_name, bv_max_len, blank_ok) returns (bit (1) aligned);

/* parameters */

declare  bv_name char (*);
declare  bv_max_len fixed bin;
declare  blank_ok bit (1) aligned;

/* automatic */

declare  i fixed bin;

/* program */

	if bv_name = "" then return ("0"b);		/* null names are always ok */

	if bv_name = "system_low" | bv_name = "system_high" then do;
	     call ioa_ ("The keyword ^a is not allowed as a level or category name. Reenter both names.", bv_name);
	     go to invalid;
	end;

	i = length (bv_name) - verify (reverse (bv_name), " ") + 1;

	if i > bv_max_len then do;
	     call ioa_ ("Name ^a is longer than allowed maximum of ^d characters. Reenter both names.", bv_name,
		bv_max_len);
	     go to invalid;
	end;

	if verify (substr (bv_name, 1, i), " '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ^_`abcdefghijklmnopqrstuvwxyz~") ^= 0
	then do;
	     call ioa_ ("Name ^a contains illegal character (s). Reenter both names.", bv_name);
	     go to invalid;
	end;

	if blank_ok then ;
	else if index (substr (bv_name, 1, i), " ") ^= 0 then do;
	     call ioa_ ("Short level and category names may not contain embedded blanks. Reenter both names.");
	     call ask_$ask_clr ();
	     return ("1"b);
	end;

	do i = lbound (installation_parms.level_names (*), 1) to hbound (installation_parms.level_names (*), 1);
	     if installation_parms.level_names (i) = bv_name then go to found_duplicate;
	end;

	do i = lbound (installation_parms.category_names (*), 1) to hbound (installation_parms.category_names (*), 1);
	     if installation_parms.category_names (i) = bv_name then go to found_duplicate;
	end;

	do i = lbound (installation_parms.short_level_names (*), 1)
	     to hbound (installation_parms.short_level_names (*), 1);
	     if installation_parms.short_level_names (i) = bv_name then go to found_duplicate;
	end;

	do i = lbound (installation_parms.short_category_names (*), 1)
	     to hbound (installation_parms.short_category_names (*), 1);
	     if installation_parms.short_category_names (i) = bv_name then go to found_duplicate;
	end;

	return ("0"b);

found_duplicate:
	call ioa_ ("Name ^a is already in use. Reenter both names.", bv_name);
invalid:
	call ask_$ask_clr ();
	return ("1"b);

     end invalid_name;

/* ------------------------------ */

out_of_range:					/* NOLIMIT should check hw/word limit */
     procedure (prompt, v, v_lo, v_hi) returns (bit (1) aligned);

dcl  v fixed bin (35);
dcl  (v_hi, v_lo) fixed bin (35);
dcl  prompt char (*);
dcl  dummy char (1);
dcl  flag fixed bin;
dcl  (error, error_lo, error_hi) bit (1) aligned init (""b);

	if v_lo ^= NOLIMIT then
	     if v < v_lo then error, error_lo = "1"b;
	if v_hi ^= NOLIMIT then
	     if v > v_hi then error, error_hi = "1"b;

	if error then do;				/* value is out of range */
	     call ask_$ask_n (dummy, flag);		/* see if anything else was typed ahead */
	     call ask_$ask_clr ();			/* clear anything that was typed ahead */
	     call ioa_ ("ERROR: value of ^a (^d) may not be^[ below ^d^;^s^]^[ or^]^[ above ^d^;^s^].", prompt, v,
		(error_lo), v_lo, (error_lo & error_hi), (error_hi), v_hi);
	     call ioa_ ("Please retype it^[^x(and everything that followed it)^].", (flag > 0));
	     return ("1"b);
	end;
	return (""b);				/* value is ok */

     end out_of_range;

/* ------------------------------ */

print_config_element:
     procedure (i);

dcl  i fixed bin;

	call ioa_ ("^5d ^5d ^5d ^5d ^7.1f ^7.1f ^7.1f ^5d ^5d", installation_parms.cona.cpu (i),
	     installation_parms.cona.kmem (i), installation_parms.cona.kbulk (i), installation_parms.cona.shift (i),
	     installation_parms.cona.response_low (i) * 1e-1, installation_parms.cona.response_high (i) * 1e-1,
	     installation_parms.cona.maxu_base (i) * 1e-1, installation_parms.cona.maxa (i),
	     installation_parms.cona.maxq (i));

     end print_config_element;

/* ------------------------------ */

print_halfword:
     procedure (name, v);

dcl  name char (*);
dcl  v fixed bin (17) unaligned;

	call ioa_ ("^a:^x^d", name, v);
	return;

     end print_halfword;

/* ------------------------------ */

print_sval:
     procedure (name, sarray);

dcl  name char (*);
dcl  sarray (0:7) fixed bin (17) unaligned;

dcl  nq fixed bin;
dcl  i fixed bin;
dcl  arrayp ptr;
dcl  array (0:7, nq) fixed bin (17) unaligned based (arrayp);

	nq = 1;
	arrayp = addr (sarray);

print_sval_common:
	call ioa_ ("^a - PER ^[QUEUE AND^x^]SHIFT", name, (nq = 4));
	call ioa_ ("^[Q^x^]^5x0^6x1^6x2^6x3^6x4^6x5^6x6^6x7", (nq = 4));
	do i = 1 to nq;
	     call ioa_ ("^[^d^x^;^s^]^8(^6d^x^)", (nq = 4), i, array (*, i));
	end;
	return;

print_sqval:
     entry (name, sqarray);

dcl  sqarray (0:7, 4) fixed bin (17) unaligned;

	nq = 4;
	arrayp = addr (sqarray);
	go to print_sval_common;

     end print_sval;

/* ------------------------------ */

ptr_rs_name:					/* get name of RS, given pointer to temp seg */
     procedure (rsp) returns (char (32));

dcl  rsp ptr;
dcl  i fixed bin;

	do i = 0 to installation_parms.nrates;
	     if rsp = rs_ptrs (i) then return (installation_parms.rate_structures (i));
	end;
	call com_err_ (0, me, "Internal error in ""ptr_rs_name"".");
	return ("UNKNOWN!");			/* OOG! */

     end ptr_rs_name;

/* ------------------------------ */

rstab$$defined:					/* search rate_structure name table */
						/* just like devtab$$= */
     procedure (rsnm, loud_sw) returns (fixed bin);

dcl  rsnm char (*);
dcl  loud_sw bit (1) aligned;

dcl  i fixed bin;
dcl  should_find bit (1) aligned;

	should_find = "1"b;
	go to rstab_common;

rstab$$undefined:
     entry (rsnm, loud_sw) returns (fixed bin (17));

	should_find = "0"b;

rstab_common:
	do i = 0 to installation_parms.nrates;
	     if installation_parms.rate_structures (i) = rsnm | rsnm = "." then do;
		if ^should_find & loud_sw then do;
		     call ioa_ ("rate_structure ""^a"" is already defined.", rsnm);
		     call ask_$ask_clr ();
		end;
		return (i);
	     end;
	end;
	if should_find & loud_sw then do;
	     call ioa_ ("rate_structure ""^a"" is not defined.", rsnm);
	     call ask_$ask_clr ();
	end;
	return (-1);

     end rstab$$defined;

/* ------------------------------ */

rsctab$$defined:					/* search resource table. */
						/* just like devtab$$= */
     procedure (rscnm, loud_sw) returns (fixed bin);

dcl  rscnm char (*);
dcl  loud_sw bit (1) aligned;

dcl  i fixed bin;
dcl  should_find bit (1) aligned;

	should_find = "1"b;
	go to rsctab_common;

rsctab$$undefined:
     entry (rscnm, loud_sw) returns (fixed bin (17));

	should_find = "0"b;

rsctab_common:
	do i = 0 to installation_parms.nrscp;
	     if installation_parms.resource (i).name = rscnm then do;
		if ^should_find & loud_sw then do;
		     call ioa_ ("resource ""^a"" is already defined.", rscnm);
		     call ask_$ask_clr ();
		end;
		return (i);
	     end;
	end;
	if should_find & loud_sw then do;
	     call ioa_ ("resource ""^a"" is not defined.", rscnm);
	     call ask_$ask_clr ();
	end;
	return (-1);

     end rsctab$$defined;

/* ------------------------------ */

set_halfword:
     procedure (prompt, units, v17unal, v_lo, v_hi);	/* to set fixed bin (17) unaligned scalars */

dcl  prompt char (*);
dcl  units char (*);
dcl  v17unal fixed bin (17) unaligned;
dcl  v17al fixed bin (17) aligned;
dcl  v35al fixed bin (35) aligned;
dcl  v fixed bin (35);
dcl  (v_hi, v_lo) fixed bin (35);
dcl  long_sw bit (1) aligned;
dcl  aligned_sw bit (1) aligned;

	long_sw = "0"b;
	aligned_sw = "0"b;
	go to set_join;

set_half_al:
     entry (prompt, units, v17al, v_lo, v_hi);

	long_sw = "0"b;
	aligned_sw = "1"b;
	go to set_join;

set_word:
     entry (prompt, units, v35al, v_lo, v_hi);

	aligned_sw = "1"b;
	long_sw = "1"b;
	go to set_join;

set_join:
	do while ("1"b);
	     call ask_$ask_int ("^a^[^x(^a)^;^s^]:^x", v, prompt, (units ^= ""), units);
	     if ^out_of_range (prompt, v, v_lo, v_hi) then do;
		if long_sw then v35al = v;
		else if aligned_sw then v17al = v;
		else v17unal = v;
		return;
	     end;
	end;

     end set_halfword;

/* ------------------------------ */

/* Internal procedure to set per-queue, per-shift, and per-queue-and-shift parameters */

set_qval:
     procedure (prompt, qarray, v_lo, v_hi);		/* to set per-queue parameters 45 and 46 */

dcl  prompt char (*);
dcl  qarray (4) fixed bin (35);
dcl  (v_lo, v_hi) fixed bin (35);

dcl  (set_shift, set_queue) bit (1) aligned init (""b);
dcl  esw fixed bin;
dcl  prompted bit (1) aligned init (""b);
dcl  (q, nq, s, ns) fixed bin;
dcl  v fixed bin (35);
dcl  (qx, q_ext, sx, s_ext) fixed bin;
dcl  ask_again bit (1) aligned;
dcl  (q_lo, q_hi, s_lo, s_hi) fixed bin;

	esw = 1;					/* remember which entry point we came in at */
	set_queue = "1"b;				/* and what we are supposed to do */
	go to set_common;

set_sval:
     entry (prompt, sarray, v_lo, v_hi);		/* to set parameters 38, 39, and 40 */

dcl  sarray (0:7) fixed bin (17) unaligned;

	esw = 2;					/* remember which entry point we came in at */
	set_shift = "1"b;				/* and what we are supposed to do */
	go to set_common;

set_sqval:
     entry (prompt, sqarray, v_lo, v_hi);		/* to set parameters 41 thru 43 */

dcl  sqarray (0:7, 4) fixed bin (17) unaligned;

	esw = 3;					/* remember which entry point we came in at */
	set_shift, set_queue = "1"b;			/* and what we are supposed to do */
	go to set_common;

set_sqlval:
     entry (prompt, sqlarray, v_lo, v_hi);		/* for parameter 44 */

dcl  sqlarray (0:7, 4) fixed bin (35);

	esw = 4;					/* remember which entry point we came in at */
	set_shift, set_queue = "1"b;			/* and what we are supposed to do */
	go to set_common;

set_common:
	ns, nq = 1;				/* go around shift and queue loops at least once each */

/* See if any shift or queue numbers were typed ahead */

	if esw = 1 then call get_queue (q_lo, q_hi);
	else if esw = 2 then call get_shift (s_lo, s_hi);
	else call get_shift_queue (q_lo, q_hi, s_lo, s_hi);

/* Check on what was typed ahead, and fill in defaults in the absence of typeahead */

	if set_queue then do;			/* if setting a per-queue or per-shift-and-queue parameter */
	     if q_lo = -1 then do;			/* if queue not typed ahead */
		if change_request then do;		/* default for change is to ask for, and set, a single queue */
		     ask_again = "1"b;
		     do while (ask_again);
			call ask_$ask_int ("queue:^x", q_lo);
						/* ask for it */
			ask_again = out_of_range ("queue", (q_lo), 1, 4);
		     end;
		     q_hi = q_lo;			/* q_hi=q_lo means set value for only one queue */
		end;
		else do;				/* default for retype is set all queues */
		     nq = 4;			/* ask for 4 values */
		     q_lo = 1;			/* for queues 1 */
		     q_hi = 4;			/* thru 4 */
		end;
	     end;
	     if nq = 1 then				/* if we will ask for only one per-queue value */
		q_ext = q_hi - q_lo;		/* set this many extra elements to that value */
	     else q_ext = 0;			/* otherwise, set only one element per value typed in */
	end;					/* end setting per-queue parameter */

	if set_shift then do;			/* if setting a per-shift or per-shift-and-queue parameter */
	     if s_lo = -1 then do;			/* if shift not typed ahead */
		if change_request then do;		/* default for change is a single shift */
		     ask_again = "1"b;
		     do while (ask_again);
			call ask_$ask_int ("shift:^x", s_lo);
						/* ask for it */
			ask_again = out_of_range ("shift", (s_lo), 0, 7);
		     end;
		     s_hi = s_lo;			/* one shift */
		end;
		else do;				/* default for retype is all shifts */
		     ns = 8;			/* so ask for 8 values */
		     s_lo = 0;			/* for shifts 0 */
		     s_hi = 7;			/* thru 7 */
		end;
	     end;
	     if ns = 1 then				/* if we will ask for only one per-shift value */
		s_ext = s_hi - s_lo;		/* set this many extra elements to that value */
	     else s_ext = 0;			/* otherwise, set only one element per value typed in */
	end;					/* end setting per-shift value */

/* Now, ask for, and store, the value(s) */

/* Outer loop on queue. If not setting per-queue, or per-shift-and-queue parameter,
   go around this loop just once, to get to the inner loop */

	do q = q_lo to q_lo + nq - 1;

/* Inner loop on shift. If not setting per-shift or per-shift-and-queue parameter,
   go thru this loop just once for each time around the outer loop */

	     do s = s_lo to s_lo + ns - 1;

/* This is what we're here for */
		ask_again = "1"b;
		do while (ask_again);
		     call ask_$ask_int (
			"^[^s^;^a:^x^]^[queue^[s ^d-^d^; ^d^s^]:^x^;^3s^]^[shift^[s ^d-^d^; ^d^s^]:^x^;^3s^]", v,
						/* the value to be typed in */
			prompted, prompt,		/* print the prompting word only once (first time around) */
			(set_queue & s = s_lo), (q_ext > 0), q, q_hi,
						/* if setting per-queue parm, print 1 or 2 queue numbers */
			(set_shift), (s_ext > 0), s, s_hi);
						/* if setting per-shift parm, print 1 or 2 shift #s */
		     ask_again = out_of_range (prompt, v, v_lo, v_hi);
		end;

		prompted = "1"b;			/* remember not to print prompting word again */

/* Now store the value into one or more array elements */
		if esw = 1 then
		     do qx = 0 to q_ext;
		     qarray (q + qx) = v;
		end;

		else if esw = 2 then
		     do sx = 0 to s_ext;
		     sarray (s + sx) = v;
		end;

		else do qx = 0 to q_ext;
		     do sx = 0 to s_ext;
			if esw = 3 then sqarray (s + sx, q + qx) = v;
			else if esw = 4 then sqlarray (s + sx, q + qx) = v;
		     end;
		end;

	     end;					/* end inner loop on shift */
	end;					/* end outer loop on queue */

	return;

     end set_qval;

/* ------------------------------ */

set_shift_field:
     procedure (i, j, k, n);

dcl  (i, j, k, n) fixed bin;

	installation_parms.shifttab (48 * i + (2 * j + n) + 1) = bit (fixed (k, 3), 3);
	return;

     end set_shift_field;

/* ------------------------------ */

set_std_shifttab:
     procedure;

dcl  (i, j) fixed bin;

	do i = 0 to 6;
	     do j = 0 to 15;
		installation_parms.shifttab (48 * i + j + 1) = "011"b;
	     end;
	     do j = 16 to 35;
		installation_parms.shifttab (48 * i + j + 1) = "001"b;
	     end;
	     do j = 36 to 47;
		installation_parms.shifttab (48 * i + j + 1) = "010"b;
	     end;
	end;
	do i = 5 to 6;
	     do j = 16 to 47;
		installation_parms.shifttab (48 * i + j + 1) = "100"b;
	     end;
	end;

     end set_std_shifttab;

/* ------------------------------ */

sort_config_table:
     procedure;

dcl  i fixed bin;
dcl  o1 fixed bin (71);
dcl  o2 fixed bin (71);
dcl  changed bit (1) aligned;
dcl  ever_changed bit (1) aligned;
dcl  save_crit bit (1) aligned;
dcl  ncon fixed bin;
dcl  1 tcona like installation_parms_part_1.cona aligned;

	changed = "1"b;
	ever_changed = "0"b;
	save_crit = critical_op;
	critical_op = critical_op | (all_sw = ALL_RS);
	ncon = installation_parms.ncon;		/* number of config table elements */

	do while (changed & ncon > 1);		/* keep going until we drop */
	     changed = "0"b;

	     do i = 1 repeat i + 1 while (i < ncon);
		o1 = gen_config_ordinal ((installation_parms.cona (i).cpu), (installation_parms.cona (i).kmem),
						/* get a number describing this element */
		     (installation_parms.cona (i).kbulk), (installation_parms.cona (i).shift));
		o2 = gen_config_ordinal ((installation_parms.cona (i + 1).cpu),
						/* and one for this element */
		     (installation_parms.cona (i + 1).kmem), (installation_parms.cona (i + 1).kbulk),
		     (installation_parms.cona (i + 1).shift));
		if o1 < 0 | installation_parms.cona (i).cpu <= 0 then do;
						/* should we dump this one? */
		     installation_parms.cona (i) = installation_parms.cona (ncon);
		     ncon = ncon - 1;
		     changed = "1"b;
		end;
		else if o2 < 0 | installation_parms.cona (i + 1).cpu <= 0 then do;
						/* dump this one (only one at a time, please)? */
		     installation_parms.cona (i + 1) = installation_parms.cona (ncon);
		     ncon = ncon - 1;
		     changed = "1"b;
		end;
		else if o1 > o2 then do;		/* out of order? */
		     tcona = installation_parms.cona (i);
						/* fiddle about */
		     installation_parms.cona (i) = installation_parms.cona (i + 1);
		     installation_parms.cona (i + 1) = tcona;
		     changed = "1"b;
		end;
		ever_changed = ever_changed | changed;
	     end;
	end;

	if ever_changed then do;			/* tell user if we changed anything */
	     call ioa_ ("Config table sorted.");
	     installation_parms.ncon = ncon;
	end;
	critical_op = save_crit;			/* back to where we were */

     end sort_config_table;

/* ------------------------------ */

verify_structures:
     procedure;

dcl  (i, j) fixed bin;
dcl  rsn fixed bin;
dcl  force bit (1) aligned;
dcl  char8 char (8);
dcl  phoo bit (1) aligned;
dcl  rsname char (32);

	call ask_$ask_n (char8, i);
	force = (i > 0 & (char8 = "-force" | char8 = "-fc" | char8 = "force" | char8 = "fc"));
	if force then call ask_ ("", char8);		/* remove it from line */

	do rsn = 0 to installation_parms.nrates;	/* for all rate-structures */
	     cur_rs_ptr = rs_ptrs (rsn);
	     rsname = installation_parms.rate_structures (rsn);

/* check device tables against installation_parms */

	     if rate_structure.ndevices ^= installation_parms.ndevices then do;
						/* first, check the counts */
		call ioa_ ("installation_parms has ^d devices, rate_structure ""^a"" has ^d",
		     installation_parms.ndevices, rsname, rate_structure.ndevices);
		if force then do;
		     call ioa_ ("Forcing change.");
		     rate_structure.ndevices = installation_parms.ndevices;
		end;
	     end;
	     do j = 1 to installation_parms.ndevices;	/* now check all the names */
		if installation_parms.device_id (j) ^= rate_structure.device_id (j) then do;
		     call ioa_ (
			"installation_parms has device ""^a"" at position ^d.^/rate_structure ""^a"" has device ""^a""."
			, installation_parms.device_id (j), j, rsname, rate_structure.device_id (j));
		     if force then do;
			call ioa_ ("Forcing change, price set to 0.0");
			rate_structure.device_id (j) = installation_parms.device_id (j);
			rate_structure.device_price (j, *) = 0e0;
		     end;
		end;
	     end;

/* check resources */

	     if installation_parms.nrscp ^= rate_structure.nrscp then do;
						/* first check the counts */
		call ioa_ (
		     "installation_parms has ^d resource array entries, rate_structure ""^a"" has ^d.^[ Forcing change^]"
		     , installation_parms.nrscp, rsname, rate_structure.nrscp, force);
		if force then rate_structure.nrscp = installation_parms.nrscp;
	     end;
	     do i = 1 to installation_parms.nrscp;	/* then check the names */
		if installation_parms.resource (i).name ^= rate_structure.resource (i).name then do;
		     call ioa_ (
			"installation_parms has resource ^a as entry ^d, the rate_structure resource is ""^a"".",
			installation_parms.resource (i).name, i, rate_structure.resource (i).name);
		     if force then do;
			call ioa_ ("Forcing change, price set to 0.0");
			rate_structure.resource (i).name = installation_parms.resource (i).name;
			rate_structure.resource (i).price = 0e0;
		     end;
		end;
	     end;

/* then check all the rate_structure name stuff */

	     if rate_structure.rate_structure_number ^= rsn then do;
						/* do I point to myself? */
		call ioa_ ("rate_structure ^d (^a) has incorrect rate_structure_number field ^d. ^[Forcing change^]",
		     rsn, installation_parms.rate_structures (rsn), rate_structure.rate_structure_number, force);
		if force then rate_structure.rate_structure_number = rsn;
	     end;
	     if rate_structure.nrates ^= installation_parms.nrates then do;
						/* first, check the counts */
		call ioa_ ("installation_parms has ^d rate_structures, rate_structure ""^a"" has ^d.",
		     installation_parms.nrates, rsname, rate_structure.nrates);
		if force then do;
		     call ioa_ ("Forcing change.");
		     rate_structure.nrates = installation_parms.nrates;
		end;
	     end;
	     do i = 0 to installation_parms.nrates;	/* now check the names */
		if installation_parms.rate_structures (i) ^= rate_structure.rate_structures (i) then do;
		     call ioa_ (
			"installation_parms has rate_structure ""^a"" at position ^d.^/rate_structure ""^a"" has rate_structure ""^a""."
			, installation_parms.rate_structures (i), i, rsname, rate_structure.rate_structures (i));
		     if force then do;
			call ioa_ ("Forcing change.");
			rate_structure.rate_structures (i) = installation_parms.rate_structures (i);
		     end;
		end;
	     end;
	end;

	cur_rs_ptr = selected_rs_ptr;			/* return to normalcy */
	edit_rs = (cur_rs_ptr ^= ip);
	critical_op = "0"b;
	call check_config_table;			/* config table ok? */
	phoo = check_device_names ();			/* device table have required names? */

     end verify_structures;

/* ------------------------------ */

write_error:
     procedure (ec, i, msg);
dcl  ec fixed bin (35);
dcl  i fixed bin;
dcl  msg char (*);

	call com_err_ (ec, me, "rate_structure_^d (^a) ^a.", i, installation_parms.rate_structures (i), msg);

     end write_error;

set_pdir_quota_defaults:
     procedure;

declare  code fixed bin (35);

/**** OLD COMMUNICATIONS SEGMENT */

dcl  com_p pointer;
dcl  1 communications based (com_p) aligned,		/* Administrators and answering service use it */
       2 admin_word char (8) unal,			/* Operator password for admin mode */
       2 ppmdl fixed bin,				/* Per-process master drum limit */
       2 ppmdl_daemon fixed bin,			/* ... for daemon */
       2 ssdq fixed bin,				/* Process directory disk quota */
       2 ssdq_daemon fixed bin,			/* ... for daemon */
       2 junk (4) fixed bin,
       2 version fixed bin,
       2 admin_sw fixed bin,				/* Length of administrator's command */
       2 admin_comment char (80) unal,			/* any old comment */
       2 admin_sender char (32) unal,			/* Who sent it */
       2 as_procid bit (36),				/* Process id of answering service */
       2 admin_com_chn fixed bin (71),			/* Event-call channel for admin command */
       2 admin_com char (4000) unaligned;		/* actual command line */

	call initiate_file_ (sc_stat_$sysdir, "communications", R_ACCESS, com_p, (0), code);
	if code = 0 then do;
	     installation_parms.default_pdir_seg_quota = communications.ssdq;
	     call terminate_file_ (com_p, (0), TERM_FILE_TERM, (0));
	end;
	else installation_parms.default_pdir_seg_quota = 1000;
	installation_parms.default_pdir_dir_quota = 1000;
	return;
     end set_pdir_quota_defaults;


/* ------------------------------ */

%page;
%include access_mode_values;
%page;
%include aim_template;
%page;
%include devid;
%page;
%include installation_parms;
%include rate_structure;
%include terminate_file;
%include sc_stat_;

     end ed_installation_parms;




		    ed_mgt.pl1                      04/09/85  1352.0r w 04/08/85  1134.5      791082



/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */
/* format: style4 */
ed_mgt: procedure options (variable);

/* ed_mgt - edit "master_group_table"
   which gives load control parameters for the load control groups
   and work class definitions for the work classes used by the priority scheduler

   Modified by T. Casey, June 1975, to edit work class information for priority scheduler
   Modified by T. Casey, October 1975 to fix bugs
   Modified by T. Casey, October 1976 to add deadline scheduler parameters.
   Modified by T. Casey, Sept 1977, to fix bugs in print and verify requests,
   .		and to permit the deletion of a group (which used to produce a warning).
   Modified by T. Casey, November 1978, to add group parameters: absentee_(max min pct).
   Modified May 1979 by T. Casey for MR7.0a to fix bug in verify (re the above absentee parameters).
   Modified July 1981 by J. Bongiovanni for governed work classes
   Modified 1984-09-17 BIM to remove call to reformat_mgt_,
   add page_weight support.
   Modified 1984-09-26 by E. Swenson to fix bug introduced by above change.
*/

%include mgt;
%include access_mode_values;
%include terminate_file;
%page;

dcl  arg_count fixed bin;
dcl  created_new_mgt bit (1) aligned;
dcl  dn char (168),
     en char (32),
     grp char (8),
     change_code char (20),
     (i, j, k, n) fixed bin,
     mgtp1 ptr init (null),
     comm char (8),
     movelen fixed bin,
     ap ptr,
     al fixed bin (21),
     bchr char (al) unaligned based (ap),
     code fixed bin (35),
     mgtp ptr init (null),				/* ptr to master group table (work copy) */
     qq ptr,
     ask_$ask_clr entry options (variable),
     ask_$ask_flo entry options (variable),
     ask_$ask_int entry options (variable),
     ask_$ask_yn entry options (variable),
     ask_ entry options (variable),
     ask_$ask_n entry options (variable),
     ask_$ask_nint entry options (variable),
     ask_$ask_nflo entry options (variable),
     ask_$ask_c entry options (variable),
     ask_$ask_cint entry options (variable),
     ask_$ask_cflo entry options (variable),
     ask_$ask_setline entry (char (*)),
     btemp bit (1) aligned,
     itemp fixed bin,
     ftemp float bin;

dcl  (addr, fixed, float, hbound, index, length, max, min, mod,
     null, reverse, size, string, substr, verify) builtin;

dcl  program_interrupt condition;
dcl  cleanup condition;

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  expand_pathname_$add_suffix entry (character (*), character (*), character (*), character (*),
	fixed binary (35));
dcl  pathname_ entry (character (*), character (*)) returns (character (168));
dcl  ioa_ entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  ioa_$nnl entry options (variable);
dcl  com_err_ entry options (variable);
dcl  com_err_$suppress_name entry () options (variable);
dcl  initiate_file_$create entry (character (*), character (*), bit (*), pointer, bit (1) aligned,
	fixed binary (24), fixed binary (35));
dcl  terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35));
dcl  get_temp_segment_ entry (character (*), pointer, fixed binary (35));
dcl  release_temp_segment_ entry (character (*), pointer, fixed binary (35));
dcl  get_group_id_ entry () returns (char (32));
dcl  get_wdir_ entry () returns (character (168));

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

dcl  mgtix fixed bin;
dcl  change_item fixed bin;
dcl  change_type fixed bin;
dcl  (fshift, lshift, nshift) fixed bin;
dcl  (mxval, nval) fixed bin;
dcl  flag fixed bin;
dcl  (gcfirst, gclast) fixed bin;
dcl  undefwc fixed bin;
dcl  shift fixed bin;
dcl  shift_pct fixed bin;
dcl  no_abs_count fixed bin;

dcl  dflt_g (4) fixed bin;
dcl  ival (8) fixed bin;
dcl  fval (8) float bin;
dcl  bval (8) bit (1) aligned;
dcl  shifts (8) fixed bin;
dcl  shf (8) fixed bin;				/* set by get_shift_spec: list of shifts to be changed */
dcl  nshf fixed bin;

dcl  print_pct_ignored bit (1) aligned;
dcl  default_absentee bit (1) aligned;
dcl  int_wc bit (1) aligned;
dcl  gcsw bit (1) aligned;
dcl  wcsw bit (1) aligned;
dcl  wcundef bit (1) aligned;
dcl  (got_shift_spec, got_int_abs, got_values) bit (1) aligned;
dcl  (padflt, pawc, pagrp, patot, paxrf) bit (1) aligned;
dcl  no_abs bit (1) aligned;

dcl  shift_used (0:7) bit (1) aligned;
dcl  q (4) bit (1) aligned;
dcl  dflt_q (4) bit (1) unaligned;

dcl  wcp ptr;

dcl  char32 char (32);

dcl  change_entry_type (2:26) fixed bin int static options (constant) init /* entry types that each change_code is valid for:
						   0=header,1=group,2=work class,3=group OR work class */
	(0,					/* 2: prio sked */
	(9) 1,					/* 3-11: maxu thru wc */
	3,					/* 12: absentee */
	(7) 2,					/* 13-19: pct thru mode */
	(2) 0,					/* 20,21: normal moce, shifts */
	(3) 1,					/* 22-24: absentee_(max min pct) */
	(2) 2);					/* 25: max_pct, 26: page_weight */


dcl  change_types (2:26) fixed bin int static options (constant) init /* data types for each item that change deals with */
	(3, 2, 0, 2, 1, 1, 1, 1, 2, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 1, 1, 1, 4, 4);
						/* 0=char;1=float;2=float*10;3=yes/no;4=variable_format */

dcl  vtypes (11:26) fixed bin int static options (constant) init /* mapping between change_item and value type,
						   for the variable format change items */
	(1, 3, 1, 3, 2, 2, 2, 2, 3, 3, 0, 0, 0, 0, 1, 1); /* 1=integer;2=floating point;3=keyword */


dcl  change_names (2:26) char (12) int static options (constant) init (/* ITEM - names used in prompting messages */
	"prio_sked"				/* 2 */
	, "max_prim"				/* 3 */
	, "id"					/* 4 */
	, "abs_max"				/* 5 */
	, "numerator"				/* 6 */
	, "denominator"				/* 7 */
	, "num1"					/* 8 */
	, "denom1"				/* 9 */
	, "constant"				/* 10 */
	, "work_class"				/* 11 */
	, "absentee y/n"				/* 12 */
	, "percent(s)"				/* 13 */
	, "defined y/n"				/* 14 */
	, "int_resp"				/* 15 */
	, "int_quantum"				/* 16 */
	, "resp"					/* 17 */
	, "quantum"				/* 18 */
	, "mode norm/rt"				/* 19 */
	, "deadline/pct"				/* 20 */
	, "shifts"				/* 21 */
	, "absentee_max"				/* 22 */
	, "absentee_min"				/* 23 */
	, "absentee_pct"				/* 24 */
	, "max_pct(s)"				/* 25 */
	, "page_weight"				/* 26 */
	);

dcl  change_items (50) fixed bin int static options (constant) init /* correspondence between the 50 change_codes and the 26 items */
	(1, 1, 2, 2, 3, 3, 3, 3, 4, 5, 5, 5, 6, 6, 7, 7, 7, 8, 9, 9, 10, 10, 10, 11, 11, 12, 13, 13, 13, 14, 14,
	15, 15, 16, 16, 17, 17, 18, 18, 19, 20, 20, 21, 22, 23, 24, 25, 25, 26, 26);

dcl  change_codes (50) char (12) int static options (constant) init (
						/* CODE	ITEM  - names that user can give in change request */

/* control items - used to exit from change mode */

	"*"					/* 1	1 */
	, "."					/* 2	1 */

/* header items (see additional header items below) */

	, "prio"					/* 3	2 */
	, "prio_sked"				/* 4	2 */

/* group items */

	, "maxu"					/* 5	3 */
	, "max_prim"				/* 6	3 */
	, "maxp"					/* 7	3 */
	, "m"					/* 8	3 */
	, "id"					/* 9	4 */
	, "abs"					/* 10	5 */
	, "abs_max"				/* 11	5 */
	, "minamax"				/* 12	5 */
	, "numerator"				/* 13	6 */
	, "num"					/* 14	6 */
	, "denominator"				/* 15	7 */
	, "den"					/* 16	7 */
	, "denom"					/* 17	7 */
	, "num1"					/* 18	8 */
	, "denom1"				/* 19	9 */
	, "den1"					/* 20	9 */
	, "constant"				/* 21	10 */
	, "const"					/* 22	10 */
	, "con"					/* 23	10 */
	, "work_class"				/* 24	11 */
	, "wc"					/* 25	11 */

/* both group and work class item */

	, "absentee"				/* 26	12 */

/* work class only items */

	, "percent"				/* 27	13 */
	, "pct"					/* 28	13 */
	, "%"					/* 29	13 */
	, "defined"				/* 30	14 */
	, "def"					/* 31	14 */
	, "int_resp"				/* 32	15 */
	, "ir"					/* 33	15 */
	, "int_quantum"				/* 34	16 */
	, "iq"					/* 35	16 */
	, "resp"					/* 36	17 */
	, "r"					/* 37	17 */
	, "quantum"				/* 38	18 */
	, "q"					/* 39	18 */
	, "mode"					/* 40	19 */

/* additional header items */

	, "normal_mode"				/* 41	20 */
	, "norm"					/* 42	20 */
	, "shifts"				/* 43	21 */
	, "absentee_max"				/* 44	22 */
	, "absentee_min"				/* 45	23 */
	, "absentee_pct"				/* 46	24 */

/* additional work class only items */

	, "max_percent"				/* 47     25 */
	, "max_pct"				/* 48     25 */
	, "page_weight"				/* 49     26 */
	, "pw"					/* 50     26 */
	);


declare  ME char (32) int static init ("ed_mgt") options (constant);
declare  DEFAULT_MGT_PATH char (168) init ("MGT.mgt") int static options (constant);


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

	if arg_count > 1 then do;
	     call com_err_$suppress_name (0, ME, "Usage: ed_mgt {pathname}");
	     return;
	end;

	if arg_count = 0 then do;
	     ap = addr (DEFAULT_MGT_PATH);
	     al = length (rtrim (DEFAULT_MGT_PATH));
	end;

	else call cu_$arg_ptr (1, ap, al, (0));

	call expand_pathname_$add_suffix (bchr, "mgt", dn, en, code);
	if code ^= 0 then do;
	     call com_err_ (code, "ed_mgt", bchr);
	     return;
	end;

	created_new_mgt = "0"b;
	mgtp, mgtp1 = null ();
	on cleanup call clean_up;
	call initiate_file_$create (dn, en, RW_ACCESS, mgtp1, created_new_mgt, (0), code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "^a", pathname_ (dn, en));
	     call clean_up;
	end;

	call get_temp_segment_ (ME, mgtp, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "Internal error; cannot get a temp segment.");
	     call clean_up;
	end;

	on condition (program_interrupt) go to main1;

	if ^(created_new_mgt | mgtp1 -> mgt.version_indicator ^= "VERSION ") then
	     mgtp -> mgt = mgtp1 -> mgt;

	else do;
	     call ioa_ ("Creating new MGT ^a.", pathname_ (dn, en));
	     call initialize_mgt;
	end;

	if mgt.version ^= MGT_version_3 then do;	/* if not current version, see what it is */
	     call com_err_ (error_table_$unimplemented_version,
		ME, "MGT version is ^d, must be ^d.",
		mgt.version, MGT_version_3);
	     call clean_up;
	     return;
	end;					/* end version not 3 */


/* Initialize current position and enter request loop */

	mgtix = 17;				/* group 1 */
	mgtep = addr (mgt.entry (17));		/* gotta start somewhere */
	if mgt.current_size < mgtix then do;		/* nobody home? */
	     call ioa_ ("no groups defined, ""add"" assumed");
	     go to acom;
	end;

/* Come here after an error, to clear any typed ahead input before prompting for next request */

main1:	call ask_$ask_clr;

/* Come here to prompt for another request */

main:	call ask_ ("type    ", comm);			/* get command */
	mgtep = addr (mgt.entry (mgtix));		/* mgtep gets moved around -
						   mgtix is the true "current pointer" */
	if comm = "quit" then goto qcom;
	else if comm = "q" then
qcom:
exit:	     do;
	     call clean_up;
	     return;
	end;
	else if comm = "write" | comm = "w"
	then do;					/* write? */
wcom:
	     created_new_mgt = "0"b;			/* don't delete me! */

	     mgtp1 -> mgt = mgtp -> mgt;

	     call terminate_file_ (mgtp1, 36 * (64 + mgtp1 -> mgt.current_size * 32), TERM_FILE_TRUNC | TERM_FILE_BC, (0));

	     goto main;				/* leave pointer where it was, after a write */
	end;
	else if comm = "f" then go to fcom;		/* find */
	else if comm = "find" then do;
fcom:	     call ask_ ("group   ", grp);
	     do i = 1 to mgt.current_size;
		mgtep = addr (mgt.entry (i));
		if group.group_id = grp then do;
		     mgtix = i;
		     go to pentry;
		end;
	     end;
	     call ioa_ ("group ""^a"" not found", grp);
	     go to main1;
	end;
	else if comm = "c" then go to ccom;		/* change */
	else if comm = "change" then do;

ccom:	     gcsw = "0"b;				/* not global change */
	     if mgtix <= 16 then wcsw = "1"b;
	     else wcsw = "0"b;
	     call change;
	end;

	else if comm = "gc" then goto gccom;
	else if comm = "global_change" then do;
gccom:	     gcsw = "1"b;
	     call ask_ ("entry type ", change_code);
	     if change_code = "load_control_group" then goto lctype;
	     if substr (change_code, 1, 5) = "group" then goto lctype; /* allow singular or plural */
	     else if change_code = "lcg" then do;
lctype:		wcsw = "0"b;
	     end;
	     else if change_code = "work_class" then goto wctype;
	     else if change_code = "wc" then do;
wctype:		wcsw = "1"b;
	     end;
	     else do;
		call ioa_ ("bad entry type: ""^a""^/must be ""work_class"" or ""load_control_group""", change_code);
		call ask_$ask_clr;
		goto gccom;
	     end;

	     call change;
	end;

	else if comm = "p" then go to pcom;
	else if comm = "print" then do;
pcom:
	     if mgtix > 16 then
		call prgp (mgtep);
	     else do;
		wcundef = ""b;
		call prwc (mgtep);
		if wcundef then do;
		     call ioa_ (" is undefined");
		     wcundef = ""b;
		end;
	     end;
	end;

	else if comm = "p*" then go to pacom;
	else if comm = "pa" then go to pacom;
	else if comm = "pall" then do;
pacom:

	     padflt = "1"b;				/* assume no optional arguments */
	     patot, pawc, pagrp, paxrf = "0"b;
paloop:	     call ask_$ask_n (char32, flag);		/* check for optional arguments */
	     if flag = 0 then goto no_pa_arg;		/* if nothing there */
	     if substr (char32, 1, 3) = "tot" then do;	/* allow "tot", "total", "totals" */
		patot = "1"b;
pa_arg:		padflt = "0"b;			/* remember that some args were given */
		call ask_$ask_c (char32, flag);	/* get rid of it from line */
		goto paloop;			/* go see if more */
	     end;
	     else if char32 = "lcg" then goto pa_grp;
	     else if substr (char32, 1, 5) = "group" then goto pa_grp; /* allow singular or plural form */
	     else if substr (char32, 1, 18) = "load_control_group" then do;
pa_grp:		pagrp = "1"b;
		goto pa_arg;
	     end;
	     else if char32 = "wc" then goto pa_wc;
	     else if substr (char32, 1, 10) = "work_class" then do; /* allow singular or plural form */
pa_wc:		pawc = "1"b;
		goto pa_arg;
	     end;
	     else if char32 = "xref" then goto pa_xref;
	     else if char32 = "cref" then goto pa_xref;
	     else if substr (char32, 1, 5) = "cross" then do; /* allow cross reference, in any form */
pa_xref:		paxrf = "1"b;
		goto pa_arg;
	     end;

no_pa_arg:					/* fall thru if no match, or come here if no typed ahead arg */
	     if padflt then				/* if no args given, use the default */
		patot, pawc, pagrp, paxrf = "1"b;	/* which is to print everything  */

/* now, print the stuff */

	     if patot then do;			/* if we are to print totals from mgt header */
		call ioa_ ("max_size ^d", mgt.max_size);
		call ioa_ ("current_size ^d", mgt.current_size);
		call ioa_ ("total_units ^d", mgt.total_units);
		call ioa_ ("prio_sked_enabled: ^[yes^;no^]", mgt.switches.prio_sked_enabled);
		call ioa_ ("wc_initialized: ^[yes^;no^]", mgt.switches.wc_initialized);
		call print_shfs (mgt.shift_defined, "defined shifts: ", "^x^d");
		call print_bvals (mgt.shift_defined, "scheduling mode:", "^x^[d^;%^]", mgt.switches.deadline_mode);
	     end;


	     if pagrp then				/* if we should print all groups */
		do n = 17 to mgt.current_size;	/* do so */
		qq = addr (mgt.entry (n));
		call prgp (qq);
	     end;

	     if pawc then do;			/* if we should print all work classes */
		wcundef = ""b;			/* we check for a series of undefined work classes */
		do n = 1 to 16;			/* to avoid aggravating the user */
		     qq = addr (mgt.entry (n));	/* by printing a long list of "... is undefined" lines */
		     if wcundef then do;		/* if the previous one was undefined */
			if string (qq -> work_class.switches.defined) ^= ""b then do; /* but this one is defined */
plast:			     wcundef = ""b;
			     if undefwc = n - 1 then	/* if only the last one was undefined */
				call ioa_ (" is undefined");
			     else call ioa_ ("-^d are undefined", n - 1);
			     if n <= 16 then	/* if not entered at plast to print "last few undefined" */
				call prwc (qq);	/* go print the current work class */
			end;
		     end;
		     else do;			/* previous one was not undefined */
			call prwc (qq);
			if wcundef then		/* prwc checks, and sets this switch */
			     undefwc = n;		/* remember the first undefined one in the series */
		     end;
		end;
		if wcundef then			/* if last few were undefined */
		     goto plast;			/* go print message to that effect */
	     end;

	     if paxrf then				/* if we are to print a cross reference */
		call pxref;			/* go do so */


	end;

	else if comm = "a" then go to acom;
	else if comm = "add" then do;
acom:	     call ask_ ("group   ", grp);
	     do mgtix = 1 to mgt.current_size;
		mgtep = addr (mgt.entry (mgtix));
		if group.group_id = grp then do;
		     if mgtix < 17 then call ioa_ ("use the ""change"" request to define a work class");
		     else call ioa_ ("group ""^a"" already exists", grp);
		     go to main1;
		end;
	     end;
	     mgtix = mgt.current_size + 1;
	     mgtep = addr (mgt.entry (mgtix));
	     group.group_id = grp;
	     group.minamax = 32767;			/* will have to change this if Multics gets really big */
	     group.absentee.allowed = "1"b;		/* by default */
	     call ask_$ask_flo ("constant ", ftemp);
	     if ftemp < 0e0 then group.max_prim = -1;
	     else group.minu = ftemp * 10;

	     if mgt.switches.wc_initialized then	/* if work classes (other than the initial
						   default of 1) have been defined */
		call ask_$ask_int ("work class ", itemp); /* keep it simple - just ask for one */
	     else itemp = 1;			/* none defined - use the initial default work class */
	     do i = 0 to 7;
		if mgt.shift_defined (i) then
		     group.int_wc (i), group.abs_wc (i) = itemp;
		else group.int_wc (i), group.abs_wc (i) = 0;
	     end;

	     mgt.current_size = mgtix;
	end;

	else if comm = "delete" then do;
	     if mgtix <= 16 then do;
		call ioa_ ("use the ""change"" request to undefine a work class");
		goto main1;
	     end;
	     do i = mgtix + 1 to mgt.current_size;
		mgt.entry (i - 1) = mgt.entry (i);
	     end;
	     mgt.current_size = mgt.current_size - 1;
	     mgtix = min (mgtix, mgt.current_size);	/* in case we deleted the last group */
	     mgtep = addr (mgt.entry (mgtix));
	     goto pentry;				/* tell user the current group has changed */
	end;

	else if comm = "n" then go to ncom;
	else if comm = "next" then do;
ncom:	     mgtix = mgtix + 1;
	     if mgtix > mgt.current_size then do;
		call ioa_ ("EOF");
		mgtix = mgt.current_size;
	     end;
	     mgtep = addr (mgt.entry (mgtix));
	     goto pentry;
	end;
	else if comm = "top" then go to tcom;
	else if comm = "t" then go to tcom;
	else if comm = "-" then do;
	     mgtix = mgtix - 1;
	     if mgtix <= 0 then do;
		call ioa_ ("TOP");
tcom:		mgtix = 1;
	     end;
	     mgtep = addr (mgt.entry (mgtix));
	     goto pentry;
	end;

	else if comm = "verify" then goto vcom;
	else if comm = "v" then do;
vcom:	     call verify_mgt;
	end;

	else if comm = "define" then call define;
	else if comm = "redefine" then call redefine;
	else if comm = "undefine" then call undefine;

	else do;					/* ? */
	     call ioa_ ("illegal command ""^a""", comm);
	     go to main1;
	end;

/* Fall thru to here after executing a request, unless:
   1) an error occurred and we went directly to main1 to flush possible typeahead; or
   2) we moved the current pointer and went to pentry (just below) to print the name of the new current entry.
*/

	go to main;

pentry:						/* come here to print line telling user where he is */
	call ask_$ask_n (char32, flag);		/* see if anything typed ahead */
	if flag ^= 0 then goto main;			/* if user typed ahead, we assume he knows where he is */
	if mgtix <= 16 then
	     call ioa_ ("work class: ^a", work_class.wc_name);
	else call ioa_ ("group: ^a", group.group_id);
	goto main;



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


/* Internal procedures, in alphabetic order */


ask_cval: proc (vtype, where, flag);

dcl  (flag, vtype, where) fixed bin;

	if vtype = 1 then
	     call ask_$ask_cint (ival (where), flag);
	else if vtype = 2 then
	     call ask_$ask_cflo (fval (where), flag);
	else if vtype = 3 then
	     call ask_ckey (bval (where), flag);

	return;

     end ask_cval;


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


ask_key: proc (bval, prompt);

dcl  prompt char (*);
dcl  bval bit (1) aligned;
dcl  (prompt_sw, remove_sw, yn_sw) bit (1) aligned;
dcl  (flag, local_flag) fixed bin;

	prompt_sw, remove_sw = "1"b;
	yn_sw = ""b;
	goto key_common;

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

ask_ckey: entry (bval, flag);
	flag = 0;
	prompt_sw, yn_sw = ""b;
	remove_sw = "1"b;
	goto key_common;

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

ask_nkey: entry (bval, flag);

	flag = 0;
	prompt_sw, remove_sw, yn_sw = ""b;
	goto key_common;

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

ask_yn: entry (bval, prompt);

	prompt_sw, yn_sw = "1"b;
	remove_sw = ""b;
	goto dont_ask_key;				/* caller already asked, and char32 contains the response */

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

ask_cyn: entry (bval, flag);

	remove_sw, prompt_sw = ""b;
	yn_sw = "1"b;
	goto dont_ask_key;				/* caller already asked, as above */

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

key_common:

	if prompt_sw then
ask_key_again: call ask_ ("^a ", char32, prompt);
	else do;
	     call ask_$ask_n (char32, flag);
	     if flag = 0 then return;
	end;

dont_ask_key:

	local_flag = 0;
	if change_item = 12 | change_item = 14 | yn_sw then
	     call scan_key ("allowed,yes,y,on,1,ok,^allowed,not_allowed,no,n,off,0", (6), bval, local_flag);
	else if change_item = 19 then
	     call scan_key ("realtime,rt,normal,norm", (2), bval, local_flag);
	else if change_item = 20 then
	     call scan_key ("deadline,percent,pct,%", (1), bval, local_flag);

	if local_flag = 0 then do;			/* no match with keywords */
	     if prompt_sw then do;			/* but caller insists on getting one */
		call ioa_ ("bad value: ""^a""", char32);
		call ask_$ask_clr;			/* flush typeahead */
		goto ask_key_again;			/* and go insist */
	     end;
	     else flag = -1;			/* caller just wants to know,
						   so say "something there but not what you want" */
	end;

	else					/* there was a match */
	     if ^prompt_sw then do;			/* if caller was not insisting */
	     flag = 1;				/* tell him we found good value */
	     if remove_sw then
		call ask_$ask_c (char32, local_flag);	/* read it again to remove it from the input line */
	end;

	return;

     end ask_key;


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


ask_val: proc (vtype, where, prompt);

dcl  (vtype, where) fixed bin;
dcl  prompt char (*);

	if vtype = 1 then
	     call ask_$ask_int ("^a ", ival (where), prompt);
	else if vtype = 2 then do;
	     call ask_$ask_flo ("^a ", fval (where), prompt);
	     if change_item >= 15 & change_item <= 18 then/* int_resp, int_quantum, resp, or quantum */
		fval (where) = fval (where) * 100e0 + .005e0;
	end;
	else if vtype = 3 then
	     call ask_key (bval (where), prompt);

	return;

     end ask_val;


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


assign_value: proc (vtype, to, from);

dcl  (from, to, vtype) fixed bin;

	if vtype = 1 then
	     ival (to) = ival (from);
	else if vtype = 2 then
	     fval (to) = fval (from);
	else if vtype = 3 then
	     bval (to) = bval (from);

	return;

     end assign_value;


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


change: proc;

/* procedure to implement the change subcommand. it is called by both the
   change and global_change requests. it dechange_codes one change request and makes
   the change (to one entry or all entries of the specified type), and then
   reads the next request. the "." and "*" requests cause exit from the change subcommand */

dcl  i fixed bin;

ask_code: call ask_ ("code ", change_code);
	do i = 1 to hbound (change_codes, 1)
	     while (change_code ^= change_codes (i));
	end;
	if i > hbound (change_codes, 1) then do;	/* not found */
	     call ioa_ ("bad change code: ""^a""", change_code);
change_clr:    call ask_$ask_clr;
	     goto ask_code;
	end;

	change_item = change_items (i);		/* pick up which variable is to be changed */
	change_type = change_types (change_item);	/* and what type it is */

	if change_item = 1 then return;		/* "." or "*" */

/* See of change_code is valid for entry type being changed */

	if change_entry_type (change_item) ^= 0 then do;	/* if change_code is for a header item, it is ok; otherwise, check */
	     if wcsw & change_entry_type (change_item) = 1 then do;
						/* we're changing a work class, but change_code is for groups only */
		call ioa_ ("code ""^a"" is not legal for a work class", change_code);
		goto change_clr;
	     end;

	     else if ^wcsw & change_entry_type (change_item) = 2 then do;
						/* we're changing a group, but change_code is for work classes only */
		call ioa_ ("code ""^a"" is not legal for a load control group", change_code);
		goto change_clr;
	     end;
						/* notice that we fall thru for change_entry_type = 3, which means
						   "valid for both group and work class" */
	end;

	goto ask_type (change_type);			/* go read value(s) from the input line */

ask_type (0):					/* character string */
ask_type (3):					/* yes or no word */
	call ask_ ("^a ", char32, change_names (change_item));

	if change_type = 3 then
	     call ask_yn (bval (1), change_names (change_item));

	goto asked_type;

ask_type (1):					/* float */
ask_type (2):					/* float*10e0 */
	call ask_$ask_flo ("^a ", ftemp, change_names (change_item));

	if change_type = 2 then			/* if float*10e0 */
	     if ftemp > 0e0 then			/* and value is not negative */
		ftemp = ftemp * 10e0;		/* multiply it by 10 */

	goto asked_type;

/* variable format - got to look ahead on the line to see what we have */

ask_type (4):

/* "c absentee" for a group is different from all the other variable format requests

   it can be either of:
   c absentee <yes-or-no value>
   c absentee queue <queue value(s)>|none
*/

	if change_item = 12 & ^wcsw then do;		/* if that's what we have */
ask_abs:	     call ask_ ("""yes"" or ""no"" or ""queue""", char32);
	     if char32 = "queue" then goto abs_q;
	     else if char32 = "q" then do;
abs_q:		call get_int_list ("queue(s)", 4, nval);

		q (*) = "0"b;
		do i = 1 to nval;			/* if nval = 0, q(*) stays = "0"b, which is what we want */
		     if ival (i) <= 0 then goto badq;
		     if ival (i) > 4 then do;
badq:			call ioa_ ("bad absentee queue number: ^d", ival (i));
			call ask_$ask_clr;
			goto abs_q;
		     end;

		     q (ival (i)) = "1"b;
		end;
		default_absentee = "1"b;		/* we are changing this group's default absentee switch */
	     end;

	     else do;				/* changing the absentee allowed bit */
		call ask_cyn (bval (1), itemp);	/* see if yes or no word there */
		if itemp <= 0 then do;		/* not a yes or no word */
		     call ioa_ ("bad value: ^a", char32);
		     call ask_$ask_clr;
		     goto ask_abs;
		end;
		default_absentee = "0"b;		/* we are not changing this group's default absentee switch */
	     end;

	end;					/* end of "c absentee for a group" do group */

/* all the other variable format requests */

	else do;

/* * ITEM	FORMAT ( "[]" denotes an optional argument)
   * 11  	work_class   [shift spec] [int|abs] <integer per-shift work class number values>
   * 12  	absentee     [shift spec] <yes-or-no per-shift absentee-allowed values>
   * 13  	percent      [shift spec] <integer per-shift percent values>
   * 14  	defined      [shift spec] <yes-or-no per-shift work-class-defined values>
   * 15	int_resp     [shift spec] <float*100 per-shift interaction response values>
   * 16	int_quantum  [shift spec] <float*100 per-shift interaction quantum values>
   * 17	resp         [shift spec] <float*100 per-shift steady state response values>
   * 18	quantum      [shift spec] <float*100 per-shift steady state quantum values>
   * 19	mode         [shift spec] <"normal" or "realtime" per-shift mode indicators>
   * 25	max_percent  [shift spec] <integer per-shift governing percent values>
   *
   *  THE ABOVE APPLY SEPARATELY TO EACH WORK CLASS
   *
   *  THE FOLLOWING APPLY TO ALL WORK CLASSES AND ARE STORED IN THE MGT HEADER
   *
   * 20	normal_mode  [shift spec] <"deadline" or "percent" per-shift mode indicators>
   * 21	shifts <list of shift numbers (all of them) in use at the site>  (can be i j k OR m-n OR mixture)
   *
   * There are several comments below, related to whether or not "values" have been typed ahead.
   * These refer only to the values described in "<  >" brackets above.
   * They specifically exclude the shift spec and the int|abs indicators.
   * The significant point here is that, if a list of values is typed ahead, omitted
   * shift specification information takes on default values that are a function
   * of the number of values typed ahead, but if a list of values is not typed ahead,
   * then the shift spec is prompted for and must be given. A different path
   * is taken through the code below in each of these two cases.
   *
   * The default when one value is given is "shift all" (all defined shifts get set to the one value).
   * When a list of values is given, the default is "shift S1" where S1 is the lowest
   * numbered defined shift, and the values are assigned to successive defined shifts, starting with S1.
   *
   *   */

/* set up default shift specification */

	     nshf = 0;				/* no shifts have actually been given by the user */
	     fshift = -1;				/* scan for defined shifts starting after -1 (i.e. at zero) */
	     mxval = 0;				/* initialize counter for defined shifts */
	     call set_default_shift_spec;		/* go count defined shifts and remember their numbers */
						/* mxval now = number of defined shifts
						   (= number of values we can use) */
	     lshift, nshift = 0;			/* only used when shift spec given, but clear garbage anyway */

	     got_shift_spec, got_int_abs, got_values = "0"b;
	     int_wc = "1"b;				/* the default is interactive work class */

look_ahead:    call ask_$ask_n (char32, flag);		/* look at next word without removing it from line */

	     if flag ^= 0 then do;			/* something was typed ahead */

		if ^got_shift_spec & change_item ^= 21
		     & substr (char32, 1, 5) = "shift" then do;
		     call get_shift_spec;
		     goto look_ahead;		/* go look for more typed ahead stuff */
		end;

		else if ^got_int_abs
			& change_item = 11 then do;	/* check for "int" or "abs" */
		     got_int_abs = check_int_abs ();
		     if got_int_abs then goto look_ahead; /* go look for more typed ahead stuff */
		     else goto check_values;		/* go see if this is values */
		end;

		else do;				/* must be values that were typed ahead */
check_values:
		     nval = 0;			/* so we can tell if we got any values */
		     if change_item = 21		/* shifts */
			& ck_int (char32, (0), (0)) then /* and we have shift number(s) */
			call get_int_list (change_names (change_item), (8), nval);
		     else call look_ahead_value (vtypes (change_item), nval);

		     if nval > 0 then got_values = "1"b;
		     else do;
			call ioa_ ("""^a"" unrecognized", char32);
			call ask_$ask_clr;
		     end;

		end;				/* from here, we fall thru to the label "asked_type", without
						   looking for any more type ahead, or prompting for anything */
	     end;					/* end of "there is type ahead" do group */

	     else do;				/* there is no more type ahead */
						/* NOTE: this do group is not entered if values were typed ahead;
						   and note again that "values" do not include the
						   shift_spec or int|abs items */
		if ^got_shift_spec then		/* if shift not already given */
		     call get_shift_spec;		/* go ask user for it */

		if change_item = 11 then		/* if this is "c work_class" */
		     if ^got_int_abs then		/* and int|abs was not already given */
			call get_int_abs;		/* go ask user for it */

/* we know values were not already given, or we would not be here */
		if change_item = 21 then		/* shifts */
		     call get_int_list (change_names (change_item), (8), nval);
		else call get_values (vtypes (change_item), change_names (change_item), nval);

	     end;					/* end "no more type ahead" do group */
	end;					/* end of "all other variable formats" do group */

asked_type:

/* we now have all the info necessary to make a change */

	if gcsw then do;				/* if global change */
	     if wcsw then do;
		gcfirst = 1;
		gclast = 16;
	     end;
	     else do;
		gcfirst = 17;
		gclast = mgt.current_size;
	     end;

	     do i = gcfirst to gclast;
		mgtep = addr (mgt.entry (i));
		call change_one_item;
	     end;
	end;

	else call change_one_item;			/* regular change */

	goto ask_code;

     end change;


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


change_one_item: proc;

/* procedure to change one item in one mgt entry; called in a loop over all
   entries of one type, for the global_change request, or just once, for the change request */

dcl  i fixed bin;

	goto item (change_item);

/* item 1 is a "." or "*" which exits from change without coming here */

item (2): mgt.switches.prio_sked_enabled = bval (1);	/* prio, prio_sked */
	return;

item (3): if ftemp = -1e0 then group.max_prim = -1;	/* maxu, max_prim, maxp */
	else do;
	     call ioa_ ("warning: changing max_prim to value not -1");
	     group.max_prim = ftemp;
	end;
	return;

item (4): group.group_id = char32;			/* id */
	return;

item (5): if ftemp < 0 then group.minamax = 32767;	/* Multics will never get that big ... */
	else group.minamax = ftemp;			/* abs, abs_max, minamax */
	return;

item (6): group.num = ftemp;				/* numerator, num */
	return;

item (7): group.denom = ftemp;			/* denominator, denom, den */
	return;

item (8): group.num1 = ftemp;				/* num1 */
	return;

item (9): group.denom1 = ftemp;			/* denom1, den1 */
	return;

item (10): group.minu = ftemp;			/* constant, const, con */
	return;

item (11): do i = 1 to nshf;				/* work_class, wc */
	     if int_wc then
		group.int_wc (shf (i)) = ival (i);
	     else group.abs_wc (shf (i)) = ival (i);
	end;
	return;

item (12):					/* absentee */
	if ^wcsw then do;				/* c absentee for a group   */
	     if default_absentee then do;
		do i = 1 to 4;
		     group.absentee.default_queue (i) = q (i);
		end;
		if string (group.absentee.default_queue) ^= ""b then /* if it is the default for any queues */
		     group.absentee.default_group = "1"b; /* flag it as a default absentee group */
		else group.absentee.default_group = "0"b; /* otherwise clear possible old value */
	     end;
	     else group.absentee.allowed = bval (1);
	end;

/* items above are all for groups - those below, for work classes */

	else do i = 1 to nshf;			/* item 12 can be for group or work class */
	     if (^gcsw | work_class.switches.defined (shf (i))) then
		work_class.switches.absentee_allowed (shf (i)) = bval (i);
	end;

	return;

item (13): do i = 1 to nshf;				/* percent, pct, % */
	     if (^gcsw | work_class.switches.defined (shf (i))) then
		work_class.min_pct (shf (i)) = ival (i);
	end;
	return;

item (14): do i = 1 to nshf;				/* defined, def */
	     work_class.switches.defined (shf (i)) = bval (i);
	     if mgtix ^= 1 then			/* if we are defining a wc other than 1 */
		mgt.switches.wc_initialized = "1"b;	/* this is no longer a transitional MGT */
	end;
	return;

item (15):					/* int_resp, ir */
item (16):					/* int_quantum, iq */
item (17):					/* resp, r */
item (18):					/* quantum, q */
item (19):					/* mode */

	do i = 1 to nshf;
	     if (^gcsw | work_class.switches.defined (shf (i))) then
		if change_item = 15 then		/* int_resp */
		     work_class.int_response (shf (i)) = fixed (fval (i));
		else if change_item = 16 then		/* int_quantum */
		     work_class.int_quantum (shf (i)) = fixed (fval (i));
		else if change_item = 17 then		/* resp */
		     work_class.response (shf (i)) = fixed (fval (i));
		else if change_item = 18 then		/* quantum */
		     work_class.quantum (shf (i)) = fixed (fval (i));
		else				/* change_item = 19 (mode) */
		     work_class.switches.realtime (shf (i)) = bval (i);
	end;
	return;

item (25):					/* max_percent, max_pct */
	do i = 1 to nshf;
	     if (^gcsw | work_class.switches.defined (shf (i))) then
		work_class.max_pct (shf (i)) = ival (i);
	end;
	return;

item (26):
	call ioa_ ("Page_weight is not yet supported.");
	return;



/* items above are per-work_class items; those below are header items, that apply to all work classes */


item (20):					/* normal_mode, norm */
	do i = 1 to nshf;
	     mgt.switches.deadline_mode (shf (i)) = bval (i);
	end;
	return;

item (21):					/* shifts */
	mgt.shift_defined (*) = ""b;			/* clear list of defined shifts - we have a new one */
	do i = 1 to nval;				/* count of defined shifts is in nval, not nshf */
	     mgt.shift_defined (ival (i)) = "1"b;
	end;
	return;

item (22):					/* absentee_max */
	if ftemp > 3276.6e0 & ftemp < 3276.8e0 then	/* perpetuate an old design error */
	     ftemp = 32767e0;
	group.absentee_max = ftemp;
	return;

item (23):					/* absentee_min */
	group.absentee_min = ftemp;
	return;

item (24):					/* absentee_pct */
	if ftemp < 1e0 then				/* if user typed 0.10 for 10% */
	     ftemp = ftemp * 100e0;			/* multiply by 100, since we store it as an integer */
	group.absentee_pct = ftemp;
	return;


     end change_one_item;


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


ck_int: proc (char_int, f, n) returns (bit (1));

/* procedure to decode a number (or pair of numbers) of the following form:
   n
   m-n

   and return the first value and the number of consecutive values implied by the pair.
   m and n can be any of the digits 0 thru 7 */

dcl  char_int char (*);
dcl  (f, n) fixed bin;
dcl  (i, j) fixed bin;
dcl  digits char (8) int static init ("01234567");

	if substr (char_int, 2) = "" then goto onedigit;
	else if substr (char_int, 4) = "" then goto hyph;
	else goto bad;
onedigit:
	i = index (digits, substr (char_int, 1, 1));	/* look up the digit */
	if i = 0 then goto bad;			/* not one of 0 thru 7 */
	n = 1;					/* one value returned */
	f = i - 1;				/* its value */
	goto good;

hyph:
	if substr (char_int, 2, 1) ^= "-" then goto bad;
	i = index (digits, substr (char_int, 1, 1));	/* scan digits starting at 0 */
	if i = 0 then goto bad;
	j = index (digits, substr (char_int, 3, 1));	/* therefore i and j are 1+ value of digit */
	if j = 0 then goto bad;
	if j < i then goto bad;			/* "6-3" is bad - user must say "3-6" */
	f = i - 1;				/* first value */
	n = j - f;				/* number of values */
						/* for example, "3-6" => f=3,n=4, since i=4,j=7 */

good:	return ("1"b);
bad:	return ("0"b);

     end ck_int;


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


copy_shift: proc (tsh, fsh);

dcl  (fsh, tsh) fixed bin;
dcl  i fixed bin;

	do i = 1 to 16;
	     mgtep = addr (mgt.entry (i));
	     if work_class.switches.defined (fsh) then do;/* only if wc defined on this shift */
		work_class.switches.defined (tsh) = "1"b;
		work_class.switches.absentee_allowed (tsh) = work_class.switches.absentee_allowed (fsh);
		work_class.switches.realtime (tsh) = work_class.switches.realtime (fsh);
		work_class.min_pct (tsh) = work_class.min_pct (fsh);
		work_class.max_pct (tsh) = work_class.max_pct (fsh);
		work_class.int_response (tsh) = work_class.int_response (fsh);
		work_class.int_quantum (tsh) = work_class.int_quantum (fsh);
		work_class.response (tsh) = work_class.response (fsh);
		work_class.quantum (tsh) = work_class.quantum (fsh);
	     end;
	end;

	do i = 17 to mgt.current_size;
	     mgtep = addr (mgt.entry (i));
	     group.int_wc (tsh) = group.int_wc (fsh);
	     group.abs_wc (tsh) = group.abs_wc (fsh);
	end;

	return;

     end copy_shift;


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


default_shift: proc (sh);

dcl  sh fixed bin;
dcl  i fixed bin;

	mgtep = addr (mgt.entry (1));			/* work class 1 is the only one, by default */
	work_class.switches.defined (sh) = "1"b;
	work_class.switches.absentee_allowed (sh) = "1"b;
	work_class.switches.realtime (sh) = ""b;
	work_class.min_pct (sh) = 100;
	work_class.max_pct (sh) = 0;
	work_class.int_response (sh) = 400;
	work_class.int_quantum (sh) = 50;
	work_class.response (sh) = 3200;
	work_class.quantum (sh) = 100;

	call undefine_wc (sh, 2, 16);			/* make sure of no garbage in wc 2-16 */

	do i = 17 to mgt.current_size;
	     mgtep = addr (mgt.entry (i));
	     group.int_wc (sh) = 1;
	     group.abs_wc (sh) = 1;
	end;

	return;

     end default_shift;


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


define: proc;

dcl  (like_sw, redefine_sw, undefine_sw) bit (1) aligned;
dcl  (i, lsh) fixed bin;

	redefine_sw, undefine_sw = ""b;

define_common:
	call get_shift_list (nval);
	if ^undefine_sw then
	     call get_like_shift (lsh, like_sw);

	do i = 1 to nval;				/* shifts to be defined are in ival(1) thru ival(nval) */
	     if redefine_sw | ^shift_is_defined (ival (i)) then do; /* if it's ok to change this shift */
		if undefine_sw then
		     call undefine_shift (ival (i));
		else if like_sw then
		     call copy_shift (ival (i), lsh);
		else call default_shift (ival (i));

		if undefine_sw then mgt.shift_defined (ival (i)) = ""b;
		else mgt.shift_defined (ival (i)) = "1"b;
	     end;

	     else call ioa_ ("shift ^d already defined; use redefine to change it", ival (i));
	end;

	return;

redefine: entry;

	redefine_sw = "1"b;
	undefine_sw = ""b;
	goto define_common;

undefine: entry;

	redefine_sw, undefine_sw = "1"b;
	goto define_common;

     end define;


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


get_int_abs: proc;

/* procedure to read the interactive|absentee specification;
   it may be "interactive", "absentee", "int" or "abs";
   this entry point prompts for it if it was not typed ahead;
   the check_int_abs entry point checks if it was typed ahead,
   if so, reads it and returns "1"b, if not, returns "0"b */

dcl  cksw bit (1) aligned;

	cksw = "0"b;

	call ask_ ("""interactive"" or ""absentee"" ", char32);

int_abs_common:
	if char32 = "interactive" then goto int;
	if char32 = "int" then do;
int:	     int_wc = "1"b;
	     goto exit_ok;
	end;
	else if char32 = "absentee" then goto abs;
	else if char32 = "abs" then do;
abs:	     int_wc = "0"b;
	     goto exit_ok;
	end;
	else do;
	     if cksw then goto exit_ng;		/* go return "0"b */
	     call ioa_ ("bad value: ""^a""", char32);
	     call ask_$ask_clr;
	     goto int_abs_common;			/* insist */
	end;

exit_ng:	return ("0"b);
exit_ok:	if cksw then do;
	     call ask_$ask_c (char32, flag);		/* remove it from the line */
	     return ("1"b);
	end;
	else return;

check_int_abs: entry returns (bit (1));
	cksw = "1"b;
	call ask_$ask_n (char32, flag);
	if flag = 0 then goto exit_ng;		/* nothing typed ahead */
	goto int_abs_common;			/* something there - go see if it is "int" or "abs" */

     end get_int_abs;


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


get_int_list: proc (prompt, mxv, nv);

/* procedure to read a list, prompting for it if not typed ahead;
   the list is of the form:
   i  j  k-l  m  n-o  p  ...
   that is, integers, or pairs of the form m-n;
   m-n pairs are expanded into m m+1 ... n-1 n;

   prompt is the prompting message;
   mxv is the most values the caller wants;
   nv is the actual number of values returned;
   values are returned in ival(1) thru ival(nv).
*/

dcl  prompt char (*);
dcl  (mxv, nv) fixed bin;
dcl  i fixed bin;
dcl  (f, n) fixed bin;

ask_int_list:
	call ask_ ("^a ", char32, prompt);
	nv = 0;					/* initialize counter */
	if char32 = "none" then return;		/* the list is empty */
	if ^ck_int (char32, f, n) then do;		/* bad value */
bad_int:	     call ioa_ ("bad value: ""^a""", char32);
	     call ask_$ask_clr;
	     goto ask_int_list;
	end;

get_int_loop:
	if nv + n > mxv then			/* if m-n pair expands into too many values */
	     goto bad_int;				/* go complain and start over */

	do i = 0 to n - 1;				/* this loop stores values for both m-n pairs and single values */
	     nv = nv + 1;
	     ival (nv) = f + i;
	end;

	if nv = mxv then return;			/* if we have gotten max allowed values */

	call ask_$ask_n (char32, flag);		/* see if anything typed ahead */
	if flag = 0 then return;			/* nothing */
	if ^ck_int (char32, f, n) then return;		/* something, but not right form */
	call ask_$ask_c (char32, flag);		/* right form: read it again to remove it from the line */
	goto get_int_loop;				/* go decode and store it */

     end get_int_list;


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


get_like_shift: proc (sh, sw);

dcl  sh fixed bin;
dcl  sw bit (1) aligned;

	sw = ""b;					/* we have not gotten a "like" shift yet */

	call ask_$ask_n (char32, flag);		/* look for type ahead */
	if flag > 0 then				/* there is some */
	     if char32 = "like" then do;		/* "like" must be typed ahead if it is to be given */
		call ask_$ask_c (char32, flag);	/* get past "like" */
		call ask_$ask_n (char32, flag);	/* see what's next */
		if flag > 0 then			/* something there */
		     if char32 = "shift" then		/* allow "shift" to preceed the number, if typed ahead */
			call ask_$ask_c (char32, flag); /* get past "shift" */

ask_like_shift:
		call ask_$ask_int ("like shift ", sh);	/* ask for one shift number */
		if sh < 0 | sh > 7 then do;
		     call ioa_ ("illegal shift number: ^d", sh);
		     call ask_$ask_clr;
		     goto ask_like_shift;
		end;

		sw = "1"b;			/* we got a like shift */
	     end;

	return;

     end get_like_shift;


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


get_shift_list: proc (nv);

dcl  nv fixed bin;

	call ask_$ask_n (char32, flag);		/* see if any type ahead */
	if flag > 0 then				/* if there is */
	     if substr (char32, 1, 5) = "shift" then	/* allow shift or shifts to be typed ahead */
		call ask_$ask_c (char32, flag);	/* get past it, if there */
ask_shifts:
	call get_int_list ("shifts ", (8), nv);
	if nv = 0 then do;
	     call ioa_ ("some shifts must be given");
	     call ask_$ask_clr;
	     goto ask_shifts;
	end;

	return;

     end get_shift_list;


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


get_shift_spec: proc;

/* procedure to read a shift specification of one of the following forms, returning output as indicated:

   shift n		nshf=1;shf(1)=n;shf(2) thru shf(mxval) = possible other shifts; mxval = how many altogether.
   shift m-n		nshf = number of shifts defined in m-n range;shf(1) thru shf(nshf) = those shifts; mxval = 1.
   shift all		nshf = number of shifts defined at site;shf(1) thru shf(nshf) = those shifts; mxval = 1.

   in all cases, fshift = shf(1); lshift = shf(nshf);nshift = lshift-fshift+1 (=nshf unless gaps in defined shifts)

*/

dcl  (f, n) fixed bin;

ask_shift: call ask_ ("shift(s) ", char32);		/* "shift" is optional if we prompted the user */
	if substr (char32, 1, 5) = "shift" then goto ask_shift; /* but required if he typed ahead */

	nshf = 0;					/* initialize counter of specified shifts */

	if char32 = "all" then do;			/* all defined shifts */
	     do shift = 0 to 7;
		if mgt.shift_defined (shift) then do;	/* is this one defined? */
		     nshf = nshf + 1;		/* if so, count it */
		     shf (nshf) = shift;		/* and remember its number */
		end;
	     end;

	     fshift = shf (1);
	     lshift = shf (nshf);
	     nshift = lshift - fshift + 1;
	end;

	else do;					/* not "all" so better be a shift number or s1-s2 pair */
	     if ^ck_int (char32, f, n) then do;		/* if not an integer or an s1-s2 pair */
		call ioa_ ("bad shift value: ""^a""", char32);
		call ask_$ask_clr;
		goto ask_shift;
	     end;

	     nshift = n;				/* number of shifts */
	     fshift = f;				/* first one */
	     lshift = fshift + nshift - 1;		/* last one */

	     do shift = fshift to lshift;		/* fill in shift numbers in this range */
		if mgt.shift_defined (shift)		/* if shift defined */
		     | shift = fshift | shift = lshift then do; /* or is one of the shifts typed in */
		     nshf = nshf + 1;
		     shf (nshf) = shift;
		end;
	     end;
	end;

	got_shift_spec = "1"b;			/* remember that user gave it and we are not using the default */
	mxval = 1;				/* we expect one value, to be assigned to all specified shifts */

	if nshift > 1 then return;			/* provided that more than one shift (m-n) was specified */
						/* but if only a single shift number was specified, then a list
						   of values can be given, to be assigned to successive defined
						   shifts, starting with the one given */
	mxval = 1;				/* initialize counter of how many values could be given */
						/* and fall thru, past the set default entry point */

set_default_shift_spec: entry;			/* come here to set defaults before seeing what was typed */
						/* a single value is assigned to all defined shifts, by default,
						   while the elements of a list of values are assigned
						   to successive shifts */
	do shift = fshift + 1 to 7;			/* fshift is -1 if we came in at the set default entry */
	     if mgt.shift_defined (shift) then do;	/* find all defined shifts after the specified one */
		mxval = mxval + 1;			/* count them in mxval */
		shf (mxval) = shift;		/* and remember their numbers */
	     end;
	end;


	return;

     end get_shift_spec;


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


get_values: proc (vtype, prompt, nv);

/* procedure to read a list of one or more values, prompting for them if they are not typed ahead.
   vtype is the value type: 1=integer;2=floating point;3=keyword.
   prompt is the prompting message.
   nv is the number of values returned.
   values are returned in one of the arrays: ival, fval, or bval, depending on vtype.

*/

dcl  prompt char (*);
dcl  (nv, vtype) fixed bin;
dcl  i fixed bin;

	call ask_val (vtype, 1, prompt);
	nv = 1;					/* we have at least one value */

	if mxval > 1 then				/* if more than one value allowed */
	     do i = 2 to mxval;			/* see if any more values were given */
	     call ask_$ask_n (char32, flag);		/* look ahead without removing next word from line */
	     if flag ^= 0 & char32 ^= "." & char32 ^= "*" then do; /* if something there, and not terminator char */
		call ask_cval (vtype, i, flag);	/* see if it is of the right data type */
		if flag > 0 then			/* if it is, ask_cval has stored it */
		     nv = nv + 1;			/* count it */
	     end;					/* end something there */
	end;					/* end loop from 2 to mxval */

/* having gotten one or more values, see what we got, and set some variables accordingly */

	if nv > 1 then				/* if more than one value was given */
	     nshf = nv;				/* remember to set exactly that many values */

	else do;					/* only one value was given */
	     if ^got_shift_spec then			/* default is "shift all" when one value given */
		nshf = mxval;			/* so remember to set values for all defined shifts */

	     if nshf > 1 then			/* if we want to assign values for several shifts */
		do i = 2 to nshf;			/* since we got only one value */
		call assign_value (vtype, i, 1);	/* make the right number of copies of it */
	     end;
	end;

	return;

     end get_values;


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


look_ahead_value: proc (vtype, nv);

/* procedure to look ahead on the line for one or more typed ahead values.
   If none there, nv = 0 on return. If at least one there, get_values is called
   to get it, and any others that follow it. Values are returned as described under get_values.

*/

dcl  (nv, vtype) fixed bin;

	nv = 0;					/* until we find something */

	if vtype = 1 then				/* integers */
	     call ask_$ask_nint (itemp, flag);
	else if vtype = 2 then			/* floating points */
	     call ask_$ask_nflo (ftemp, flag);
	else if vtype = 3 then			/* keywords */
	     call ask_nkey (btemp, flag);		/* internal procedure */

	if flag = 1 then				/* if something was there */
	     call get_values (vtype, "", nv);		/* go get it, and others */

	return;

     end look_ahead_value;


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


prgp: proc (zp);

/* procedure to print all information about one group.
   zp is a pointer to the mgt entry containing the group. */

dcl  zp ptr;
dcl  (ctmp1, ctmp2) char (32) aligned, ii fixed bin;
dcl  i fixed bin;
	if zp -> group.minamax < 32767 then call ioa_$rsnnl ("(abs max ^.1f + ^d/^d)", ctmp1, ii,
		zp -> group.minamax / 1e1, zp -> group.num1, zp -> group.denom1);
	else ctmp1 = "";
	if zp -> group.denom ^= 0 then call ioa_$rsnnl ("+ ^d/^d", ctmp2, ii,
		zp -> group.num, zp -> group.denom);
	else ctmp2 = "";
	if zp -> group.max_prim < 0 then call ioa_ ("^/^8a^2x-1 ^a",
		zp -> group.group_id, ctmp1);
	else call ioa_ ("^/^8a^2x^5.1f ^a ^a",
		zp -> group.group_id, zp -> group.minu / 1e1, ctmp2, ctmp1);

	call ioa_ ("int wc: ^8(^d^x^)",
	     zp -> group.int_wc);
	call ioa_ ("abs wc: ^8(^d^x^)",
	     zp -> group.abs_wc);

/* Print lines of the form:
   absentee: max min pct
   .          MX  MN PCT%
*/

	call ioa_ ("absentee:^11tmax^15tmin^19tpct^/^11t^3d^15t^3d^19t^3d%",
	     zp -> group.absentee_max, zp -> group.absentee_min, zp -> group.absentee_pct);

	if zp -> group.absentee.allowed then
	     call ioa_ ("absentee allowed");
	else call ioa_ ("absentee not allowed");
	if zp -> group.absentee.default_group then do;
	     call ioa_$nnl ("default group for queues:");
	     do i = 1 to 4;
		if zp -> group.absentee.default_queue (i) then
		     call ioa_$nnl ("^x^d", i);
	     end;
	     call ioa_ ("");
	end;

	return;

     end prgp;


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


print_ivals: proc (which, heading, fmt, ivals);

dcl  (which, bvals) (0:7) bit (1) unaligned;
dcl  ivals (0:7) fixed bin;
dcl  iflts (0:7) fixed bin (17) unaligned;
dcl  (fmt, heading) char (*);
dcl  scale float bin;
dcl  (i, vtype) fixed bin;

	vtype = 1;
	goto print_common;

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

print_iflt: entry (which, heading, fmt, iflts, scale);

	vtype = 2;
	goto print_common;

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

print_bvals: entry (which, heading, fmt, bvals);

	vtype = 3;
	goto print_common;

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

print_shfs: entry (which, heading, fmt);

	vtype = 4;
	goto print_common;

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

print_ivals_check_zero:
     entry (which, heading, fmt, iflts);

	vtype = 5;

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

print_common:

	call ioa_$nnl (heading);

	do i = 0 to 7;
	     if which (i) then
		if vtype = 1 then
		     call ioa_$nnl (fmt, ivals (i));
		else if vtype = 2 then
		     call ioa_$nnl (fmt, float (iflts (i)) / scale);
		else if vtype = 3 then
		     call ioa_$nnl (fmt, bvals (i));
		else if vtype = 4 then
		     call ioa_$nnl (fmt, i);
		else call ioa_$nnl (fmt, (iflts (i) = 0), iflts (i)); /* vtype must be 5 */
	end;
	call ioa_ ("");

	return;

     end print_ivals;


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


prwc: proc (zp);

/* procedure to print all information about one work class.
   zp is a pointer to the mgt entry containing the work class. */

dcl  zp ptr;

	call ioa_$nnl ("^/^2a", zp -> work_class.wc_name);
	if string (zp -> work_class.switches.defined) = ""b then do;
	     wcundef = "1"b;
	     return;
	end;

	call print_shfs (zp -> work_class.switches.defined, "^xdefined on shifts", "^x^5d");

	call print_bvals (zp -> work_class.switches.defined, "^4xabsentee allowed",
	     "^[^3xyes^;^4xno^]", zp -> work_class.switches.absentee_allowed);

	call print_bvals (zp -> work_class.switches.defined, "^16xmode",
	     "^[^4xrt^;^2xnorm^]", zp -> work_class.switches.realtime);

	call print_ivals (zp -> work_class.switches.defined, "^9xmin percent",
	     "^3x^3d", zp -> work_class.min_pct);

	call print_ivals_check_zero (zp -> work_class.switches.defined, "^9xmax percent",
	     "^[^6x^1s^;^3x^3d^]", zp -> work_class.max_pct);


	call print_iflt (zp -> work_class.switches.defined, "^12xint resp",
	     "^x^5.2f", zp -> work_class.int_response, 100e0);

	call print_iflt (zp -> work_class.switches.defined, "^9xint quantum",
	     "^x^5.2f", zp -> work_class.int_quantum, 100e0);

	call print_iflt (zp -> work_class.switches.defined, "^16xresp",
	     "^x^5.2f", zp -> work_class.response, 100e0);

	call print_iflt (zp -> work_class.switches.defined, "^13xquantum",
	     "^x^5.2f", zp -> work_class.quantum, 100e0);


	return;

     end prwc;


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


pxref: proc;

/* procedure to print a cross reference of groups and work classes.
   NOTE: this code assumes that the mgt passes the "verify" checks, and no
   attempt is made to do anything sensible with an mgt that fails those checks.
   User documentation emphasizes this. */

/* Scan work classes and groups - see which shifts are used,
   and if any groups do not allow absentees (forcing them to be moved to other groups) */

	print_pct_ignored = ""b;			/* turned on if we must print msg explaining asterisk */
	no_abs_count = 0;				/* count the no-absentee groups, if any */
	no_abs = ""b;				/* remember if there are any at all */
	nshift = 0;				/* count shifts used */
	shift_used (*) = ""b;			/* remember which ones are used */

	do i = 1 to 16;				/* go thru work classes */
	     mgtep = addr (mgt.entry (i));		/* get ptr to work class */
	     do shift = 0 to 7;			/* go thru shifts */
		if work_class.switches.defined (shift) then
		     shift_used (shift) = "1"b;
	     end;
	end;

	do shift = 0 to 7;				/* fill in array of shift numbers
						   (for convenience in later code) */
	     if shift_used (shift) then do;
		nshift = nshift + 1;		/* count shifts used */
		shifts (nshift) = shift;		/* and save their numbers */
	     end;
	end;

	do i = 17 to mgt.current_size;		/* go thru groups */
	     mgtep = addr (mgt.entry (i));		/* get ptr to group */
	     if ^group.absentee.allowed then do;	/* if it does not allow absentees */
		no_abs = "1"b;			/* remember that such groups exists */
		no_abs_count = no_abs_count + 1;	/* and count them */
	     end;
	end;

/* Print heading */

	call ioa_$nnl ("^/Work classes defined on shift(s):");
	do i = 1 to nshift;
	     call ioa_$nnl ("^x^d", shifts (i));
	end;
	call ioa_ ("^2/WC^13xGROUP(S)");

/* Initialize for printing cross reference of each shift */

	lshift = -1;				/* we don't print out identical shifts more than once -
						   we just say "like shift N" */
						/* lshift remembers which one it is like, while we see if there
						   are any more like it */
	ival (*) = 0;				/* we use ival to remember which ones we actually printed out */

/* Outer loop on shifts - but only the ones for which work classes are defined */
	do i = 1 to nshift;
	     shift = shifts (i);			/* get actual shift number */

/* Check for this shift being like one we already printed */

	     if lshift >= 0 then do;			/* the previous shift we looked at was like one we printed */
		if shifts_alike (lshift, shift) then	/* if this one is like it too */
		     if i < nshift then		/* and there are more shifts */
			goto next_shift;		/* go look at next one */
		     else i = i + 1;		/* trick to special case the last one, when the
						   last n shifts are alike (code below says "i-1") */
						/* fall thru and print message which includes this shift */

/* This shift is not like the previous one. Print message for previous ones,
   of the form: shift(s) i j k ... like shift N */

		do j = 1 to nshift			/* find index of first shift that was like the one printed */
		     while (shifts (j) ^= fshift);
		end;
		if j = i - 1 then			/* if just one shift like it */
print_one_alike:
		     call ioa_ ("^5xshift ^d like shift ^d", shifts (j), lshift);
		else do;
		     call ioa_$nnl ("^5xshifts");
		     do k = j to i - 1;
			call ioa_$nnl ("^x^d", shifts (k));
		     end;
		     call ioa_ ("^xlike shift ^d", lshift);
		end;

		if i > nshift then goto next_shift;	/* exit, if last n shifts were alike */
	     end;

/* If this shift was not like the previous one, it might still be like one of the others */

	     lshift = -1;				/* start by assuming it isn't */
	     if i > 1 then				/* if there are any others */
		do j = 1 to i - 1;			/* go thru them */
		if ival (shifts (j)) = 1 then		/* only look at ones that were printed */
		     if shifts_alike (shifts (j), shift)/* compare them to this one */
		     then do;			/* if equal */
			lshift = shifts (j);	/* remember the number of the earlier one */
			fshift = shift;		/* and remember that this one is the first one like it */
			if i = nshift then do;	/* special case last one like one other */
			     j = nshift;		/* index of last shift, used for printing it */
			     i = i + 1;		/* force exit from loop */
			     goto print_one_alike;
			end;
			goto next_shift;		/* go look at next one */
		     end;
	     end;

/* if we fall thru here, there is no way we can get out of printing this shift */

	     call ioa_ ("^5xshift ^d", shift);
	     call pxshft (shift);			/* go print it */
	     ival (shift) = 1;			/* and remember that we did so */

next_shift: end;

	if print_pct_ignored then			/* if there was a realtime work class */
	     call ioa_ ("^/* This percent is not counted because the work class is realtime on this shift.");

	return;


/* ********** INTERNAL PROCEDURE WITHIN THIS INTERNAL PROCEDURE ********** */


shifts_alike: proc (s1, s2) returns (bit (1) aligned);

/* procedure to determine whether or not two shifts are alike,
   with respect to work class and load control group definitions */

dcl  (s1, s2) fixed bin;
dcl  i fixed bin;

	     do i = 1 to 16;
		mgtep = addr (mgt.entry (i));
		if work_class.min_pct (s1) ^= work_class.min_pct (s2) then goto diff;
		if work_class.max_pct (s1) ^= work_class.max_pct (s2) then goto diff;
		if work_class.switches.defined (s1) ^= work_class.switches.defined (s2) then goto diff;
		if work_class.switches.absentee_allowed (s1) ^= work_class.switches.absentee_allowed (s2)
		then goto diff;
	     end;
	     do i = 17 to mgt.current_size;
		mgtep = addr (mgt.entry (i));
		if group.int_wc (s1) ^= group.int_wc (s2) then goto diff;
		if group.abs_wc (s1) ^= group.abs_wc (s2) then goto diff;
	     end;
	     return ("1"b);				/* we were unable to find any differences */
diff:	     return ("0"b);				/* something was different */

	end shifts_alike;


     end pxref;


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


pxshft: proc (shift);

/* procedure to print cross reference for one shift */

dcl  shift fixed bin;
dcl  (i, j, igrp, agrp, dfct, colct) fixed bin;
dcl  (int, abs, int_abs_diff) bit (1) aligned;
dcl  print_asterisk bit (1) aligned;


	do i = 1 to 16;				/* go thru work classes, examining and printing each */
	     mgtep = addr (mgt.entry (i));
	     if ^work_class.switches.defined (shift) then goto next_wc; /* skip undefined ones */
	     wcp = mgtep;				/* remember the ptr to it */
	     int_abs_diff = ""b;			/* these are per-work class data */
	     igrp, agrp = 0;
	     default_absentee = "0"b;
	     string (dflt_q) = ""b;
	     do j = 17 to mgt.current_size;		/* pre-scan groups to see what we have to print */
		mgtep = addr (mgt.entry (j));
		if group.int_wc (shift) = i then int = "1"b;
		else int = ""b;
		if ^group.absentee.allowed then goto noabs;
		if group.abs_wc (shift) = i then abs = "1"b;
		else
noabs:		     abs = ""b;

		if ^int & ^abs then			/* if this group does not use the work class we're printing */
		     goto next_group;
		if int ^= abs then int_abs_diff = "1"b;
		if int then igrp = igrp + 1;		/* count interactive groups */
		if abs then agrp = agrp + 1;		/* count absentee groups */
		if group.absentee.default_group then do;/* if this is a default absentee group */
		     default_absentee = "1"b;		/* remember that such a group exists */
		     string (dflt_q) = string (dflt_q) | string (group.absentee.default_queue);
						/* remember which queues have defaults */
		end;
next_group:    end;					/* end of prescan loop over groups */

	     if wcp -> work_class.switches.realtime (shift) then /* if realtime */
		print_pct_ignored, print_asterisk = "1"b; /* remember to say so */
	     else print_asterisk = ""b;		/* otherwise don't */

/* now print the stuff */

	     call ioa_$nnl ("^2d^2x^3d^[*^;%^]^[(^3d)^;^5x^1s^]^2x", i, wcp -> work_class.min_pct (shift),
		print_asterisk, (^print_asterisk & (wcp -> work_class.max_pct (shift) ^= 0)),
		wcp -> work_class.max_pct (shift));


	     if igrp > 0 then do;			/* if any interactive groups in this work class */
		if int_abs_diff then call ioa_$nnl ("int^x");
		else call ioa_$nnl ("i&a^x");
		call pxgrps (igrp, 1);		/* go print igrp interactive groups */
	     end;

	     if agrp > 0 & int_abs_diff then do;	/* if absentees not identical to interactives */
		if igrp > 0 then call ioa_$nnl ("^10xabs^x"); /* if we printed interactives */
		else call ioa_$nnl ("abs^x");
		call pxgrps (agrp, 2);		/* go print agrp absentee groups */
	     end;
	     else if igrp = 0 then			/* if neither interactive nor absentee groups in this wc */
		call ioa_ ("");			/* get back to left margin - last call was to ioa_$nnl */

	     if default_absentee then do;		/* if a default absentee group is in this work class */
		call ioa_$nnl ("^2xq");		/* print which ^2xqueues */
		dfct = 0;
		colct = 0;
		do j = 1 to 4;			/* go over the queues */
		     if dflt_q (j) then do;
			dfct = dfct + 1;
			if dfct = 1 then goto prq;	/* go print q number */
			if j = 4 then do;		/* if last one */
			     j = 5;		/* tricky */
			     goto prq;		/* prq says "j-1" */
			end;
		     end;
		     else if dfct = 1 then dfct = 0;	/* previous q but not this one */
		     else if dfct > 0 then do;	/* previous few queues - print the last one */
prq:
			colct = colct + 2;		/* count cols, for later spacing to next field */
			if dfct > 2 then		/* if more than 2 queues */
			     call ioa_$nnl ("-^d", j - 1); /* print "m-n" */
			else call ioa_$nnl ("^x^d", j); /* just print a queue */
			if dfct > 1 then dfct = 0;	/* previous queues but not this one */
		     end;
		end;

		colct = 11 - colct + 1;		/* number of columns left to get to next field */
		call ioa_$nnl ("^vxdflt", colct);

		call pxgrps (no_abs_count, 3);	/* go print groups whose absentees get put into this work class */
	     end;

next_wc:	end;

/* ********** INTERNAL PROCEDURE WITHIN THIS INTERNAL PROCEDURE ********** */

pxgrps:	proc (ngroups, type);

/* procedure to print ngroups group names, that fit into the
   category specified by type. type can be 1, 2, or 3, indicating
   interactive, absentee, and default absentee groups, respectively.
   names are printed four per line, starting in column 16 */

dcl  (ngroups, type) fixed bin;
dcl  (lct, gct) fixed bin;

	     gct, lct = 0;				/* initialize group and groups-per-line counters */
	     do j = 17 to mgt.current_size;
		mgtep = addr (mgt.entry (j));
		if type = 1 then do;		/* interactive */
		     if group.int_wc (shift) = i then goto prgp;
		     else goto skip_grp;
		end;
		else if type = 2 then do;		/* absentee */
		     if group.abs_wc (shift) = i then goto prgp;
		     else goto skip_grp;
		end;
		else if type = 3 then do;		/* default absentee */
		     if ^group.absentee.allowed then	/* if absentees not allowed in this group */
			goto prgp;		/* they will have to be moved to a default absentee group */
		     else goto skip_grp;
		end;

prgp:		gct = gct + 1;			/* count groups printed */
		lct = lct + 1;			/* count groups on this line */
		if lct >= 5 then do;
		     lct = 1;
		     call ioa_$nnl ("^/^14x");
		end;
		call ioa_$nnl ("^x^8a", group.group_id);

skip_grp:		if gct >= ngroups then goto ret;	/* quit as soon as all groups are printed */
	     end;
ret:	     if lct > 0 | gct = 0 then call ioa_ ("");	/* carriage return, if we have printed part of a line */
	     return;
	end pxgrps;



     end pxshft;


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


scan_key: proc (keys, comma_count, bval, flag);

dcl  keys char (*);
dcl  key char (32) varying;
dcl  (comma_count, flag) fixed bin;
dcl  bval bit (1) aligned;
dcl  (comma_offset, curpos, keypos, kln, ln, n_commas) fixed bin;

	kln = length (keys);
	ln = length (char32) + 1 - verify (reverse (char32), " "); /* 1 nonblank gives 32+1-32=1 */

/* See if given keyword is one of the legal ones, and if so, get its position in the set of legal ones */

	key = "," || substr (char32, 1, ln) || ",";	/* to force match only on word delimited by commas */
	if keys = substr (key, 2, kln) then keypos = 1;	/* trivial case - only one legal keyword */
	else if ln + 1 > kln then keypos = 0;		/* keyword plus one comma longer than keys - no match possible */
	else if substr (keys, 1, ln + 1) = substr (key, 2, ln + 1) then /* first legal keyword has no leading comma */
	     keypos = 1;
	else if substr (keys, kln - ln, ln + 1) = substr (key, 1, ln + 1) then /* last one has no trailing comma */
	     keypos = kln - ln + 1;
	else if ln + 2 > kln then keypos = 0;		/* keyword plus two commas too long - no match possible */
	else do;					/* scan for match within legal keyword string */
	     keypos = index (keys, key);
	     if keypos > 0 then			/* if we found a match */
		keypos = keypos + 1;		/* move past the leading comma */
	end;

	if keypos = 0 then				/* if no match */
	     flag = 0;				/* tell caller, and do nothing else */

	else do;					/* keyword legal, so see if it corresponds to "1"b or "0"b */
	     flag = 1;				/* tell caller */
	     n_commas = 0;				/* count commas before the matching key */
	     curpos = 1;				/* start at beginning of first key */
	     do while (curpos < keypos);		/* keep looking until we hit the matching key */
		comma_offset = index (substr (keys, curpos, keypos - curpos), ","); /* look for comma */
		if comma_offset > 0 then do;		/* if we found one */
		     n_commas = n_commas + 1;		/* count it */
		     curpos = curpos + comma_offset;	/* move past it */
		end;
	     end;					/* fall thru when curpos >= keypos */

	     if n_commas < comma_count then		/* if the matching key is in the first half */
		bval = "1"b;			/* the keyword corresponds to "1"b */
	     else bval = "0"b;			/* if in the second half, "0"b */

	end;

	return;

     end scan_key;


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


shift_is_defined: proc (sh) returns (bit (1) aligned);

dcl  sh fixed bin;
dcl  i fixed bin;

	do i = 1 to 16				/* look thru all work classes */
	     while (^addr (mgt.entry (i)) -> work_class.switches.defined (sh));
	end;					/* to see if any are defined on the specified shift */

	if i <= 16 then				/* if any are */
	     return ("1"b);				/* say yes */
	else return (""b);				/* else say no */

     end shift_is_defined;

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


undefine_shift: proc (sh);

dcl  sh fixed bin;
dcl  i fixed bin;

	call undefine_wc (sh, 1, 16);			/* undefine work classes 1-16 on this shift */
	do i = 17 to mgt.current_size;		/* undefine all groups on this shift */
	     mgtep = addr (mgt.entry (i));
	     group.int_wc (sh) = 0;
	     group.abs_wc (sh) = 0;
	end;

	return;

     end undefine_shift;


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


undefine_wc: proc (sh, ft, lt);

dcl  (ft, lt, sh) fixed bin;
dcl  i fixed bin;

	do i = ft to lt;
	     mgtep = addr (mgt.entry (i));
	     work_class.switches.defined (sh) = ""b;
	     work_class.switches.absentee_allowed (sh) = ""b;
	     work_class.switches.realtime (sh) = ""b;
	     work_class.min_pct (sh) = 0;
	     work_class.max_pct (sh) = 0;
	     work_class.int_response (sh) = 0;
	     work_class.int_quantum (sh) = 0;
	     work_class.response (sh) = 0;
	     work_class.quantum (sh) = 0;
	end;

	return;

     end undefine_wc;


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


verify_mgt: proc;

/* procedure to verify the correctness and consistency of the mgt,
   and report all errors it finds */

dcl  err_max fixed bin init (5);
dcl  err_count fixed bin init (0);
dcl  warning_printed bit (1) aligned;
dcl  wc_printed bit (1) aligned;
dcl  low_pct (0:7) bit (1) aligned;
dcl  unused_pct (0:7) bit (1) aligned;
dcl  print_unused_pct bit (1) aligned;
dcl  pct_is_used bit (1) aligned;
dcl  wc_empty (0:7, 16) bit (1) aligned;

	wc_empty = ""b;				/* array initializations */
	low_pct = ""b;

	call ask_$ask_cint (itemp, flag);		/* check for optional max error count */
	if flag > 0 then err_max = itemp;		/* if given, override default with it */

/* The following code makes the same correctness tests that up_mgt_ makes, but when it
   finds an error, it reports it in more detail, and keeps going instead of quitting at the first error. */


	do shift = 0 to 7;				/* check consistency on each shift */

	     shift_used (shift) = ""b;		/* remember which shifts are used */
	     shift_pct = 0;				/* sum of percentages */
	     no_abs = ""b;
	     string (dflt_q) = ""b;			/* keep track of absentee groups */
	     unused_pct (shift) = ""b;		/* keep track of pcts unused because of
						   deadline or realtime scheduling */

	     do i = 1 to 16;			/* first go thru work classes */
						/* checking if defined, and adding up percentages */
		wcp = addr (mgt.entry (i));
		if wcp -> work_class.switches.defined (shift) then do; /* if defined */
		     wc_empty (shift, i) = "1"b;	/* since wc defined on shift, see if it is used */
						/* assume it is not used until we see that it is */
		     shift_used (shift) = "1"b;	/* at least one is, on this shift */

		     if mgt.switches.deadline_mode (shift) | wcp -> work_class.switches.realtime (shift) then do;
			pct_is_used = ""b;		/* remember not to count this one's percent */
			unused_pct (shift) = "1"b;	/*  remember to explain, if % < 100 on this shift */
		     end;
		     else pct_is_used = "1"b;		/* remember to add in this one's percent */
		     if wcp -> work_class.min_pct (shift) <= 0 then do;
			call ioa_ ("bad percent (^d) for work class ^d on shift ^d",
			     wcp -> work_class.min_pct (shift), i, shift);
			if ^pct_is_used then
			     call ioa_ ("(percent is ignored for realtime workclass, but must be > 0 to install MGT.)");
			call count_error;
		     end;

		     if wcp -> work_class.max_pct (shift) < 0 | wcp -> work_class.max_pct (shift) > 100 then do;
			call ioa_ ("bad max percent (^d) for work class ^d on shift ^d",
			     wcp -> work_class.max_pct (shift), i, shift);
			call count_error;
		     end;

		     call check_rq (wcp -> work_class.int_quantum (shift), "010"b); /* resp=0;int=1;realtm=0 */
		     call check_rq (wcp -> work_class.quantum (shift), "000"b); /* resp=0;int=0;realtm=0 */
		     if wcp -> work_class.switches.realtime (shift) then do; /* if realtime work class */
			call check_rq (wcp -> work_class.int_response (shift), "111"b); /* resp=1;int=1;realtm=1 */
			call check_rq (wcp -> work_class.response (shift), "101"b); /* resp=1;int=0;realtm=1 */
		     end;

		     if pct_is_used then		/* except for realtime work classes */
			shift_pct = shift_pct + wcp -> work_class.min_pct (shift); /* add up percentages */
		end;
	     end;					/* end loop on work classes */
	     if shift_pct > 100 then do;
		call ioa_ ("sum of work class percents > 100 (^d) on shift ^d", shift_pct, shift);
		call count_error;
	     end;
	     else if shift_used (shift) then
		if shift_pct < 100 then
		     low_pct (shift) = "1"b;

	     do i = 17 to mgt.current_size;		/* now go thru all groups */
		mgtep = addr (mgt.entry (i));

		if ^shift_used (shift) then do;	/* if no work classes defined on this shift */
		     if group.int_wc (shift) ^= 0 then call shift_err_int; /* there better be no work classes used */
		     if group.abs_wc (shift) ^= 0 then call shift_err_abs;
		end;

		else do;				/* some work classes are defined */
		     wc_empty (shift, group.int_wc (shift)) = "0"b; /* not empty */
		     wcp = addr (mgt.entry (group.int_wc (shift)));
		     if ^wcp -> work_class.switches.defined (shift) then /* see if this one is */
			call shift_err_int;		/* and complain if not */

		     if group.absentee.allowed then do; /* if absentees allowed in this group */
			wc_empty (shift, group.abs_wc (shift)) = "0"b; /* not empty */
			wcp = addr (mgt.entry (group.abs_wc (shift)));
			if ^wcp -> work_class.switches.defined (shift) then
						/* make sure their work class is defined */
			     call shift_err_abs;	/* and complain if not */
			if ^wcp -> work_class.switches.absentee_allowed (shift) then do;
			     call ioa_ ("group ""^a"" absentees on shift ^d are in work class ^d,
but that work class does not allow absentees", group.group_id, shift, group.abs_wc (shift));
			     call count_error;
			end;

			if group.absentee.default_group then do; /* if this is a default group for some queue(s) */
			     do j = 1 to 4;		/* go thru queues */
				if group.absentee.default_queue (j) then /* if it is for this queue */
				     if dflt_q (j) then do; /* but there already is one */
					call ioa_ ("more than one default group for absentee queue ^d:
group ""^a"" is an additional one (group ""^a"" is the first one)", j, group.group_id,
					     addr (mgt.entry (dflt_g (j))) -> group.group_id);
					call count_error;
				     end;

				     else do;	/* otherwise, remember that we have a default for this queue */
					dflt_q (j) = "1"b;
					dflt_g (j) = i;
				     end;		/* and remember which group, for possible error message */
			     end;
			end;
		     end;				/* end absentee allowed */

		     else do;			/* absentee not allowed in this group */
			no_abs = "1"b;		/* remember that there is such a group */
			if group.absentee.default_group then do;
			     call ioa_ ("group ""^a"" does not allow absentees, but is given as the default
group for absentee queue ^d", group.group_id, j);
			     call count_error;
			end;
		     end;				/* end absentees not allowed */
		end;				/* end some work classes defined on this shift */
	     end;					/* end loop thru all groups */

	     if no_abs then				/* if a no-absentee group exists */
		if string (dflt_q) ^= "1111"b then do;	/* and there are not default groups for all queues */
		     do j = 1 to 4;			/* print message for each queue */
			if ^dflt_q (j) then do;
			     call ioa_ ("There is no default group for absentee queue ^d, but there is a
group that does not allow absentees", j);
			     call count_error;
			end;
		     end;
		end;

	end;					/* end loop on shifts */

	do i = 17 to mgt.current_size;		/* make a last pass thru groups, checking group only parameters */
	     mgtep = addr (mgt.entry (i));
	     if group.absentee_pct < 0 | group.absentee_pct > 100 then do;
		call ioa_ ("illegal absentee percent (^d%) for group ""^a""",
		     group.absentee_pct, group.group_id);
		call count_error;
	     end;

	     if group.absentee_min > group.absentee_max then do;
		call ioa_ ("absentee_min (^d) greater than absentee_max (^d) for group ""^a""",
		     group.absentee_min, group.absentee_max, group.group_id);
		call count_error;
	     end;

	     if group.absentee_max < 0 then do;
		call ioa_ ("absentee_max (^d) for group ""^a"" is negative.", group.absentee_max, group.group_id);
		call count_error;
	     end;
	end;

	if err_count = 0 then
	     call ioa_ ("No errors");
	else call ioa_ ("^d errors - the mgt can not be installed", err_count);

/* Check for suspicious-looking conditions, that are not fatal errors,
   but are likely to be oversignts on the part of the user */

	warning_printed = "0"b;			/* remember that we have not printed a heading line */
	print_unused_pct = ""b;			/* stays off unless we print a * beside some shift */

	do shift = 0 to 7;				/* check for sum of percents < 100% on any shift */
	     if low_pct (shift)			/* look for first such shift */
		& ^mgt.switches.deadline_mode (shift) then do; /* except realtime shifts, whose pcts aren't used */
		call print_warning;			/* go print heading, if not already done */
		call ioa_$nnl ("Sum of work class percents is < 100% on shift(s):");
		do shift = shift to 7;		/* go thru shifts from this one to last */
		     if low_pct (shift) then do;
			call ioa_$nnl ("^x^d^[*^]", shift, unused_pct (shift));
			if unused_pct (shift) then print_unused_pct = "1"b; /* remember to explain the * */
		     end;
		end;
		if print_unused_pct then		/* if we put asterisks beside some shifts, explain them */
		     call ioa_
			("^/* There are realtime work classes in this shift; their percents are not counted.");
		call ioa_ ("");
	     end;
	end;					/* inner loop runs the index of this one out to its limit */

	wc_printed = ""b;				/* remember we have not printed wc heading */
	do shift = 0 to 7;				/* check for wc with no groups in it */
	     do i = 1 to 16;
		if wc_empty (shift, i) then do;	/* search for first such occurrence */
		     call print_warning;
		     if ^wc_printed then do;
			wc_printed = "1"b;
			call ioa_ ("The following work class(es) are unused on the indicated shifts");
		     end;
		     call ioa_$nnl ("shift ^d:  ", shift);
		     do i = i to 16;		/* go thru work classes from this one to last */
			if wc_empty (shift, i) then
			     call ioa_$nnl ("^x^d", i);
		     end;
		     call ioa_ ("");
		end;
	     end;					/* inner loop runs the index of this one out to its limit */
	end;					/* end loop on shifts */

	do shift = 0 to 7;
	     do i = 1 to 16;
		wcp = addr (mgt.entry (i));
		if wcp -> work_class.switches.defined (shift) &
		     ^wcp -> work_class.switches.realtime (shift) then do;
		     call check_rq (wcp -> work_class.int_response (shift), "110"b);
		     call check_rq (wcp -> work_class.response (shift), "100"b);
		end;
	     end;
	end;

	do i = 17 to mgt.current_size;		/* check for reasonable absentee user limits */
	     mgtep = addr (mgt.entry (i));
	     if group.absentee_max = 0		/* if max is zero */
		& ^(group.absentee_min = 0		/* and min and percent are not */
		& group.absentee_pct = 0) then do;	/* both zero, no absentee jobs for the group can log in */
		call print_warning;			/* print warning heading if not already done */
		call ioa_ ("group ""^a"": absentee_max=^d, absentee_min=^d, absentee_pct=^d%, so jobs from this group will never log in.",
		     group.group_id, group.absentee_max, group.absentee_min, group.absentee_pct);
	     end;
	end;

verify_exit: return;

/* ********** INTERNAL PROCEDURES WITHIN THIS INTERNAL PROCEDURE ********** */


check_rq: proc (val, sw);				/* check response and quantum values */

dcl  val fixed bin (17) unaligned;
dcl  sw bit (3) unaligned;
dcl  resp bit (1) unaligned defined (sw) pos (1);
dcl  int bit (1) unaligned defined (sw) pos (2);
dcl  realtm bit (1) unaligned defined (sw) pos (3);

	     if val > 0 then return;			/* positive value is ok for anything */
	     if resp & val = 0 then return;		/* zero is ok for realtime response */
						/* quantum must always be >0 */
						/* realtime response must >= 0 */
						/* nonrealtime response should be >= 0,
						   but we only give warning if it is negative */

	     if resp & ^realtm then			/* if just a warning */
		call print_warning;			/* tell user so */
	     else call count_error;			/* otherwise increment fatal error count */

	     call ioa_ ("^[^;zero or ^]negative ^[int_^]^[response^;quantum^] (^.2f) for ^[realtime ^]work class ^d on shift ^d",
		realtm, int, resp, float (val) / 100e0, realtm, i, shift);

	     return;

	end check_rq;


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

print_warning: proc;

	     if ^warning_printed then do;
		call ioa_ ("Warnings (will not prevent installation of MGT):");
		warning_printed = "1"b;
	     end;
	     return;

	end print_warning;

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

shift_err_int: proc;
dcl  wc fixed bin;
dcl  ia char (11);					/* interactive or absentee */
	     wc = group.int_wc (shift);
	     ia = "interactive";
shift_err_common:
	     if wc = 0 then
		call ioa_ ("^a work class of group ""^a"" on shift ^d is undefined (=0),
but work classes are defined on that shift", ia, group.group_id, shift);
	     else call ioa_ ("work class ^d is undefined on shift ^d but is used by group ""^a"" (^a)",
		     wc, shift, group.group_id, ia);
	     call count_error;
	     return;
shift_err_abs: entry;
	     wc = group.abs_wc (shift);
	     ia = "absentee";
	     goto shift_err_common;
	end shift_err_int;

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

count_error: proc;
	     err_count = err_count + 1;
	     if mod (err_count, err_max) = 0 then do;
		call ask_$ask_yn ("^d errors - do you wish to continue? ", char32, err_count);
		if char32 = "no" then goto verify_exit; /* nonlocal goto */
	     end;
	     return;
	end count_error;

     end verify_mgt;

initialize_mgt:
     procedure;

dcl  wcx fixed bin;

	mgt.author.proc_group_id = get_group_id_ ();
	mgt.table = "MGT";
	mgt.w_dir = get_wdir_ ();
	mgt.max_size = hbound (mgt.entry, 1);
	mgt.current_size = 17;			/* start with WCTE's */
	mgt.total_units = 0;
	mgt.version_indicator = "VERSION ";
	mgt.version = MGT_version_3;
	mgt.wc_initialized = "0"b;
	mgt.prio_sked_enabled = "1"b;
	mgt.prio_sked_on_tape = "1"b;
	do wcx = 1 to 16;
	     mgtep = addr (mgt.entry (wcx));
	     work_class.wc_name = ltrim (char (wcx));
	end;

	string (mgt.user_wc_defined) = "100000000000000"b;
	string (mgt.shift_defined) = (8)"1"b;		/* define all shifts */
	mgt.user_wc_min_pct = 100;

/**** We will define one work-class and one group */

	mgtep = addr (mgt.entry (1));
	work_class.switches.defined (*) = "1"b;		/* defined on all shifts */
	work_class.switches.absentee_allowed (*) = "1"b;	/* with absentee allowed */
	work_class.min_pct (*) = 100;			/* and getting all the time */
	work_class.min_pct (*) = 100;
	work_class.int_response (*) = 400;
	work_class.int_quantum (*) = 50;
	work_class.response (*) = 3200;
	work_class.quantum (*) = 100;

	mgtep = addr (mgt.entry (17));

	group.group_id = "Other";
	group.max_prim = -1;
	group.int_wc = 1;
	group.abs_wc = 1;
	group.absentee.allowed = "1"b;
	group.absentee_max = 1000;
	group.absentee_pct = 100;
	return;
     end initialize_mgt;

clean_up:
     procedure;

	if mgtp ^= null () then call release_temp_segment_ (ME, mgtp, (0));
	if mgtp1 ^= null () then if created_new_mgt then
		call terminate_file_ (mgtp1, (0), TERM_FILE_DELETE, (0));
	     else call terminate_file_ (mgtp1, 36 * (64 + mgtp1 -> mgt.current_size * 32), TERM_FILE_TRUNC_BC_TERM, (0));
	return;
     end clean_up;
     end ed_mgt;




		    get_uid_with_lastname.pl1       10/27/83  1614.3rew 10/27/83  1441.8       20583



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


get_uid_with_lastname: procedure (Name);

declare  Name character (*) parameter;

/* Originally written April 1971 by K. Willis. */
/* Rewritten for new URF format July 1979 by C. Hornig. */

/* This procedure lists all users with a given last name. */

%include urf_entry;

declare  ME character (32) init ("get_uid_with_lastname") static options (constant);

declare (error_table_$bad_index,
         error_table_$no_record) fixed bin (35) external;

declare  cu_$arg_count entry returns (fixed bin),
         urf_manager_$get_abs_entry entry (fixed bin (35), character (*), pointer, fixed bin (35)),
        (ioa_, com_err_) entry options (variable);

declare  code fixed bin (35),
         rec fixed bin (35),
         count fixed bin (35),
         uid character (32),
         1 urfe aligned like urf_entry;

declare  addr builtin;

/* * * * * * * * * * GET_UID_WITH_LASTNAME * * * * * * * * * */

	if cu_$arg_count () ^= 1 then do;
	     call com_err_ (0, ME, "Usage: get_uid_with_lastname <last-name>");
	     return;
	end;

	count = 0;
	do rec = 1 by 1;
	     call urf_manager_$get_abs_entry (rec, uid, addr (urfe), code);
	     if code ^= error_table_$no_record
	     then if code ^= 0
		then do;
		     if code ^= error_table_$bad_index
		     then call com_err_ (code, ME);
		     else if count = 0
		     then call ioa_ ("No users found with last name of ""^a"".", Name);
		     else call ioa_ ("^d users found with last name of ""^a"".", count, Name);
		     return;
		end;
		else if ((substr (urfe.last_name, 1, 1) = "*")
		& (substr (urfe.last_name, 2) = Name))
		| (urfe.last_name = Name)
		then do;
		     call ioa_ ("User ID for ^a, ^a is ""^a"".", urfe.last_name, urfe.first_name, uid);
		     count = count + 1;
		end;
	end;
     end get_uid_with_lastname;




		    get_user_.pl1                   07/13/88  1112.5r w 07/13/88  0942.4       40293



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

/* program to return the name and project of each user registered on the Multics system */

/* j m grochow 		7/23/70 */

/* upgraded to version II pl1 and
   modified for new SAT / PDT formats by Janice B. Phillipps, March 1972 */

guinit: proc(dirname, code);

dcl ( (satp,					/* pointer to the sat */
     satep,
     pdtep,
     pdtp) ptr,					/* pointer to the pdt */
    (satsize,					/* current size of the sat */
     satindex,					/* where are we now */
     pdtsize,					/* current size of the pdt */
     pdtindex) fixed bin,				/* where are we now */
    (projectname char(9),				/* save the current projectname */
     dirnamepdt char(168)) aligned			/* directory name which contains pdt's */
     ) internal static;				/* all internal static */

dcl  ioa_ external entry options(variable),
     com_err_ external entry options (variable),
     hcs_$initiate external entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1), fixed bin (2),
     ptr, fixed bin),
     hcs_$terminate_noname external entry (ptr, fixed bin);

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

dcl  p ptr,
     i fixed bin;


dcl (person, proj) char(*);
dcl  dirname char(*) aligned;
dcl  code fixed bin;

%include user_attributes;
%include sat;
%include pdt;



/* ======================================================== */

	call hcs_$initiate(dirname, "sat", "", 0, 1, satp, code);
	if satp = null then do;
	     if code = 0 then code = 1;
	     return;
	end;

	if satp -> sat.version ^= SAT_version then do;
	     call com_err_ (0, "get_user_", "SAT version is inconsistent with declarations used by this program.");
	     return;
	end;


	satsize = satp->sat.current_size;
	satindex = 1;

	dirnamepdt = dirname;
	substr(dirnamepdt, index(dirnamepdt, " "), 4) = ">pdt";
	call initpdt;				/* get the first pdt */

	return;

get_user_: entry(person, proj);

beginloop: do i = pdtindex to pdtsize;

	     p = addr(pdtp->pdt.user(i));

	     if p->user.state = 0 then go to endloop;

	     person = p->user.person_id;		/* person's name */
	     proj = projectname;			/* the current project */

	     pdtindex = i+1;
	     return;

endloop:	end;

/* if we fall through, get another pdt */

	call hcs_$terminate_noname (pdtp, code);	/* terminate the current pdt */
	call initpdt;
	if projectname = " " then do;			/* no more pdt's */
	     person = " ";
	     proj = " ";
	     call hcs_$terminate_noname (pdtp, code);	/* terminate last pdt */
	     call hcs_$terminate_noname (satp, code);	/* terminate sat */

	     return;
	end;

	go to beginloop;


/* internal entry to get another pdt */

initpdt:	proc;

dcl  projfile char(32) aligned,			/* name of project pdt file */
     code fixed bin;				/* for error codes */
dcl  com_err_ external entry options (variable);

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

	     do i = satindex to satsize;

		p = addr(satp->sat.project(i));

		if p->project.state = 0 then go to endloop1;

		projfile = substr(p->project.project_id, 1, index(p->project.project_id, " ")-1)||".pdt";

		call hcs_$initiate(dirnamepdt, projfile, "", 0, 1, pdtp, code);
		if pdtp = null then do;
		     call ioa_("The following pdt could not be initiated: ^a>^a", dirnamepdt, projfile);
		     go to endloop1;
		end;

		if pdtp -> pdt.version ^= PDT_version then do;
		     call com_err_ (0, "get_user_", "PDT version is inconsistent with the declarations used by this program.");
		     return;
		end;

		projectname = p->project.project_id;
		pdtsize = pdtp->pdt.current_size;
		pdtindex = 1;

		satindex = i+1;
		return;

endloop1:      end;

/* if we fall through, no more pdt's */

	     projectname = " ";

	     return;

	end initpdt;

     end guinit;




		    get_userid_.pl1                 07/13/88  1112.5r w 07/13/88  0938.6       42750



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

/* format: style4 */
get_userid_: proc (procid, pers, proj, type, anon, ecode);

/* GET_USERID_ - program to find out who a user is, given process id. */
/* Modified November 1981, E. N. Kittlitz.  user_table_entry conversion. */


/****^  HISTORY COMMENTS:
  1) change(87-04-26,GDixon), approve(87-07-09,MCR7741),
     audit(87-05-06,Parisek), install(87-08-04,MR12.1-1055):
     Upgraded for change to answer_table.incl.pl1 and user_table_entry.incl.pl1
  2) change(87-05-31,GDixon), approve(87-07-09,MCR7719),
     audit(87-07-13,Hartogs), install(87-08-04,MR12.1-1055):
     Add $info entrypoint.
                                                   END HISTORY COMMENTS */


dcl  procid bit (36),				/* input process id */
     pers char (*),					/* output person id */
     proj char (*),					/* output project id */
     tag char (*),					/* output instance tag */
     process_type fixed bin,				/* output process type */
     abs_queue fixed bin,				/* output absentee queue, 0 = fg */
     type fixed bin,				/* 0 = interactive, -1 daemon, >0 abs queue */
     anon fixed bin,				/* 1 if anonymous, else 0 */
     ecode fixed bin (35);

dcl  ec fixed bin (35),
     i fixed bin,
     info_entry bit(1);

dcl (static_ansp, static_autp, static_dutp) ptr int static init(null);

dcl  sysdir char (64) aligned int static options(constant) init (">system_control_dir");

dcl (addr, null) builtin;

dcl  hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned,
	fixed bin (1), fixed bin (2), ptr, fixed bin (35));

dcl  error_table_$noentry fixed bin(35) ext static;

/* --------------------------------------------- */

	info_entry = "0"b;
	go to JOIN;
	
info:	entry (procid, pers, proj, tag, process_type, anon, abs_queue, ecode);

	info_entry = "1"b;
	
JOIN:	ecode = 0;
	if static_ansp = null then
	     call hcs_$initiate (sysdir, "answer_table", "", 0, 1, static_ansp, ec);
	if static_autp = null then 
	     call hcs_$initiate (sysdir, "absentee_user_table", "", 0, 1, static_autp, ec);
	if static_dutp = null then
	     call hcs_$initiate (sysdir, "daemon_user_table", "", 0, 1, static_dutp, ec);

	ansp = static_ansp;
	autp = static_autp;
	dutp = static_dutp;

	if ansp = null & autp = null & dutp = null then do;
	     ecode = ec;
	     return;
	end;

	if ansp ^= null then do;
	     do i = 1 to anstbl.current_size;
		utep = addr (anstbl.entry (i));
		if ute.active >= NOW_HAS_PROCESS then do;
		     if ute.proc_id = procid then do;
			pers = ute.person;
			proj = ute.project;
			if info_entry then do;
			     tag = ute.tag;
			     process_type = ute.process_type;
			     abs_queue = 0;
			end;
			else type = ute.queue;
			anon = ute.anonymous;
			return;
		     end;
		end;
	     end;
	end;

	if autp ^= null then do;			/* check access to table */
	     do i = 1 to autp -> autbl.current_size while (autp -> autbl.n_abs_run > 0);
		utep = addr (autp -> autbl.entry (i));
		if ute.active >= NOW_HAS_PROCESS then do;
		     if ute.proc_id = procid then do;
			pers = ute.person;
			proj = ute.project;
			if info_entry then do;
			     tag = ute.tag;
			     process_type = ute.process_type;
			     abs_queue = ute.queue;
			end;
			else type = ute.queue;
			anon = ute.anonymous;
			return;
		     end;
		end;
	     end;
	end;					/* end of autbl search */

	if dutp ^= null then do;
	     do i = 1 to dutbl.current_size;
		utep = addr (dutbl.entry (i));
		if ute.active >= NOW_HAS_PROCESS then do;
		     if ute.proc_id = procid then do;
			pers = ute.person;
			proj = ute.project;
			if info_entry then do;
			     tag = ute.tag;
			     process_type = ute.process_type;
			     abs_queue = 0;
			end;
			else type = ute.queue;
			anon = ute.anonymous;
			return;
		     end;
		end;
	     end;
	end;					/* end daemon table search */

	ecode = error_table_$noentry;

%page; %include absentee_user_table;
%page; %include answer_table;
%page; %include daemon_user_table;
%page; %include dialup_values;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;

     end get_userid_;




		    hash_table.pl1                  10/27/83  1614.3rew 10/27/83  1441.9       88920



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

hash_table: proc;					/* originally coded by k.willis 2/71 */



%include hashst;



dcl  htp pointer;					/* hash table pointer */
dcl  buffer char (152),				/* input buffer string */
     1 input based (ip),				/* input character array-overlays buffer */
     2 line (0: 151) char (1) unaligned,
    (ip, q, ap) pointer,
     abuffer char (152) aligned,
     bit_count fixed bin (24),			/* number of bits in hash table */
     len fixed bin,					/* length of argument from console */
     more_needed bit (1),				/* switch that indicates expected argument when on */
    (val, i, j, count, ec, al, buckets) fixed bin,
     bc fixed bin init (152),				/* number of characters in input line */
     hash_$in entry (ptr, char (*) aligned, fixed bin, fixed bin),
     hash_$out entry (ptr, char (*) aligned, fixed bin, fixed bin),
     hash_$search entry (ptr, char (*) aligned, fixed bin, fixed bin),
     hash_$make entry (ptr, fixed bin, fixed bin),
     ios_$read_ptr entry (ptr, fixed bin (17), fixed bin (17)),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin),
     aa fixed bin (35),
     bchr char (al) based (ap) unaligned,		/* character string for command args */
    (error_table_$segknown, error_table_$namedup, error_table_$noarg, error_table_$invalid_elsize) ext fixed bin (17),
     error_table_$full_hashtbl ext fixed bin (17),
     path char (168) aligned,
     expand_path_ entry (ptr, fixed bin (17), ptr, ptr, fixed bin (17)),
     com_err_ entry options (variable),
     ioa_ entry options (variable),
     hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5),
     ptr, fixed bin),
     hcs_$set_bc entry (char (*) aligned, char (*) aligned, fixed bin (24), fixed bin),
     term_ entry (char (*) aligned, char (*) aligned, fixed bin),
     cv_dec_ entry (char (*) aligned) returns (fixed bin (35)),
     dn char (168) aligned,				/* directory name */
     en char (32) aligned,				/* entry name */
     chr char (1) aligned,				/* request code */
     getback label local,
    (srchname, addname) char (32) aligned;		/* entry name and value to be passed to hash_ */
dcl  default fixed bin init (995),			/* size of hash table if none given */
     max fixed bin init (6552);			/* max number of buckets that will fit in one segment */

dcl (substr, null, addr) builtin;









/* the hash_table command is used to create a hash table and to insert, delete, and search for entries in it.

   usage:  hash_table path -nb-
   where "path" specifies the name of an existing hash table or the name to be given to the hash table
   created with "nb" buckets or entries.  if "nb" is not specifiedor not within bounds(0<nb<=6552) then
   a default value is assigned to it.


   the user may type the following four input lines(all must begin in column 1)
   q
   a name1 value1 ...... namen valuen
   d name1 ... namen
   s name1 ... namen

   "q" quits and returns to command level
   "a" adds entry "namei" to the hash table with value "valuei"
   "s" searches for entry "namei" and prints the value found
   "d" deletes entry "namei" and prints the value it was associated with

   "namei" is a character string <= 32 characters and "valuei" is a decimal number
   one argument is required for requests "d" and "s" while two are required for "a"
   */




ht:	entry;					/* command may be called by "ht" or "hash_table" */
	call cu_$arg_ptr (1, ap, al, ec);		/* get pointer to first argument(entry name) */
	if ec ^= 0 then do;				/* it did not exist */
err:	     call com_err_ (ec, "hash_table", "");	/* call standard error printing routine */
	     return;				/* return to caller */
	end;
	path = bchr;				/* align argument */
	call expand_path_ (addr (path), al, addr (dn), addr (en), ec); /* obtain full directory and entry names */
	if ec ^= 0 then go to err;
	call hcs_$make_seg (dn, en, "", 1011b, q, ec);	/* create or make known the segment with entry name given */
	if q = null then go to err;			/* unable to create or locate */
	if ec = 0 then do;				/* it did not previously exist */
	     call cu_$arg_ptr (2, ap, al, ec);		/* get pointer to optional second arg(number of buckets) */
	     if ec ^= 0 then buckets = default;		/* no buckets-assign default value */
	     else do;
		aa = cv_dec_ (substr (ap -> bchr, 1, al)); /* convert the decimal number to binary */
		if aa <= 0 then buckets = default;	/* check range of buckets */
		else if aa>max then do;
		     buckets = max;			/* buckets cannot be more than will fit in 1 segment */
		     call ioa_ ("too many buckets: ^d maximum", max); /* print console message */
		end;
		else buckets = aa;			/* change precision of valid number of buckets */
	     end;
	     bit_count = 36* (buckets*10+8);		/* there are 36 bits in each word and 10 words in each bucket with 8 at top */
	     call hcs_$set_bc (dn, en, bit_count, ec);	/* set the bit count of segment created */
	     if ec ^= 0 then go to err;
	     call hash_$make (q, buckets, ec);		/* this entry initializes the created hash table */
	     if ec ^= 0 then go to err;
	end;
	ip = addr (buffer);				/* common to existing and new hash tables */




next:	
	call ios_$read_ptr (ip, bc, count);		/* get request */
	if count = 1 then go to next;			/* nl character-try again */
	abuffer = buffer;				/* align input */
	chr = substr (abuffer, 1, 1);			/* treat first character as request code */




	if chr = "q" then do;			/* quit */
	     call term_ (dn, en, ec);			/* remove segment from address space */
	     if ec ^= 0 then go to err;
	     return;				/* return to caller */
	end;




	j = 1;					/* the next char examined in input will be the second(input.line(j)) */
	more_needed = "1"b;				/* 1 argument must be present */




	if chr = "s" then do;			/* search */
	     getback = s;				/* set return label to s */
	     go to getarg;				/* get first argument */
s:	     more_needed = "0"b;			/* any further arguments are optional */
	     call hash_$search (q, srchname, val, ec);	/* entry point to find val of srchname */
	     if ec ^= 0 then go to err2;		/* could not find it */
	     call ioa_ ("'^a' has value ^d", srchname, val); /* print the value */
	     go to getarg;				/* repeat the process if more arguments */
	end;




	if chr = "d" then do;			/* delete */
	     getback = d;				/* set ruturn label to d */
	     go to getarg;				/* get first argument */
d:	     more_needed = "0"b;			/* any further arguments are optional */
	     call hash_$out (q, srchname, val, ec);	/* entry point to delete srchname */
	     if ec ^= 0 then go to err2;		/* could not find it */
	     else call ioa_ ("'^a' deleted with value ^d", srchname, val); /* print console message */
	     go to getarg;				/* repeat the process for any remaining arguments */
	end;




	if chr = "a" then do;			/* insert */
	     getback = a;				/* set return label to a */
	     go to getarg;				/* get first argument */
a:	     more_needed = "1"b;			/* two arguments are required for "a" and others must be in pairs */
	     addname = srchname;			/* save entry name in addname */
	     getback = a2;				/* set return label to a2 */
	     go to getarg;				/* get value corresponding to addname */
a2:	     more_needed = "0"b;			/* another argument is not required */
	     aa = cv_dec_ (srchname);			/* convert value to binary */
	     val = aa;				/* change the precision */
	     call hash_$in (q, addname, val, ec);	/* entry point to insert the entry and value in hash table */
	     getback = a;
	     if ec = 0 then go to getarg;		/* get any remaining arguments */
	     go to err2;
	end;




	call ioa_ ("'^a' not a hash_table request", chr);	/* invalid request */
	go to next;				/* try again */






getarg:	do i = j to count-2 while (ip -> input.line (i) = " "); /* set i to point to first char in name and j to blank after */
	end;					/* i points to first nonblank character */
	if i>count-2 then do;			/* no argument existed */
	     if more_needed then go to err1;		/* print error message if argument expected */
	     else go to next;			/* otherwise get next request */
	end;
	else do j = i+1 to count-2 while (ip -> input.line (j) ^= " ");
	end;					/* j now points to blank after name or nl character */
	if j-i>32 then do;				/* maximum length of name is 32 characters */
	     call ioa_ ("'^a' truncated to 32 characters", substr (abuffer, i+1, j-i)); /* print message */
	     len = 32;				/* continue the process with 32 characters */
	end;
	else len = j-i;				/* assign len the actual length if <32 characters */
	srchname = substr (abuffer, i+1, len);		/* put name in srchname */
	go to getback;				/* return to routine to process srchname */






err1:	ec = error_table_$noarg;			/* expected argument missing */
	call com_err_ (ec, "hash_table", "");		/* common error message routine */
	go to next;				/* get next request */
err2:	if ec = error_table_$full_hashtbl then go to err;	/* if hash table was full or inefficient */
	call com_err_ (ec, "hash_table", "");		/* print message for all other errors */
	go to getarg;				/* get any remaining arguments for request */
     end hash_table;




		    hunt.pl1                        10/27/83  1614.3rew 10/27/83  1441.9       91179



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

hunt: proc;

/* HUNT - find a segment in a given subtree. */
/* Modified 780905 by PG to terminate archive segments when finished with them. */
/* Fixed to find secondary names and check for no r on an archive, 05/10/79 S. Herbst */
/* Changed to call sweep_disk_$dir_list 05/29/79 S. Herbst */
/* MCR 4264 fixed to complain about top node 01/07/80 S. Herbst */
/* Implement as active function and fix for multiple archive names 05/14/80 S. Herbst */
/* Fixed to work on the root 01/12/81 S. Herbst */
/* Fixed not to stall when a damaged archive is hit, LA Newcomb, 3Nov1982 */
/* Fixed to look at archive contents before the addmanes, LA Newcomb, 16Nov1982 */

/* format:  style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */

%include archive_header;
%include branch_status;

/* static */

dcl  total		        fixed bin int static;
dcl  R_ACCESS		        fixed bin (5) int static options (constant) init (01000b);
dcl  S_ACCESS		        fixed bin (5) int static options (constant) init (01000b);

dcl  arg			        char (arg_len) based (arg_ptr);
dcl  return_arg		        char (return_len) varying based (return_ptr);
dcl  dir_path		        char (168);
dcl  starname		        char (32);

dcl  (af_sw, allsw, archive_sw, firstsw, got_dir, got_starname) bit (1) aligned;

dcl  (arg_ptr, header_ptr, return_ptr, segp) ptr;

dcl  seg_mode		        fixed bin (5);
dcl  (arg_count, arg_len, i, j, return_len) fixed bin;
dcl  code			        fixed bin (35);

dcl  error_table_$badopt	        fixed bin (35) ext;
dcl  error_table_$incorrect_access    fixed bin (35) ext;
dcl  error_table_$no_s_permission     fixed bin (35) ext;
dcl  error_table_$root	        fixed bin (35) ext;
dcl  error_table_$seg_busted	        fixed bin (35) ext;

dcl  complain		        entry variable options (variable);

dcl  absolute_pathname_	        entry (char (*), char (*), fixed bin (35));
dcl  (active_fnc_err_, active_fnc_err_$suppress_name) entry options (variable);
dcl  archive_util_$first_element      entry (ptr, fixed bin (35));
dcl  archive_util_$next_element       entry (ptr, fixed bin (35));
dcl  check_star_name_$entry	        entry (char (*), fixed bin (35));
dcl  (com_err_, com_err_$suppress_name) entry options (variable);
dcl  cu_$af_return_arg	        entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$arg_ptr		        entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  get_wdir_		        entry returns (char (168));
dcl  hcs_$fs_get_mode	        entry (ptr, fixed bin (5), fixed bin (35));
dcl  hcs_$initiate		        entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$status_		        entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl  hcs_$terminate_noname	        entry (ptr, fixed bin (35));
dcl  (ioa_, ioa_$rsnnl)	        entry options (variable);
dcl  match_star_name_	        entry (char (*), char (*), fixed bin (35));
dcl  sweep_disk_$dir_list	        entry (char (168), entry);

dcl  (addr, fixed, length, null, rtrim, substr) builtin;
dcl  (seg_fault_error, cleanup)       condition;
%page;
	call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
	if code = 0 then do;
	     af_sw = "1"b;
	     complain = active_fnc_err_;
	     return_arg = "";
	end;
	else do;
	     af_sw = "0"b;
	     complain = com_err_;
	end;

	allsw, firstsw, got_dir, got_starname = "0"b;
	archive_sw = "1"b;

	do i = 1 to arg_count;

	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);

	     if substr (arg, 1, 1) ^= "-" then
		if got_dir then do;
USAGE:		     if af_sw then call active_fnc_err_$suppress_name (0, "hunt",
			     "Usage:  [hunt starname {root_of_tree} {-control_arg}]");
		     else call com_err_$suppress_name (0, "hunt",
			     "Usage:  hunt starname {root_of_tree} {-control_args}");
		     return;
		end;
		else if got_starname then do;
		     call absolute_pathname_ (arg, dir_path, code);
		     if code ^= 0 then do;
			call complain (code, "hunt", "^a", arg);
			return;
		     end;
		     got_dir = "1"b;
		end;
		else do;
		     starname = arg;
		     call check_star_name_$entry (starname, code);
		     if code ^= 0 & code ^= 1 & code ^= 2 then do;
			call complain (code, "hunt", "^a", starname);
			return;
		     end;
		     got_starname = "1"b;
		end;

/* control arg */

	     else if arg = "-all" | arg = "-a" then allsw = "1"b;
	     else if arg = "-first" | arg = "-ft" then firstsw = "1"b;
	     else if arg = "-archive" | arg = "-ac" then archive_sw = "1"b;
	     else if arg = "-no_archive" | arg = "-nac" then archive_sw = "0"b;
	     else do;
		call complain (error_table_$badopt, "hunt", "^a", arg);
		return;
	     end;
	end;

	if ^got_starname then go to USAGE;
	else if ^got_dir then dir_path = get_wdir_ ();

	call hcs_$status_ (dir_path, "", 1, addr (branch_status), null, code);
	if code = error_table_$root then do;
	     code = 0;
	     branch_status.mode = "01000"b;
	end;
	if code ^= 0 & code ^= error_table_$no_s_permission & code ^= error_table_$incorrect_access then do;
	     call complain (code, "hunt", "^a", dir_path);
	     return;
	end;
	if fixed (branch_status.mode, 5) < S_ACCESS then do;
	     call complain (0, "hunt", "No s permission on ^a", dir_path);
	     return;
	end;

	total = 0;

	segp = null ();				/* for cleaning up */
	on cleanup begin;
		if segp ^= null () then
		     call hcs_$terminate_noname (segp, code);
	     end;

	call sweep_disk_$dir_list (dir_path, counter);

bust:	if ^af_sw then call ioa_ ("Total ^d", total);

	return;
%page;
counter: proc (sdn, sen, lvl, een, bptr, nptr);

dcl  sdn			        char (168) aligned,	/* superior dir name */
     sen			        char (32) aligned,	/* dirname */
     lvl			        fixed bin,		/* distance from root */
     een			        char (32),		/* entry name */
     bptr			        ptr,		/* ptr to info structure */
     nptr			        ptr;		/* ptr to names structure */

dcl  xp			        char (168),
     ename		        char (32),
     (ni, xi)		        fixed bin;

dcl  1 branch		        based (bptr) aligned, /* thing returned by star_long */
       2 type		        bit (2) unal,
       2 nname		        bit (16) unal,
       2 nindex		        bit (18) unal,
       2 dtm		        bit (36) unal,
       2 dtu		        bit (36) unal,
       2 mode		        bit (5) unal,
       2 pad		        bit (13) unal,
       2 records		        bit (18) unal;

dcl  names		        (99 /* arbitrary */) char (32) aligned based (nptr);

dcl  ecc			        fixed bin (35);

dcl  (						/* constants */
     bty			        char (4) dim (0:3) init ("link", "seg", "dir", "??"),
     SEG_TYPE		        fixed bin init (1)
     )			        int static options (constant);

	call ioa_$rsnnl ("^a^[>^]^a", xp, xi, sdn, sdn ^= ">", sen);
	if ^allsw then
	     if fixed (branch.type) ^= SEG_TYPE then
		return;
	ecc = 1;					/* so loops will start */
%page;
	if archive_sw then				/* we are to check archive components */
	     if fixed (branch.type) = SEG_TYPE then do;	/* archive may only be a segment */

		on seg_fault_error begin;		/* must handle damaged archives */
			call complain (error_table_$seg_busted, "hunt",
			     "^a^[>^]^a", xp, xp ^= ">", ename);
			go to check_storage_sys_name;
		     end;

		do ni = 1 to fixed (branch.nname) while (ecc ^= 0);

		     ename = names (fixed (branch.nindex) + ni - 1);

		     j = length (rtrim (ename));
		     if j > 8 then
			if substr (ename, j - 7, 8) = ".archive" then do;
			     call hcs_$initiate (xp, ename, "", 0b, 0b, segp, ecc);
			     if segp = null then
				go to check_storage_sys_name;
			     call hcs_$fs_get_mode (segp, seg_mode, ecc);
			     if ecc ^= 0 then
				go to terminate_archive;
			     if seg_mode < R_ACCESS then
				go to terminate_archive;
			     header_ptr = segp;
			     call archive_util_$first_element (header_ptr, ecc);
			     do while (ecc = 0);
				call match_star_name_ ((header_ptr -> archive_header.name), starname, ecc);
				if ecc = 0 then do;
				     total = total + 1;
				     if af_sw then do; /* append archive_path::component_name */
					if return_arg ^= "" then return_arg = return_arg || " ";
					if xp = ">" then return_arg = return_arg || ">";
					else return_arg = return_arg || rtrim (xp) || ">";
					return_arg = return_arg || rtrim (ename);
					return_arg = return_arg || "::";
					return_arg = return_arg || rtrim (header_ptr -> archive_header.name);
				     end;
				     else call ioa_ ("^a ^a^[>^]^a contains ^a", bty (fixed (branch.type)),
					     xp, xp ^= ">", ename, header_ptr -> archive_header.name);
				     if firstsw then do;
					call hcs_$terminate_noname (segp, ecc);
					segp = null (); /* so cleanuyp doesn't get a crack at it */
					go to bust;
				     end;
				end;
				call archive_util_$next_element (header_ptr, ecc);
			     end;
terminate_archive:
			     call hcs_$terminate_noname (segp, ecc);
			     segp = null ();
			     go to check_storage_sys_name; /* done with the archive components */
			end;
		end;
	     end;
%page;
check_storage_sys_name:
	ecc = 1;					/* so loop will go */
	do ni = 1 to fixed (branch.nname) while (ecc ^= 0);
	     ename = names (fixed (branch.nindex) + ni - 1);
	     call match_star_name_ (ename, starname, ecc);
	     if ecc = 0 then do;
		total = total + 1;
		if af_sw then do;
		     if return_arg ^= "" then return_arg = return_arg || " ";
		     if xp ^= ">" then return_arg = return_arg || rtrim (xp);
		     return_arg = return_arg || ">";
		     return_arg = return_arg || rtrim (ename);
		end;
		else call ioa_ ("^a ^a^[>^]^a", bty (fixed (branch.type)), xp, xp ^= ">", ename);
		if firstsw then go to bust;
	     end;
	end;


	return;
     end counter;

     end hunt;




		    list_as_requests.pl1            08/05/87  0803.1r   08/04/87  1540.6      136899



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


/****^  HISTORY COMMENTS:
  1) change(84-12-01,Margulies), approve(), audit(), install():
     Pre-hcom comments.
     Written 1984-12, BIM.
     Modified 1985-02-20, BIM: For daemon and com channel info requests.
  2) change(86-11-24,Lippard), approve(86-11-24,PBF7326),
     audit(86-11-25,GDixon), install(86-11-25,MR12.0-1224):
     Modified to handle abs_command AS requests.
                                                   END HISTORY COMMENTS */


/* list_as_requests: lists and interprets all as requests in the message 
   segment */

/* format: style2,idind30 */

list_as_requests:
     procedure options (variable);

/**** This command is a very simple lister. It lists all requests
      unless the access present is only sufficient for own access.
      Fancy control args will just have to wait. */

	declare ssu_$standalone_invocation    entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));
	declare ssu_$destroy_invocation       entry (ptr);
	declare ssu_$abort_line	        entry () options (variable);
	declare ssu_$arg_count	        entry (ptr, fixed bin);
	declare ssu_$arg_ptr	        entry (ptr, fixed bin, ptr, fixed bin (21));
	declare com_err_		        entry () options (variable);
	declare cu_$arg_list_ptr	        entry returns (pointer);

	declare display_access_class_	        entry (bit (72) aligned) returns (character (32) aligned);
	declare get_user_free_area_	        entry returns (pointer);
	declare ioa_		        entry () options (variable);
	declare message_segment_$read_message_index
				        entry (fixed bin, ptr, ptr, fixed bin (35));
	declare message_segment_$open	        entry (char (*), char (*), fixed bin, fixed bin (35));
	declare message_segment_$close        entry (fixed bin, fixed bin (35));
	declare message_segment_$get_mode_index
				        entry (fixed bin, bit (36) aligned, fixed bin (35));
	declare request_id_		        entry (fixed binary (71)) returns (character (19));
	declare requote_string_	        entry (character (*)) returns (character (*));

	declare system_info_$request_chn      entry (bit (36) aligned, fixed bin (71), char (*), char (*));

	declare expand_pathname_$add_suffix   entry (character (*), character (*), character (*), character (*),
				        fixed binary (35));


	declare error_table_$noarg	        fixed bin (35) ext static;
	declare error_table_$badopt	        fixed bin (35) ext static;

	declare argx		        fixed bin;
	declare arg_count		        fixed bin;
	declare dir_name		        char (168);
	declare entryname		        char (32);
	declare message_bits	        bit (mmi.ms_len) based (mmi.ms_ptr) aligned;
	declare ms_index		        fixed bin;
	declare ms_mode		        bit (36) aligned;
	declare sci_ptr		        pointer;
	declare code		        fixed bin (35);
	declare ap		        pointer;
	declare al		        fixed bin (21);
	declare argument		        char (al) based (ap);
	declare 1 mmi		        aligned like mseg_message_info;

	declare (addr, currentsize, divide, hbound, lbound, size, substr, unspec) builtin;


	dir_name = "";
	entryname = "";
	ms_index = -1;				/* for cleanup handler */
	call ssu_$standalone_invocation (sci_ptr, "list_as_requests", "", cu_$arg_list_ptr (), SSU_ABORT, code);
	if code ^= 0
	then do;
		call com_err_ (code, "list_as_requests", "Failed to create ssu_ invocation.");
		return;
	     end;

	call ssu_$arg_count (sci_ptr, arg_count);
	if arg_count > 0
	then do argx = 1 to arg_count;
		call ssu_$arg_ptr (sci_ptr, argx, ap, al);
		if argument = "-test_ms"
		then do;
			if argx = arg_count
			then call ssu_$abort_line (sci_ptr, error_table_$noarg,
				"-test_ms must be followed by a message segment pathname.");
			argx = argx + 1;
			call ssu_$arg_ptr (sci_ptr, argx, ap, al);
			call expand_pathname_$add_suffix (argument, "ms", dir_name, entryname, code);
			if code ^= 0
			then call ssu_$abort_line (sci_ptr, code, "Invalid pathname ^a.", argument);
		     end;
		else call ssu_$abort_line (sci_ptr, error_table_$badopt, "Invalid control argument ^a.", argument);
	     end;

	if dir_name = ""
	then call system_info_$request_chn ((""b), (0), dir_name, entryname);
	call message_segment_$open (dir_name, entryname, ms_index, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code, "Failed to open message segment ^a>^a.", dir_name, entryname);
	call message_segment_$get_mode_index (ms_index, ms_mode, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code, "Failed to get mode on message segment ^a>^a.", dir_name, entryname);

	unspec (mmi) = ""b;
	mmi.version = MSEG_MESSAGE_INFO_V1;
	mmi.own = ^substr (ms_mode, 3, 1);		/* read mode */
	mmi.message_code = MSEG_READ_FIRST;
	code = 0;
	do while (code = 0);
	     call message_segment_$read_message_index (ms_index, get_user_free_area_ (), addr (mmi), code);
	     if code = 0
	     then do;
		     call PRINT_MESSAGE;
		     free message_bits;
		end;
	     mmi.message_code = MSEG_READ_AFTER_SPECIFIED;
	end;
	call message_segment_$close (ms_index, (0));
	return;

PRINT_MESSAGE:
     procedure;

	declare request_id		        char (19);
	declare ms_id_clock		        fixed bin (71);
	declare ms_length_words	        fixed bin (18);
	declare 1 header		        aligned like as_request_header based (mmi.ms_ptr);

	unspec (ms_id_clock) = mmi.ms_id;
	request_id = request_id_ (ms_id_clock);
	call ioa_ ("Message ^a from ^a (^w) in ring ^d", request_id, mmi.sender_id, mmi.sender_process_id,
	     mmi.sender_level);
	call ioa_ ("        Authorization ^a, Maximum authorization ^a",
	     display_access_class_ (mmi.sender_authorization), display_access_class_ (mmi.sender_max_authorization));

	ms_length_words = divide (mmi.ms_len, 36, 18, 0);
	if ms_length_words < size (as_request_header)
	then do;
		call ioa_ ("        Message length less than minimum.");
		return;
	     end;

	if header.version ^= as_request_version_1
	then do;
		call ioa_ ("        Message header version ^d, but only version ^d is supported.", header.version,
		     as_request_version_1);
		return;
	     end;
	if header.type < ASR_FIRST_TYPE | header.type > ASR_LAST_TYPE
	then do;
		call ioa_ ("        Message type ^d undefined.", header.type);
		call ioa_ ("        Reply channel ^d.", header.reply_channel);
		return;
	     end;
	call ioa_ ("        ^a request. Reply channel ^d.", ASR_REQUEST_NAMES (header.type), header.reply_channel);
	go to TYPE (header.type);

TYPE (1):						/* dial server */
	call PRINT_DIAL_REQUEST;
	return;

TYPE (2):						/* dial out */
	call PRINT_DIAL_REQUEST;
	return;

TYPE (3):						/* fpe causes logout */
TYPE (4):						/* fpe causes new process */
	return;					/* nothing to say */

TYPE (5):						/* "buzzard" -- termination notify */
	call PRINT_BUZZARD;
	return;

TYPE (6):						/* bump */
	call PRINT_BUMP;
	return;

TYPE (7):						/* command execution */
	call PRINT_ADMIN_COMMAND;
	return;

TYPE (8):						/* note pnt changes */
	call PRINT_NOTE_PNT;
	return;

TYPE (9):						/* daemon commands */
	call PRINT_DAEMON_COMMAND;
	return;

TYPE (10):					/* com_channel_info */
	call PRINT_COM_CHANNEL_INFO;
	return;
TYPE (11):					/* abs_command */
	call PRINT_ABS_COMMAND;
	return;


PRINT_DIAL_REQUEST:
     procedure;

	request_ptr = mmi.ms_ptr;
	if ms_length_words < size (dial_server_request)
	then do;
		call ioa_ ("        Message too short.");
		return;
	     end;

	if dial_server_request.version ^= dial_server_request_version_4
	then do;
		call ioa_ ("        Request version ^d, but only ^d is supported.", dial_server_request.version,
		     dial_server_request_version_4);
		return;
	     end;
	call ioa_ ("        dial_control_channel ^d", dial_server_request.dial_control_channel);
	call ioa_ ("        dial_qualifier ^a", dial_server_request.dial_qualifier);
	call ioa_ ("        channel_name ^a", dial_server_request.channel_name);
	call ioa_ ("        dial_out_destination ^a", dial_server_request.dial_out_destination);
	call ioa_ ("        baud_rate ^d^[ not specified^]", dial_server_request.baud_rate,
	     dial_server_request.baud_rate = -1);
	if dial_server_request.line_type >= lbound (line_types, 1)
	     & dial_server_request.line_type <= hbound (line_types, 1)
	then call ioa_ ("        line_type ^d (^a)", dial_server_request.line_type,
		line_types (dial_server_request.line_type));
	else call ioa_ ("        line_type ^d", dial_server_request.line_type);
	call ioa_ ("        server_type ^a", dial_server_request.server_type);
	call ioa_ ("        flags: ^[^^^]start,^[^^^]stop,^[^^^]privileged_attach,^[^^^]release_channel,",
	     ^dial_server_request.start, ^dial_server_request.stop, ^dial_server_request.privileged_attach,
	     ^dial_server_request.release_channel);
	call ioa_ ("               ^[^^^]registered_server,^[^^^]no_hangup,^[^^^]release_dial_id,^[^^^]tandd_attach,",
	     ^dial_server_request.registered_server, ^dial_server_request.no_hangup,
	     ^dial_server_request.release_dial_id, ^dial_server_request.tandd_attach);
	call ioa_ ("               ^[^^^]privileged_server", ^dial_server_request.privileged_server);
	call ioa_ ("        access_class ^a", display_access_class_ (dial_server_request.access_class));
	return;
     end PRINT_DIAL_REQUEST;

PRINT_BUZZARD:
     procedure;

	asr_buzzard_infop = mmi.ms_ptr;
	if ms_length_words < size (asr_buzzard_info)
	then do;
		call ioa_ ("        Message length less than minimum.");
		return;
	     end;
	if asr_buzzard_info.version ^= asr_buzzard_info_version_1
	then do;
		call ioa_ ("        Request version ^a, but only version ^a is supported.", asr_buzzard_info.version,
		     asr_buzzard_info_version_1);
		return;
	     end;
	call ioa_ ("        info_channel ^d", asr_buzzard_info.info_channel);
	call ioa_ ("        reference_id ^w", asr_buzzard_info.my_reference_id);
	return;
     end PRINT_BUZZARD;


PRINT_BUMP:
     procedure;

	asr_bump_user_info_ptr = mmi.ms_ptr;
	if ms_length_words < size (asr_bump_user_info)
	then do;
		call ioa_ ("        Message length less than minimum.");
		return;
	     end;

	if asr_bump_user_info.version ^= asr_bump_user_info_version_1
	then do;
		call ioa_ ("        Message version is ^a, but only version ^a is supported.",
		     asr_bump_user_info.version, asr_bump_user_info_version_1);
		return;
	     end;

	call ioa_ ("        process_id ^w", asr_bump_user_info.process_id);
	call ioa_ ("        message ^a", asr_bump_user_info.message);
	call ioa_ ("        grace_time_in_seconds ^d", asr_bump_user_info.grace_time_in_seconds);
	call ioa_ ("        reference_id ^w", asr_bump_user_info.reply_reference_id);
	return;
     end PRINT_BUMP;

PRINT_ADMIN_COMMAND:
     procedure;

	asr_admin_command_info_ptr = mmi.ms_ptr;
	if ms_length_words < currentsize (asr_admin_command_info)
	then do;
		call ioa_ ("        Message length less than minimum.");
		return;
	     end;
	if asr_admin_command_info.version ^= ASR_AC_VERSION_1
	then do;
		call ioa_ ("        Request version is ^a, but only version ^a is supported.",
		     asr_admin_command_info.version, ASR_AC_VERSION_1);
		return;
	     end;

	call ioa_ ("        flags: ^[^^^]send_start_wakeup,^[^^^]send_completion_wakeup,",
	     ^asr_admin_command_info.flags.send_start_wakeup, ^asr_admin_command_info.flags.send_completion_wakeup);
	call ioa_ ("               ^[^^^]send_completion_message,^[^^^]send_completion_mail",
	     ^asr_admin_command_info.flags.send_completion_message, ^asr_admin_command_info.flags.send_completion_mail);
	call ioa_ ("        mail_destination ^a", asr_admin_command_info.mail_destination);
	call ioa_ ("        command ^a", requote_string_ (asr_admin_command_info.command));
	return;
     end PRINT_ADMIN_COMMAND;

PRINT_NOTE_PNT:
     procedure;

	asr_note_pnt_change_info_ptr = mmi.ms_ptr;
	if ms_length_words < currentsize (asr_note_pnt_change_info)
	then do;
		call ioa_ ("        Message length less than minimum.");
		return;
	     end;
	if asr_note_pnt_change_info.version ^= ASR_NPC_INFO_VERSION_1
	then do;
		call ioa_ ("        Request version is ^a, but only version ^a is supported.",
		     asr_note_pnt_change_info.version, ASR_NPC_INFO_VERSION_1);
		return;
	     end;
	call ioa_ ("        person_id ^a", asr_note_pnt_change_info.person_id);
	return;
     end PRINT_NOTE_PNT;

PRINT_COM_CHANNEL_INFO:
     procedure;

	asr_com_channel_info_ptr = mmi.ms_ptr;
	if ms_length_words < currentsize (asr_com_channel_info)
	then do;
		call ioa_ ("        Message length less than minimum.");
		return;
	     end;
	if asr_com_channel_info.version ^= ASR_CCI_VERSION_1
	then do;
		call ioa_ ("        Request version is ^a, but only version ^a is supported.",
		     asr_com_channel_info.version, ASR_CCI_VERSION_1);
		return;
	     end;
	call ioa_ ("        channel_name ^a", asr_com_channel_info.channel_name);
	call ioa_ ("        reply_message_handle ^.3b", asr_com_channel_info.reply_message_handle);

	return;

     end PRINT_COM_CHANNEL_INFO;

PRINT_DAEMON_COMMAND:
     procedure;

	asr_daemon_command_info_ptr = mmi.ms_ptr;
	if ms_length_words < currentsize (asr_daemon_command_info)
	then do;
		call ioa_ ("        Message length less than minimum.");
		return;
	     end;
	if asr_daemon_command_info.version ^= ASR_DC_INFO_VERSION_1
	then do;
		call ioa_ ("        Request version is ^a, but only version ^a is supported.",
		     asr_daemon_command_info.version, ASR_DC_INFO_VERSION_1);
		return;
	     end;

	call ioa_ ("        action_code ^[login^;logout^;quit^;reply^]", asr_daemon_command_info.action_code);
	call ioa_ ("        user_name ^a", asr_daemon_command_info.user_name);
	call ioa_ ("        project_name ^a", asr_daemon_command_info.project_name);
	call ioa_ ("        source_name ^a", asr_daemon_command_info.source_name);
	call ioa_ ("        command ^a", requote_string_ (asr_daemon_command_info.command));
	return;
     end PRINT_DAEMON_COMMAND;

PRINT_ABS_COMMAND:
     procedure;

	asr_abs_command_info_ptr = mmi.ms_ptr;
	if ms_length_words < currentsize (asr_abs_command_info)
	then do;
		call ioa_ ("        Message length less than minimum.");
		return;
	     end;
	if asr_abs_command_info.version ^= ASR_AC_INFO_VERSION_1
	then do;
		call ioa_ ("        Request version is ^a, but only version ^a is supported.",
		     asr_abs_command_info.version, ASR_AC_INFO_VERSION_1);
		return;
	     end;

	call ioa_ ("        action_code ^[login^;cancel^]", asr_abs_command_info.action_code);
	call ioa_ ("        request_id ^a", request_id_ (asr_abs_command_info.request_id));
	return;
     end PRINT_ABS_COMMAND;
     end PRINT_MESSAGE;

SSU_ABORT:
     procedure;
	go to ABORT;
     end SSU_ABORT;

ABORT:
	if ms_index ^= -1
	then call message_segment_$close (ms_index, (0));
	return;

%include mseg_message_info;
%include as_request_header;
%include as_requests;
%include asr_abs_command;
%include asr_daemon_command;
%include asr_com_channel_info;
%include dial_server_request;
%include line_types;
     end list_as_requests;




		    list_delegated_projects.pl1     07/13/88  1112.5r w 07/13/88  0942.4       41328



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


list_delegated_projects: proc;

dcl (sat_dir, sat_path) char (168) aligned,
     sel_proj char (32) aligned init (""),
     sat_name char (32) aligned,
     datestr char (16) aligned,
    (i, ii, iii, m, lng, sm, jj, slng, ec) fixed bin,
     an fixed bin init (2),
    (argp, satp, satep, pp) pointer,
     arg char (slng) based (argp),
     ct fixed bin init (0),
     ct1 fixed bin init (0);

dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin),
     com_err_ entry options (variable),
     idsort_ entry ((*) char (32) aligned, (*) fixed bin, fixed bin);
dcl  ioa_ entry options (variable),
     ioa_$rsnnl entry options (variable),
     hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned,
     fixed bin (1), fixed bin (2), ptr, fixed bin),
     hcs_$terminate_noname entry (ptr, fixed bin),
     clock_ entry () returns (fixed bin (71)),
     date_time_ entry (fixed bin (71), char (*) aligned);
dcl (addr, null, fixed, substr) builtin;

/* ================================================ */

%include user_attributes;
%include sat;
/* ================================================ */

/* INITIALIZATION - LOCATE AND INITIATE SAT */


	call cu_$arg_ptr (1, argp, slng, ec);		/* 1st argument is path name of sat */
	if ec ^= 0 then do;
	     call com_err_ (ec, "list_delegated_projects", "");
	     return;
	end;

	sat_path = arg;
	if sat_path ^= "sat" then
	     if substr (sat_path, slng-3, 4) ^= ">sat" then
		if substr (sat_path, slng-3, 4) ^= ".sat" then do;
	     slng = slng + 4;
	     substr (sat_path, slng-3, 4) = ".sat";
	end;

	call expand_path_ (addr (sat_path), slng, addr (sat_dir), addr (sat_name), ec);
	if ec ^= 0 then do;
	     call com_err_ (ec, "list_delegated_projects", sat_path);
	     return;
	end;

	call hcs_$initiate (sat_dir, sat_name, "", 0, 0, satp, ec);
	if satp = null then do;
	     call com_err_ (ec, "list_delegated_projects", sat_path);
	     return;
	end;
	if sat.version ^= SAT_version then do;
	     call com_err_ (0, "list_delegated_projects",
	     "SAT version is inconsistent with declarations used by this program");
	     go to exit;
	end;

arglp:	call cu_$arg_ptr (an, argp, slng, ec);		/* get next arg -- a project name */
	if ec ^= 0 then go to endarg;			/* last arg? */
	else do;
	     sel_proj = arg;
	end;

next_arg: an = an + 1;
	go to arglp;				/* loop on args */
endarg:	if sel_proj ^= "" then go to quickie;
	call date_time_ ((clock_ ()), datestr);
	call ioa_ ("^/List of Delegated Projects as of ^a^/", datestr);

	call ioa_ ("^/^10xP__r_o_j_e_c_t^4xA__d_m_i_n_i_s_t_r_a_t_o_r^/");

quickie:	sm = sat.current_size;			/* Set up for sort. */
	begin;

dcl  x (sm) char (32) aligned,			/* project sorting array */
     y (sm) fixed bin;				/* grade array sorted with project id */

	     do i = 1 to sat.current_size;
		satep = addr (sat.project (i));
		x (i) = project.project_id;
		y (i) = i;
	     end;
	     if sel_proj = "" then call idsort_ (x, y, sm);

	     do i = 1 to sat.current_size;		/* loop thru SAT looking for delegated projects */
		satep = addr (sat.project (y (i)));	/* get ptr to slide down sat entries */
		if project.state = 1 then do;
		     if sel_proj ^= "" then if sel_proj ^= project.project_id then go to endsatloop;
		     ct = ct + 1;			/* counter to report undelegated projects */
		     if project.admin (1).userid = "" then go to endsatloop;
		     ct1 = ct1 + 1;
		     call ioa_ ("^/^10x^9a  ^a", project.project_id, project.admin (1).userid);
		     do jj = 2 to 4;		/* up to 4 project administrators */
			if project.admin (jj).userid ^= "" then
			     call ioa_ ("^21x^a", project.admin (jj).userid);
		     end;
		end;
endsatloop:    end;
	end;

	if sel_proj ^= "" then if ct = 0 then do;
	     call ioa_ (" Project ^a not found in SAT", sel_proj);
	end;
	else if ct1 = 0 then do;
	     call ioa_ ("^a is not currently a delegated project", sel_proj);
	end;

	call ioa_ ("");
exit:	call hcs_$terminate_noname (satp, ec);
	return;

     end list_delegated_projects;




		    list_extra_personids.pl1        09/25/92  1645.7r w 09/25/92  1644.9       63891



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




/****^  HISTORY COMMENTS:
  1) change(90-11-05,Vu), approve(90-11-05,MCR8226), audit(92-09-24,Zimmerman),
     install(92-09-25,MR12.5-1019):
     list_extra_personids aborts when it is run more than once within the same
     process.
                                                   END HISTORY COMMENTS */


/* format: style4 */
list_extra_personids: procedure;

/* Modified May 1982 E. N. Kittlitz. bugfix. */
/* Modified 1984-08-15 by E. Swenson for Version 2 PNTs. */

dcl  1 vrec aligned,				/* record in temporary vfile */
       2 pid char (32),
       2 in_pnt bit,
       2 chain pointer;

dcl  1 reference aligned based (refp),
       2 next pointer,
       2 type char (168);

dcl  temp_area area based (ai.areap);

dcl  temp_file internal file keyed record;

dcl  ME char (32) static options (constant) init ("list_extra_personids");
dcl  sysdir char (168) static init (">system_control_dir");
dcl  pdtdir char (168) static init (">system_control_dir>pdt");

/* External Static */

dcl  error_table_$bad_index fixed bin (35) external static;
dcl  error_table_$checksum_failure fixed bin (35) external static;
dcl  error_table_$no_record fixed bin (35) external static;
dcl  iox_$error_output ptr external static;
dcl  sys_info$max_seg_size fixed bin (19) external static;

/* External Entries */

dcl  com_err_ entry options (variable);
dcl  define_area_ entry (ptr, fixed bin (35));
dcl  get_pdir_ entry returns (char (168));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  ioa_$ioa_switch entry () options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  pnt_manager_$get_abs_entry entry (fixed bin (35), ptr, fixed bin (35));
dcl  release_area_ entry (ptr);
dcl  unique_chars_ entry (bit (*)) returns (char (15));

dcl  code fixed bin (35);
dcl  uid char (32);
dcl  rec fixed bin (35);
dcl  1 pnte aligned like pnt_entry;
dcl  atd char (168);
dcl  long bit aligned;
dcl  (satp, pdtp, pdtep, satep, refp) pointer;
dcl  (i, j) fixed bin;
dcl  1 ai aligned like area_info;

/* Builtins */

dcl  (addr, index, null, rtrim, string, substr) builtin;

/* Conditions */

dcl  (cleanup, endfile, key) condition;

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

	long = "0"b;

	ai.version = area_info_version_1;
	string (ai.control) = ""b;
	ai.control.extend = "1"b;
	ai.control.no_freeing = "1"b;
	ai.owner = ME;
          ai.size = sys_info$max_seg_size;
	ai.areap = null ();

          on cleanup call clean_up ();
	call define_area_ (addr (ai), code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "Defining temporary area.");
	     return;
	end;

	call ioa_$rsnnl ("vfile_ ^a>^a.lxp.temp", atd, (0), get_pdir_ (), unique_chars_ (""b));
	open file (temp_file) title (atd) update;

	call hcs_$initiate (sysdir, "sat", "", 0, 0, satp, code);
	if satp = null () then do;
	     call com_err_ (code, ME, "Initiating SAT.");
               call clean_up ();
	end;

	do j = 1 to 2;
	     call ref (sat.system_admin (j), "System Administrator");
	end;
	do i = 1 to sat.current_size;
	     satep = addr (sat.project (i));
	     if project.state = 1 then do;
		do j = 1 to 4;
		     call ref (project.admin (j).userid, "Project " || rtrim (project.project_id) || " Administrator");
		end;

		call hcs_$initiate (pdtdir, rtrim (project.project_id) || ".pdt", "", 0, 0, pdtp, code);
		if pdtp = null ()
		then call com_err_ (code, ME, "Initiating ^a.pdt.", project.project_id);
		else do;
		     do j = 1 to pdt.current_size;
			pdtep = addr (pdt.user (j));
			if user.state = 1 then call ref ((user.person_id), rtrim (project.project_id) || " Project");
		     end;
		     call hcs_$terminate_noname (pdtp, code);
		end;
	     end;
	end;

	on key (temp_file) begin;
		read file (temp_file) into (vrec) key (uid);
		vrec.in_pnt = "1"b;
		rewrite file (temp_file) from (vrec) key (uid);
	     end;
	do rec = 1 by 1;
	     call pnt_manager_$get_abs_entry (rec, addr (pnte), code);
	     if code = error_table_$bad_index then goto done_pnt;
	     else if code = error_table_$no_record then ;
	     else if code = error_table_$checksum_failure then
		call ioa_$ioa_switch (iox_$error_output, "^a: Checksum error reading PNT entry ^d.", ME, rec);
	     else if code ^= 0 then do;
		call com_err_ (code, ME, "Reading PNT entry ^d.", rec);
                    call clean_up ();
	     end;
	     else do;
		uid = pnte.user_id;
		vrec.pid = uid;
		vrec.chain = null ();
		vrec.in_pnt = "1"b;
		write file (temp_file) from (vrec) keyfrom (uid);
	     end;
	end;
done_pnt: revert key (temp_file);
	close file (temp_file);
	open file (temp_file) title (atd) sequential input;
          on endfile (temp_file) begin;
             call clean_up ();
             goto exit;
          end;

	do while ("1"b);
	     read file (temp_file) into (vrec);
	     if vrec.in_pnt & vrec.chain = null ()
	     then do;
		call ioa_ ("^22a in PNT is not used.", vrec.pid);
	     end;
	     else if long | ^vrec.in_pnt then do;
		call ioa_ ("^22a^[ is not in the PNT.^]", vrec.pid, ^vrec.in_pnt);
		do refp = vrec.chain
		     repeat (reference.next)
		     while (refp ^= null ());
		     call ioa_ ("   ^a", reference.type);
		end;
	     end;
	end;

exit:     return;

clean_up: procedure ();
          close file (temp_file);
          call release_area_ (ai.areap);
	return;
end;

/* * * * * * * * * * REF * * * * * * * * * */

ref: procedure (Pid, Type);
dcl  (Pid, Type) char (*);
dcl  pid char (32);
dcl  i fixed bin;

	i = index (Pid, ".");
	if i = 0
	then pid = Pid;
	else pid = substr (Pid, 1, i - 1);
	if pid = "" | pid = "*" then return;
	allocate reference in (temp_area) set (refp);
	reference.type = Type;
	reference.next = null ();

	vrec.pid = pid;
	vrec.chain = refp;
	vrec.in_pnt = "0"b;
	on key (temp_file) begin;
		read file (temp_file) into (vrec) key (pid);
		reference.next = vrec.chain;
		vrec.chain = refp;
		rewrite file (temp_file) from (vrec) key (pid);
	     end;
	write file (temp_file) from (vrec) keyfrom (pid);
     end;						/* ref */

/* * * * * * * * * * TEST * * * * * * * * * */

test: entry (Dirname);
dcl  Dirname char (*) parameter;

	sysdir = Dirname;
	pdtdir = Dirname || ">pdt";
	return;

%include area_info;
%include pdt;
%include pnt_entry;
%include sat;
%include user_attributes;

     end;						/* list_extra_personids */




		    load_ctl_status.pl1             08/29/88  0949.4rew 08/29/88  0856.3       69831



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

/* format: style4 */
lcs: load_ctl_status: proc;

/* print group totals */
/* Modified by T. Casey, July 1975, to print work class information */
/* Modified by T. Casey, September 1977, to count anstbl.extra_units in "all the rest" computation */
/* Modified by G. Dixon, February, 1977 to terminate Answer Table using ansp, to align output columns, to
   support more than 99 users in a group.  */
/* Modified by T. Casey, January 1979 for MR7.0 absentee enhancements */
/* Modified November 1981, E. N. Kittlitz.  user_table_entry conversion. */

/****^  HISTORY COMMENTS:
  1) change(87-04-26,GDixon), approve(87-05-01,MCR7741),
     audit(87-05-06,Parisek), install(87-08-04,MR12.1-1055):
     Upgraded for change to answer_table.incl.pl1.
  2) change(87-08-25,GDixon), approve(88-08-15,MCR7969),
     audit(88-08-04,Lippard), install(88-08-29,MR12.2-1093):
     Correct ioa_ control string. (Answering_Service 354, phx16706)
                                                   END HISTORY COMMENTS */

dcl  sysdir char (168) aligned int static init (">system_control_dir"),
     en char (32) aligned,
     datstr char (16) aligned,
     wcstr char (10) aligned init (""),
     an fixed bin,
     selgp char (8) aligned init (""),
     selgl fixed bin init (0),
     (long, prio_sked, totalsw) bit (1) aligned init ("0"b),
     shift_change_time fixed bin (71),
     (shift, next_shift) fixed bin,
     sysi char (8) aligned,
     inst char (32) aligned,
     (f1, f2, f3, f4, f5) float bin,
     (i, k, n) fixed bin,
     ap ptr,
     al fixed bin,
     bchr char (al) unaligned based (ap),
     first_group fixed bin,
     ec fixed bin,
     fudge_flag char (1),
     extra_units fixed bin,
     whoptr ptr,
     mgtp ptr;

dcl  (addr, null, substr) builtin;

dcl  clock_ entry () returns (fixed bin (71)),
     system_info_$installation_id entry (char (*) aligned),
     system_info_$sysid entry (char (*) aligned),
     system_info_$next_shift_change entry (fixed bin, fixed bin (71), fixed bin),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin),
     ioa_ entry options (variable),
     ioa_$rsnnl entry options (variable),
     ioa_$nnl entry options (variable),
     date_time_ entry (fixed bin (71), char (*) aligned),
     com_err_ entry options (variable);

dcl  hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1),
	fixed bin (2), ptr, fixed bin);
dcl  hcs_$terminate_noname entry (ptr, fixed bin);


	ansp = null;
	k = 0;
	en = "mgt";
try_init: call hcs_$initiate (sysdir, en, "", 0, 1, mgtp, ec);
	if mgtp = null then do;
	     if en = "mgt" then do;			/* TEMPORARY - FOR FIRST RELEASE OF PRIORITY SCHEDULER SYSTEM */
		en = "master_group_table";
		goto try_init;
	     end;
er:	     call com_err_ (ec, "load_ctl_status", en);
	     return;
	end;

	first_group = 1;
	if mgt.version_indicator = "VERSION " then
	     if mgt.version >= 2 then do;
		first_group = 17;
		if mgt.switches.prio_sked_enabled then prio_sked = "1"b;
	     end;

	en = "whotab";
	call hcs_$initiate (sysdir, en, "", 0, 1, whoptr, ec);
	if whoptr = null then go to er;
	f1 = whotab.n_units / 1e1;
	f2 = whotab.mxunits / 1e1;
	call date_time_ ((clock_ ()), datstr);
	call system_info_$next_shift_change (shift, shift_change_time, next_shift);

	an = 1;
arglp:	call cu_$arg_ptr (an, ap, al, ec);
	if ec ^= 0 then go to endarg;
	if al = 0 then ;
	else if substr (bchr, 1, 1) = "-" then do;
	     if bchr = "-lg" then long = "1"b;
	     else if bchr = "-long" then long = "1"b;
	     else if bchr = "-tt" then totalsw = "1"b;
	     else if bchr = "-total" then totalsw = "1"b;
	     else if bchr = "-totals" then totalsw = "1"b;
	     else do;
		call com_err_ (0, "load_ctl_status", "invalid argument ^a", bchr);
		return;
	     end;
	end;
	else do;					/* must be group id */
	     selgp = bchr;
	     selgl = al;
	end;
	an = an + 1;
	go to arglp;

endarg:	if long then do;
	     call system_info_$sysid (sysi);
	     call system_info_$installation_id (inst);
	     call ioa_ ("^/Multics^x^a;^x^a^2x^a^/Load =^x^.1f out of^x^.1f units; users =^x^d absentee = ^d, daemons = ^d",
		sysi, inst, datstr, f1, f2, whotab.n_users, whotab.abs_users, whotab.n_daemons);

	     call date_time_ (shift_change_time, datstr);
	     call ioa_ ("Shift ^d until ^a", shift, datstr);
	end;
	else do;
	     call ioa_ ("^/^16a^x^.1f/^.1f^x^d^x(^d,^d)",
		datstr, f1, f2, whotab.n_users, whotab.abs_users, whotab.n_daemons);
	     if selgl ^= 0 then go to xlp;
	end;

	if prio_sked then do;
	     call ioa_$nnl ("^/Work Classes:");
	     do i = 1 to 16;
		if mgt.user_wc_defined (i) then
		     call ioa_$nnl ("^2x^2d", i);
	     end;
	     call ioa_$nnl ("^/Percents:^4x");
	     do i = 1 to 16;
		if mgt.user_wc_defined (i) then
		     call ioa_$nnl ("^2x^2d", mgt.user_wc_min_pct (i));
	     end;
	     if totalsw then goto exit;		/* if just totals, exit before printing heading */
	     call ioa_ ("^2/Group^3xMaxprime^xMaxabs^2xPrime^xSecondary^2xAbs^4xTot / Max^4xPercent^2xIWC^xAWC^/");
	end;

	else if ^totalsw then
	     call ioa_ ("^/Group^3xMaxprime^xMaxabs^2xPrime^xSecondary^2xAbs^4xTot / Max^4xPercent^/");
xlp:
	if totalsw then goto exit;
	do i = first_group to mgt.current_size;
	     mgtep = addr (mgt.entry (i));
	     if selgl ^= 0 then			/* only one group wanted? */
		if selgp ^= substr (group.group_id, 1, selgl) then go to skip;
	     k = k + 1;
	     fudge_flag = "";
	     if group.max_prim >= 0 then f1 = group.max_prim / 1e1;
	     else do;				/* this group takes "all the rest" */
		call hcs_$initiate (sysdir, "answer_table", "", 0, 1, ansp, ec);
		if ansp ^= null () then
		     extra_units = anstbl.extra_units;
		else do;
		     extra_units = (whotab.abs_users + whotab.n_daemons) * 10;
		     fudge_flag = "*";
		end;
		f1 = (whotab.mxunits - mgt.total_units - extra_units) / 1e1;
	     end;
	     f2 = group.n_prim / 1e1;
	     f3 = group.n_sec / 1e1;
	     f4 = (group.n_prim + group.n_sec) / 1e1;
	     f5 = f4 * 1e3 / whotab.n_units;
	     if group.absolute_max < 32767 then call ioa_$rsnnl ("^5.1f/^.1f", datstr, n,
		     f4, group.absolute_max / 1e1);
	     else call ioa_$rsnnl ("^5.1f/------", datstr, n, f4);
	     if prio_sked then
		call ioa_$rsnnl ("^2x^2d^2x^2d", wcstr, n, group.int_wc (shift), group.abs_wc (shift));
	     call ioa_ ("^8a^3x^5.1f^1a^6d^2x^5.1f^5x^5.1f^5d^3x^12a^3x^5.1f%^a",
		group.group_id, f1, fudge_flag, group.absentee_limit, f2, f3, group.n_abs, datstr, f5, wcstr);
	     if fudge_flag = "*" then
		call ioa_ ("^/* This figure might be inaccurate because you lack read access to the answer table.");
skip:	end;

	if selgl ^= 0 then if k = 0 then call ioa_ ("group ""^a"" not found", selgp);
exit:
	call hcs_$terminate_noname (mgtp, ec);
	call hcs_$terminate_noname (whoptr, ec);
	if ansp ^= null () then
	     call hcs_$terminate_noname (ansp, ec);
	call ioa_ ("");

	return;

test: entry (a_sysdir);

dcl  a_sysdir char (*);

	sysdir = a_sysdir;

%page; %include answer_table;
%page; %include mgt;
%page; %include user_table_header;
%page; %include whotab;


     end load_ctl_status;




		    monitor_quota.pl1               01/16/85  1309.2rew 01/16/85  1305.0      203319



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


monitor_quota:
     proc;


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

   Calculates  remaining  storage  of  a  directory  and  will
   send  a  warning  message at the approach of a record quota
   overflow   condition.

   Written by R. Holmstedt 07/09/81

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

dcl  absolute_pathname_ entry (char (*), char (*), fixed bin (35));
dcl  all_flag init ("0"b) bit (1);
dcl  arg char (argl) based (argp);
dcl  argl fixed bin (21);
dcl  argp ptr;
dcl  argno fixed bin;
dcl  call_flag init ("0"b) bit (1);
dcl  call_limit fixed bin (21) init (0);
dcl  command_line char (command_line_length) based (command_line_ptr); /* argument after -call */
dcl  command_line_length fixed bin;			/* length of command line */
dcl  command_line_ptr ptr;				/* pointer to command line argument */
dcl  convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35));
dcl  convert_date_to_binary_$relative entry (char (*), fixed bin (71),
     fixed bin (71), fixed bin (35));
dcl  code fixed bin (35);
dcl  console_flag init ("0"b) bit (1);
dcl  console_warn_limit fixed bin (21) init (0);
dcl  com_err_ entry () options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cu_$cp entry (ptr, fixed bin (21), fixed bin (35));
dcl (error_table_$action_not_performed, error_table_$moderr, error_table_$noentry,
     error_table_$no_dir, error_table_$no_append, error_table_$messages_off,
     error_table_$inconsistent, error_table_$bad_arg) fixed bin (35) ext static;
dcl  false init ("0"b) bit (1) internal static options (constant);
dcl  hcs_$quota_read entry (char (*), fixed bin (18), fixed bin (71),
     bit (36) aligned, bit (36), fixed bin (1), fixed bin (18),
     fixed bin (35));
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  i fixed bin;
dcl  ioa_$rsnnl entry () options (variable);
dcl  linkage_error condition;
dcl  print_flag init ("0"b) bit (1);
dcl  message char (256) varying init ("");
dcl  message_id (10) char (50) init ((10) (1) "");
dcl  monitor_quota$main entry;
dcl  monitor_quota_init_switch init ("0"b) bit (1) int static;
dcl  monitor_quota_ptr ptr int static init (null);
dcl 01 monitor_list aligned based (monitor_quota_ptr),
    02 monitor_count fixed bin,
    02 monitor (0 refer (monitor_list.monitor_count)),
      03 time fixed bin (71),
      03 record_limit fixed bin (21),
      03 path_name char (168) varying,
      03 call_flag bit (1),
      03 call_limit fixed bin (21),
      03 console_flag bit (1),
      03 console_warn_limit fixed bin (21),
      03 warn_flag bit (1),
      03 warn_limit fixed bin (21),
      03 rpt_time fixed bin (71),
      03 rpt_flag bit (1),
      03 message_id (10) char (50),
      03 command_line_length fixed bin,
      03 command_line char (256);
dcl  nargs fixed bin;
dcl  off_flag init ("0"b) bit (1);
dcl  one_big_number fixed bin (71) init (377777777777777777777) internal static options (constant);
dcl  quota fixed bin (18);
dcl  record_limit fixed bin (21);
dcl  release_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  rpt_flag init ("0"b) bit (1);
dcl  rpt_time fixed bin (71);
dcl  path_flag init ("0"b) bit (1);
dcl  path_name char (168);
dcl  pathname char (168);
dcl  percent fixed bin (6, 3);
dcl  phcs_$ring_0_message entry (char (*));
dcl  prog_name char (13) internal static init ("monitor_quota");
dcl  send_mail_ entry (char (*), char (*), ptr, fixed bin (35));
dcl  send_message_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  sons_lvid bit (36);
dcl  test_entry entry variable;
dcl  time_now fixed bin (71);
dcl  timer_manager_$alarm_call entry (fixed bin (71), bit (2), entry);
dcl  timer_manager_$reset_alarm_call entry (entry);
dcl  true init ("1"b) bit (1) internal static options (constant);
dcl  trp fixed bin (71);
dcl  tup bit (36) aligned;
dcl  tacc_sw fixed bin (1);
dcl  used fixed bin (18);
dcl  warn char (256) varying;
dcl  warn_flag init ("0"b) bit (1);
dcl  warn_limit fixed bin (21) init (0);
dcl (after, before, convert, null, index, addr, substr, length, rtrim, clock, divide) builtin;
dcl  conversion condition;


/* ***********  S T A R T************* */

command_args:


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*					       */
/* This procedure will define the arguments used for     */
/* the command to process. Some checking is done on      */
/* arguments passed in as to valid characters	       */
/*					       */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	on conversion goto num_error;

	call cu_$arg_count (nargs);

	do argno = 1 to nargs;


	     call cu_$arg_ptr (argno, argp, argl, code);
	     if code ^= 0 then goto bad_arg;

arg_scan:	     if substr (arg, 1, 1) = "-" then do;

		if arg = "-pathname" | arg = "-pn" then do;
						/* directory to monitor	       */
		     if path_flag then goto dup_arg;
		     path_flag = true;
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, argp, argl, code);
		     if code ^= 0 then goto bad_arg;
		     if substr (arg, 1, 1) = "-" then goto bad_arg;
		     pathname = rtrim (arg);
		     call absolute_pathname_ (pathname, path_name, code);
		     if code ^= 0 then goto bad_arg;
		end;

		else if arg = "-call" then do;
						/* a command line is to be executed if quota used exceeds limit */
		     if call_flag then go to dup_arg;
		     call_flag = true;
		     argno = argno + 1;

		     call cu_$arg_ptr (argno, argp, argl, code);
		     if code ^= 0 then goto bad_arg;
		     if substr (arg, 1, 1) = "-" then goto bad_arg;
		     command_line_length = length (arg);
		     command_line_ptr = addr (arg);
		     command_line = arg;
		     argno = argno + 1;		/* see if record count given */
		     if argno > nargs then goto EOL;
		     call cu_$arg_ptr (argno, argp, argl, code);
		     if code ^= 0 then goto bad_arg;
		     if substr (arg, 1, 1) = "-" then goto arg_scan;
		     call_limit = convert (call_limit, (arg));
		end;

		else if arg = "-console" then do;
						/* send warning to system console    */
		     if console_flag then goto dup_arg;
		     console_flag = true;
		     on linkage_error goto test_link_fail;
						/* this is how to test if the user has access or not, before making the call */
		     test_entry = phcs_$ring_0_message;
		     revert linkage_error;
		     argno = argno + 1;		/* see if record count given */
		     if argno > nargs then goto EOL;
		     call cu_$arg_ptr (argno, argp, argl, code);
		     if code ^= 0 then return;
		     if substr (arg, 1, 1) = "-" then goto arg_scan;
		     console_warn_limit = convert (console_warn_limit, (arg));
		end;

		else if arg = "-warn" then do;
						/* send warning to this person       */
		     if warn_flag then goto dup_arg;
		     warn_flag = true;
		     argno = argno + 1;		/* get the person_id.proj_id */
		     call cu_$arg_ptr (argno, argp, argl, code);
		     if code ^= 0 then goto bad_arg;
		     if index (arg, ".") = 0 then go to bad_arg;
		     send_mail_info.version = send_mail_info_version_2;
		     send_mail_info.mbz1 = false;
		     send_mail_info.mbz = false;
		     send_mail_info.sent_from = "";
		     send_mail_info.wakeup = true;
		     send_mail_info.always_add = false;
		     send_mail_info.never_add = true;
		     send_mail_info.notify = false;
		     send_mail_info.acknowledge = false;
		     do i = 1 to 10 while (index (arg, ".") ^= 0);
			message_id (i) = arg;
			call send_mail_ (arg, "", addr (send_mail_info), code);
			if code ^= 0 then do;
			     if code ^= error_table_$messages_off then do;
				if code = error_table_$noentry | code = error_table_$no_dir then
				     warn = "No mailbox for "||arg;
				else if code = error_table_$no_append then
				     warn = "Insufficient access to add a message to "||arg||" mailbox";
				else warn = "Sending message to  "||arg;
				goto non_fatal_warn;
			     end;
			end;

			argno = argno + 1;		/* get the person_id.proj_id */
			if argno > nargs then goto EOL;
			call cu_$arg_ptr (argno, argp, argl, code);
			if code ^= 0 then goto bad_arg;
		     end;
		     if substr (arg, 1, 1) = "-" then goto arg_scan;
		     warn_limit = convert (call_limit, (arg));
		end;

		else if arg = "-off" then do;
		     if nargs ^= 1 then do;
			warn = "-off must not be given with any other arguments.";
			code = error_table_$inconsistent;
			goto non_fatal_warn;
		     end;

		     off_flag = true;
		end;

		else if arg = "-print" | arg = "-pr" then do;
		     if nargs ^= 1 then do;
			warn = "-print must not be given with any other arguments.";
			code = error_table_$inconsistent;
			goto non_fatal_warn;
		     end;

		     print_flag = true;
		end;

		else if arg = "-repeat" | arg = "-rpt" then do;
		     if rpt_flag then goto dup_arg;
		     rpt_flag = true;
		     argno = argno + 1;		/* get the repeat time */
		     call cu_$arg_ptr (argno, argp, argl, code);
		     if code ^= 0 then goto bad_arg;
		     time_now = clock ();
		     if code ^= 0 then goto bad_arg;
		     call convert_date_to_binary_$relative (arg, rpt_time, time_now, code);
		     if code ^= 0 then goto bad_arg;
						/* now get the difference	       */
		     rpt_time = rpt_time - time_now;


		end;
		else goto bad_arg;
	     end;
	     else goto bad_arg;
	end;
EOL:						/* thats end of line	       */
	revert conversion;

	call set_up ();
	goto fini;


/* \014 */
set_up:	proc;

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

   This procedure will evaluate the command arguments and provide
   the defaults where needed.

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

dcl date_time_ entry (fixed bin(71), char(*));
dcl  get_wdir_ entry () returns (char (168));
dcl  ioa_	entry() options(variable);
dcl  time_to_print char (24);
dcl  user_info_ entry (char (*), char (*), char (*));
dcl  user_name char (22);
dcl  user_proj char (9);
dcl  user_acct char (32);

	     if print_flag then do;	/* show user information on monitors */
		if monitor_quota_init_switch = false then do;
				/* nothing to monitor	       */
		     call ioa_ ("monitor_quota: There are no requests active.");
		     return;
		end;
		
		do i = 1 to monitor_list.monitor_count;
				/* go thru the list		       */

		     call date_time_ (monitor_list.monitor (i).time, time_to_print);
		     call ioa_ ("^/^d)  ^a^/next wakeup interval: ^a  ^/^[warn limit: ^d^;^s^]    ^[console warning limit: ^d^;^s^]    ^[call warning limit: ^d^;^s^]",
		     i,
		     monitor_list.monitor (i).path_name,
		     time_to_print,
		     monitor_list.monitor (i).warn_flag,
		     monitor_list.monitor (i).warn_limit,
		     monitor_list.monitor (i).console_flag,
		     monitor_list.monitor (i).console_warn_limit,
		     monitor_list.monitor (i).call_flag,
		     monitor_list.monitor (i).call_limit);
		end;
		return;
	     end;
	     

	     if off_flag then do;			/* stop all monitoring	       */
		if monitor_quota_init_switch = false then goto fini;
		else call cleanup;
		return;
	     end;


	     if ^path_flag then path_name = get_wdir_ ();
						/* if we don't have a directory get one */

	     call hcs_$quota_read ((path_name), quota, trp, tup, sons_lvid, tacc_sw, used, code);
	     if code ^= 0 then do;
		warn = "Error reading quota for " ||rtrim (path_name)||".";
		goto non_fatal_warn;
	     end;

/* figure out record limit to monitor       */
	     if warn_limit = 0 & console_warn_limit = 0 & quota = 0 & ^call_flag then do;

		code = error_table_$action_not_performed;
		warn = "The quota of "||rtrim (path_name)||" is 0, a record limit needs to be specified.";
		goto non_fatal_warn;
	     end;

	     if call_limit > quota | warn_limit > quota | console_warn_limit > quota then do;
		warn = "Record limit specified is larger than the quota in " ||rtrim (path_name)||".";
		code = error_table_$bad_arg;
		goto non_fatal_warn;
	     end;

	     if warn_limit = 0 & console_warn_limit = 0 then record_limit = quota * .80;
						/* set it to 80% of the dir. quota  */
	     else do;
		if console_warn_limit ^= 0 & warn_limit = 0 then record_limit = console_warn_limit;
		if warn_limit ^= 0 & console_warn_limit = 0 then record_limit = warn_limit;
		if console_warn_limit ^= 0 & warn_limit ^= 0 then do;
		     record_limit = console_warn_limit;
		     if warn_limit < record_limit then record_limit = warn_limit;
		end;
	     end;

	     if call_flag then do;

		if call_limit = 0 & quota = 0 then do;
		     code = error_table_$action_not_performed;
		     warn = "The quota of "||rtrim (path_name)||" is 0, a record limit needs to be specified.";
		     goto non_fatal_warn;
		end;

		if call_limit = 0 then call_limit = quota * .90;
						/* set it to 90% of the dir. if user didn't set it */
		if call_limit < record_limit then record_limit = call_limit;

	     end;

	     if ^rpt_flag then			/* figure out a good repeat time     */
		call repeat_calc (quota, used, rpt_time);


	     if ^warn_flag & ^console_flag & ^call_flag then do;

/* need to find somebody to tell */
		call user_info_ (user_name, user_proj, user_acct);
		message_id (1) = rtrim (user_name)||"."||rtrim (user_proj);
		warn_flag = true;
		warn_limit = record_limit;
	     end;


	     if monitor_quota_init_switch = false then do;
						/* set up static area to keep information about quota */
		call get_temp_segment_ (prog_name, monitor_quota_ptr, code);
		if code ^= 0 then do;
		     warn = "Error from get_temp_segments_.";
		     goto bummer;
		end;

		monitor_list.monitor_count = 0;
		monitor_quota_init_switch = true;
	     end;

	     monitor_list.monitor_count = monitor_list.monitor_count + 1;
						/* add another directory to be monitored */
	     monitor_list.monitor (monitor_count).record_limit = record_limit;
	     monitor_list.monitor (monitor_count).path_name = rtrim (path_name);
	     monitor_list.monitor (monitor_count).call_flag = call_flag;
	     monitor_list.monitor (monitor_count).call_limit = call_limit;
	     monitor_list.monitor (monitor_count).console_flag = console_flag;
	     monitor_list.monitor (monitor_count).console_warn_limit = console_warn_limit;
	     monitor_list.monitor (monitor_count).rpt_time = rpt_time;
	     monitor_list.monitor (monitor_count).rpt_flag = rpt_flag;
	     monitor_list.monitor (monitor_count).warn_flag = warn_flag;
	     monitor_list.monitor (monitor_count).warn_limit = warn_limit;
	     monitor_list.monitor (monitor_count).time = time_now + monitor_list.monitor (monitor_count).rpt_time;

	     if call_flag then do;
		monitor_list.monitor (monitor_count).command_line_length = command_line_length;
		monitor_list.monitor (monitor_count).command_line = command_line;
	     end;
	     else do;
		monitor_list.monitor (monitor_count).command_line_length = 0;
		monitor_list.monitor (monitor_count).command_line = "";
	     end;

	     do i = 1 to 10;
		monitor_list.monitor (monitor_count).message_id (i) = message_id (i);
	     end;

	     if record_limit < used then		/* quota problem already! */
		call convert_date_to_binary_ ("", monitor_list.monitor (monitor_count).time, code);
						/* will look like it matured	       */


	     call main ();
	     return;
	end set_up;
						/* \014 */
repeat_calc: proc (dir_quota, dir_used, repeat);
dcl  dir_quota fixed bin (18);
dcl  dir_used fixed bin (18);
dcl  repeat fixed bin (71);
dcl  percent fixed bin (6, 3);
dcl  time_value char (5) varying;

	     percent = divide ((dir_used * 100), dir_quota, 5, 0) ;

	     if percent < 50 then time_value = "30min";
	     else if percent < 60 then time_value = "20min";
	     else if percent < 70 then time_value = "10min";
	     else if percent < 80 then time_value = "5min";
	     else if percent > 90 then time_value = "1min";
	     else time_value = "2min";

	     time_now = clock ();
	     call convert_date_to_binary_$relative ((time_value), repeat, time_now, code);
	     if code ^= 0 then do;
		warn = "Error on calculation of repeat value "||time_value||".";
		goto bummer;
	     end;
						/* now get the difference	       */
	     repeat = repeat - time_now;

	     return;
	end repeat_calc;
						/* \014 */
main:	entry;

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

   This entry scans the monitor_list when the alarm timer
   calls into this entry. The next alarm time is calculated
   for all entrys and  the smallest time is selected for
   the next alarm.
   *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


dcl  alarm_time fixed bin (71);
dcl  j fixed bin;



	alarm_time = one_big_number;
						/* need a starting point to compair */
	call timer_manager_$reset_alarm_call (monitor_quota$main);
	time_now = clock ();			/* get the time now		       */



	do i = 1 to monitor_list.monitor_count;
	     if monitor_list.monitor (i).time < time_now then do;
						/* time to check		       */

		call hcs_$quota_read ((monitor_list.monitor (i).path_name),
		     quota, trp, tup, sons_lvid, tacc_sw, used, code);
		if code ^= 0 then do;
		     warn = "Error reading quota for " ||monitor_list.monitor (i).path_name||".";
		     goto bummer;
		end;

		if quota = 0 then do;    /* this will check if directory quota was changed to 0*/
		     if monitor_list.monitor_count > 1 then monitor_list.monitor (i).time = one_big_number;
						/* this should stop monitoring for this only */
		     code = error_table_$action_not_performed;
		     warn = "The quota for " ||monitor_list.monitor (i).path_name ||" has been changed to zero.";
		     goto non_fatal_warn;
		end;

		if used < monitor_list.monitor (i).record_limit then do;
						/* nothing to worry about 	       */

		     if ^monitor_list.monitor (monitor_count).rpt_flag then
			call repeat_calc (quota, used, monitor_list.monitor (i).rpt_time);

		     monitor_list.monitor (i).time = time_now + monitor_list.monitor (i).rpt_time;
		     if monitor_list.monitor (i).time < alarm_time then
			alarm_time = monitor_list.monitor (i).time;
						/* set wakeup time to lowest time needed */

		end;

		else do;				/* we used more then the limit       */
		     if monitor_list.monitor (i).console_flag then do;
			if monitor_list.monitor (i).console_warn_limit <= used then do;
			     percent = divide ((used * 100), quota, 5, 0) ;
			     message = "";
			     call ioa_$rsnnl ("^a: Storage in ^a is ^d% full.",
				message, (0), prog_name, (monitor_list.monitor (i).path_name), percent);
						/* error message		       */


			     on linkage_error go to call_1_failed;

			     call phcs_$ring_0_message ((message));
			     revert linkage_error;	/* It worked */
			end;
		     end;

		     if monitor_list.monitor (i).warn_flag then do;
			if monitor_list.monitor (i).warn_limit <= used then do;
						/* check to be sure, may only have call limit or console limit */
			     percent = divide ((used * 100), quota, 5, 0) ;
			     message = "";
			     call ioa_$rsnnl ("^a: Storage in ^a is ^d% full.",
				message, (0), prog_name, (monitor_list.monitor (i).path_name), percent);
			     do j = 1 to 10 while (monitor_list.monitor (i).message_id (j) ^= "");
				call send_message_ ((before (monitor_list.monitor (i).message_id (j), ".")),
				     (after (monitor_list.monitor (i).message_id (j), ".")),
				     (message), code);
				if code ^= 0 then
				     call com_err_ (code, prog_name,
				     "Error sending warning to ^a ^/Quota limit reached in ^a. Monitoring will continue.",
				     monitor_list.monitor (i).message_id (j), monitor_list.monitor (i).path_name);
						/* tell someone		       */
			     end;
			end;

		     end;


		     if monitor_list.monitor (i).call_flag then do;
			if monitor_list.monitor (i).call_limit <= used then do;
			     call cu_$cp (addr (monitor_list.monitor (i).command_line),
				length (monitor_list.monitor (i).command_line), code);
			     if code ^= 0 then do;
				warn = "Error calling "||rtrim (monitor_list.monitor (i).command_line)|| ".";
				goto non_fatal_warn;
			     end;
			end;
		     end;
		     if ^monitor_list.monitor (monitor_count).rpt_flag then
			call repeat_calc (quota, used, monitor_list.monitor (i).rpt_time);

		     monitor_list.monitor (i).time = monitor_list.monitor (i).time + monitor_list.monitor (i).rpt_time;

		     if monitor_list.monitor (i).time < alarm_time then
			alarm_time = monitor_list.monitor (i).time;
						/* set wakeup time to lowest time needed */


		end;				/* end of quota problem	       */

	     end;

	     else if monitor_list.monitor (i).time < alarm_time then alarm_time = monitor_list.monitor (i).time;
	end;
						/* set to the next wake up	       */

	call timer_manager_$alarm_call ((alarm_time), "00"b, monitor_quota$main);
	return;






/* \014 */
test_link_fail:
	revert linkage_error;
	code = error_table_$moderr;
	warn = "Access required to phcs_ to send warning to system console.";
	goto non_fatal_warn;
call_1_failed:
	revert linkage_error;
	if monitor_list.monitor_count > 1 then monitor_list.monitor (i).time = one_big_number;
						/* this should stop monitoring for this only */
	code = error_table_$moderr;
	warn = "Access required to phcs_ to send warning to system console.";
	goto non_fatal_warn;
non_fatal_warn:					/* don't delete the other monitor entries */
	if monitor_quota_ptr ^= null then do;
	     if monitor_list.monitor_count >1 then do;
		call com_err_ (code, prog_name, "^/^a", warn);
		return;
	     end;
	end;
	goto bummer;
						/* cleanup and go away	       */

num_error:
	revert conversion;

bad_arg:
	code = error_table_$bad_arg;
	warn = arg;
	call com_err_ (code, prog_name, "^a", warn);
	return;


dup_arg:
	code = error_table_$inconsistent;
	warn = arg || " appears twice on the command line.";
	goto non_fatal_warn;
bummer:
	call com_err_ (code, prog_name, "^/^a", warn);
	call cleanup;
	return;

cleanup:	proc;
	     call timer_manager_$reset_alarm_call (monitor_quota$main);
	     if monitor_quota_init_switch ^= false then do;
		call release_temp_segment_ (prog_name, monitor_quota_ptr, code);
		monitor_quota_init_switch = false;
	     end;
	     return;
	end;
fini:
	return;
%include send_mail_info;
     end monitor_quota;




		    mos_edac_summary.pl1            03/14/85  0810.8r w 03/13/85  1100.2      148626



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


/* MOS_EDAC_SUMMARY: Command to summarize MOS Memory EDAC errors from the syserr log */

/* Written June 1979 by Larry Johnson */
/* Most of this program was borrowed from the io_error_summary command. */
/* Completed for installation December 1979 by Rich Coppola */
/* Modified July 1983 by Paul Farley to change call to sys_info_$time_delta,
   which does not exist, to time_data_$time_delta, which also allows for
   per-process time zone selection (phx15295). */

mos_edac_summary: mes:  proc;

dcl  name char (17) int static options (constant) init ("mos_edac_summary"); /* Name of procedure */
dcl  code fixed bin (35);				/* Standard system status code */
dcl  open_status bit (36) aligned;			/* Code from syserr_log_util_$open */
dcl  ptr_array (1) ptr;				/* An array of pointers as required by get_temp_segment_ */
dcl  tab_cnt fixed bin init (0);			/* Number of seperate status found */
dcl  mask bit (36) aligned init ("0"b);			/* Mask of significant bits in status word */
dcl  arg_ptr ptr;					/* Pointer to an argument */
dcl  arg_len fixed bin;				/* Length of an argument */
dcl  arg char (arg_len) based (arg_ptr);		/* A command argument */
dcl  arg_count fixed bin;				/* The number of arguments */
dcl  arg_list_ptr ptr;				/* Pointer to commands argument list */
dcl  for_ptr ptr;					/* Saved pointer to the -for argument */
dcl  for_len fixed bin;				/* Saved length of -for argument */
dcl  for_arg char (for_len) based (for_ptr);		/* This is the -for argument */
dcl  from_sw bit (1) init ("0"b);			/* Set if -from used */
dcl  to_sw bit (1) init ("0"b);			/* Set if -to used */
dcl  for_sw bit (1) init ("0"b);			/* Set if -for used */
dcl  more_args bit (1);				/* Set while there are more arguments to scan */
dcl  from_time fixed bin (71);			/* Time specified on -from */
dcl  to_time fixed bin (71);				/* Time specified on -to */
dcl  for_time fixed bin (71);				/* Time specified on -for */
dcl  count_limit fixed bin init (0);			/* Results for -limit arg */
dcl  day_limit fixed bin init (0);			/* Results for -day_limit arg */
dcl  workp ptr;					/* Pointer to work segment */
dcl  arg_no fixed bin init (1);			/* For scanning argument list */
dcl  errentp ptr;					/* Pointer to status table entry */
dcl  msg_time fixed bin (71);				/* Time of syserr message */
dcl  msg_seq fixed bin (35);				/* Sequence number */
dcl  scu_cnt fixed bin init (0);			/* Number of MEMs requested */
dcl  err_cnt fixed bin init (0);			/* Entries in status table */
dcl  segs_allocated bit (1) init ("0"b);		/* Set after work segments created */
dcl  sort_listp ptr;
dcl  us_per_day fixed bin (71);			/* micro-seconds per day */

dcl 1 work aligned based (workp),			/* Declaration of work segment */
    2 scureq (32) char (7) var,			/* Table of requested MEMs */
    2 buffer (500) bit (36) aligned,			/* Syserr messages are read here */
    2 errentry (err_cnt + 1) like err;			/* Entry for each different error */

dcl 1 err aligned based (errentp),			/* Entry for each different error syndrome found */
    2 mem char (1) unal,
    2 store char (2) unal,
    2 count fixed bin (35),
    2 ZAC_line bit (6) unal,
    2 syndrome bit (8) unal,
    2 identification bit (4) unal,
    2 day_count fixed bin (18) uns unal,
    2 day_list (16) fixed bin (18) uns unal;

dcl 1 sort_list aligned based (sort_listp),
    2 count fixed bin,
    2 errentp (sort_list.count) ptr unal;

dcl  sort_items_$general entry (ptr, entry);
dcl  syserr_log_util_$open entry (bit (36) aligned, fixed bin (35));
dcl  print_syserr_msg_$open_err entry (bit (36) aligned, char (*), fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  get_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35));
dcl  syserr_log_util_$read entry (ptr, fixed bin, fixed bin, fixed bin (35));
dcl  syserr_log_util_$close entry (fixed bin (35));
dcl  release_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  syserr_log_util_$search entry (fixed bin (71), fixed bin (71), fixed bin (35), fixed bin (35));
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  cu_$arg_list_ptr entry (ptr);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr);
dcl  edit_mos_rscr_$decode entry (ptr, char (*), char (*));
dcl  convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35));
dcl  convert_date_to_binary_$relative entry (char (*), fixed bin (71), fixed bin (71), fixed bin (35));

dcl  time_data_$time_delta ext fixed bin (71);

dcl  error_table_$end_of_info ext fixed bin (35);
dcl  error_table_$badopt ext fixed bin (35);

dcl (cleanup, conversion) condition;

dcl (addr, bin, divide, hbound, index, substr) builtin;

/* Initialization */

	on cleanup call clean_up;

	call get_temp_segments_ (name, ptr_array, code);	/* Get a work segment */
	if code ^= 0 then do;
	     call com_err_ (code, name, "Can't get temp segment");
	     go to done;
	end;
	segs_allocated = "1"b;			/* Remember that they are allocated */
	workp = ptr_array (1);			/* Copy pointer to my segment */

	call cu_$arg_list_ptr (arg_list_ptr);		/* Need pointer to argument list */
	call cu_$arg_count (arg_count);		/* And the length */
	more_args = (arg_count > 0);			/* Set if args to scan */
	call scan_args;				/* Scan the argument list */

	call syserr_log_util_$open (open_status, code);	/* Open the syserr log */
	if code ^= 0 | substr (open_status, 1, 2) ^= "11"b then do; /* If error */
	     call print_syserr_msg_$open_err (open_status, name, code);
	     if code ^= 0 then go to done;		/* Not recoverable */
	end;

	if ^from_sw then do;			/* No -from, so start at beginning */
	     call syserr_log_util_$search (0, msg_time, msg_seq, code);
	     if code ^= 0 then do;
		call com_err_ (code, name, "Can't find first message in log.");
		go to done;
	     end;
	     from_time = msg_time;			/* Official starting time */
	end;
	else do;					/* -from used, find right message */
	     call syserr_log_util_$search (from_time, msg_time, msg_seq, code);
	     if code ^= 0 then do;
		call com_err_ (code, name, "Locating first message requested.");
		go to done;
	     end;
	end;

	if for_sw then do;				/* Now can compute -for limit */
	     call convert_date_to_binary_$relative (for_arg, to_time, from_time, code);
	     if code ^= 0 then do;
		call com_err_ (code, name, "-for ^a", for_arg);
		go to done;
	     end;
	     to_sw = "1"b;				/* Now, just as if -to was specified */
	end;
	if ^to_sw then to_time = from_time;		/* Initialize last message time */

	syserr_msgp = addr (work.buffer);		/* Read here */

/* Loop thru the file */

loop:	call syserr_log_util_$read (syserr_msgp, hbound (buffer, 1), (0), code);
	if code ^= 0 then do;
	     if code = error_table_$end_of_info then go to print;
	     call com_err_ (code, name, "Reading syserr log");
	     go to done;
	end;

	if to_sw then do;				/* If time limit */
	     if syserr_msg.time > to_time then go to print;
	end;
	else to_time = syserr_msg.time;		/* Save last message time */

	if syserr_msg.data_code = SB_mos_err & syserr_msg.data_size > 0 then
	     call count_it;
	go to loop;

/* End of log reached */

print:	call sort_it;				/* Sort the table */
	call print_it;				/* Print results */

/* End of command */

done:	call clean_up;
	return;

/* Procedure to scan the argument list */

scan_args: proc;

	     do while (more_args);			/* Do while thins to look at */
		call get_arg;
		if arg = "-from" | arg = "-fm" then do;		/* Start time */
		     from_sw = "1"b;
		     call time_arg (from_time);
		end;
		else if arg = "-to" then do;		/* Ending time */
		     to_sw = "1"b;
		     call time_arg (to_time);
		end;
		else if arg = "-for" then do;		/* Time limit */
		     for_sw = "1"b;
		     call time_arg (for_time);	/* For syntax checking only */
		     for_len = arg_len;		/* Save pointer to this argument */
		     for_ptr = arg_ptr;
		end;
		else if arg = "-limit" then count_limit = decimal_arg ();
		else if arg = "-day_limit" then do;
		     day_limit = decimal_arg ();
		     if day_limit > 16 then do;
			call com_err_ (0, name, "Maximum value for -day_limit is 16.");
			go to done;
		     end;
		     us_per_day = 24*60*60*1000000;
		end;
		else if arg = "-mem" then do; /* List of MEMs */
		     if ^more_args then do;		/* Need more args */
no_scu:			call com_err_ (0, name, "Argument missing after -MEM");
			go to done;
		     end;
		     call get_arg;
		     if substr (arg, 1, 1) = "-" then go to no_scu; /* Shouldn't be control arg */
new_scu:
		     if (length (arg) > 1) | (index ("abcdefgh", arg) = 0) then do;
			
			call com_err_ (0, name, "Invalid mem specified ""^a""", arg);
			go to done;
		     end;
		     

		     scu_cnt = scu_cnt + 1;		/* Count MEM found */
		     work.scureq (scu_cnt) = arg;	/* Save name */
		     if more_args then do;		/* If more to scan */
			call get_arg;
			if substr (arg, 1, 1) ^= "-" then do; /* Found another MEM */
			     if scu_cnt < hbound (work.scureq, 1) then go to new_scu;
			     else do;		/* Too many */
				call com_err_ (0, name, "There were more than ^d MEMs specified.",
				     hbound (work.scureq, 1));
				go to done;
			     end;
			end;
			else call put_arg;		/* Went too far, back up 1 */
		     end;
		end;
		else do;				/* Bad arg */
		     call com_err_ (error_table_$badopt, name, "^a", arg);
		     go to done;
		end;
	     end;

	     if to_sw & for_sw then do;		/* Conflict */
		call com_err_ (0, name, "Conflicting arguments: -to and -for");
		go to done;
	     end;

	     return;

	end scan_args;

/* Procedure to return the next argument from command line */

get_arg:	proc;

	     call cu_$arg_ptr_rel (arg_no, arg_ptr, arg_len, code, arg_list_ptr);
	     if code ^= 0 then do;			/* Should never happen */
		call com_err_ (code, name, "Arg ^d", arg_no);
		go to done;
	     end;
	     arg_no = arg_no + 1;			/* For next call */
	     more_args = (arg_no <= arg_count);
	     return;

put_arg:	     entry;				/* Entry to return argument after scanning too far */
	     arg_no = arg_no - 1;
	     more_args = (arg_no <= arg_count);
	     return;

	end get_arg;

/* Procedure to convert a time argument */

time_arg:	proc (t);

dcl  t fixed bin (71);				/* The time to ouput */
dcl  arg_copy char (10) var;				/* Save copy of arg here */

	     arg_copy = arg;
	     if ^more_args then do;			/* Must be more */
		call com_err_ (0, name, "Argument required after ^a.", arg_copy);
		go to done;
	     end;
	     call get_arg;
	     call convert_date_to_binary_ (arg, t, code);
	     if code ^= 0 then do;
		call com_err_ (code, name, "^a ^a", arg_copy, arg);
		go to done;
	     end;

	     return;

	end time_arg;

/* Procedure to convert a decimal argument */

decimal_arg: proc returns (fixed bin);

dcl  arg_copy char (10) var;

	     arg_copy = arg;
	     if ^more_args then do;
		call com_err_ (0, name, "Argument required after ^a.", arg_copy);
		go to done;
	     end;
	     call get_arg;
	     on conversion go to bad_dec_arg;
	     return (bin (arg));

bad_dec_arg:   call com_err_ (0, name, "Invalid ^a: ^a", arg_copy, arg);
	     go to done;

	end decimal_arg;

/* Procedure to count an EDAC */

count_it:	proc;

dcl  (i, j) fixed bin;
dcl  found bit (1);
dcl  mem char (1);
dcl  store char (2);
dcl  day_no fixed bin;

	     found = "0"b;
	     scrp = addr (syserr_msg.data);
	     i = index (syserr_msg.text, " mem ");
	     if i = 0 then do;
unparsable:	call com_err_ (0, name, "Unparsable syserr message. Text: ^a", syserr_msg.text);
		return;
	     end;
	     mem = substr (syserr_msg.text, i + 5, 1);

	     if scu_cnt > 0 then
		do j = 1 to scu_cnt while (found = "0"b);
		if mem = work.scureq (j) then
		     found = "1"b;
	     end;

	     if scu_cnt > 0 then
		if ^found then
		return;			/*  don't count this one */
	     else;
	     

	     i = index (syserr_msg.text, " store ");
	     if i = 0 then go to unparsable;
	     store = substr (syserr_msg.text, i+7, 2);
	     if substr (store, 2, 1) = "." then substr (store, 2, 1) = " ";

	     do i = 1 to err_cnt;
		errentp = addr (work.errentry (i));
		if err.mem = mem & err.store = store & err.ZAC_line = scr_su.ZAC_line &
		err.syndrome = scr_su.syndrome & err.identification = scr_su.identification then do;
		     err.count = err.count + 1;
		     go to check_day;
		end;
	     end;

	     err_cnt = err_cnt + 1;
	     errentp = addr (work.errentry (err_cnt));
	     err.mem = mem;
	     err.store = store;
	     err.count = 1;
	     err.day_count = 0;
	     err.ZAC_line = scr_su.ZAC_line;
	     err.syndrome = scr_su.syndrome;
	     err.identification = scr_su.identification;

check_day:     if day_limit <= 0 then return;
	     day_no = divide (syserr_msg.time - time_data_$time_delta, us_per_day, 17, 0);
	     do i = 1 to err.day_count;
		if err.day_list (i) = day_no then return;
	     end;
	     if err.day_count = hbound (err.day_list, 1) then return;
	     err.day_count = err.day_count + 1;
	     err.day_list (err.day_count) = day_no;

	     return;

	end count_it;

/* Procedure to sort the table */

sort_it:	proc;

dcl  i fixed bin;
dcl  sort_count fixed bin;

	     sort_listp = addr (work.errentry (err_cnt + 1)); /* Use next available word */
	     sort_list.count = err_cnt;		/* TEMP FIX */
	     sort_count = 0;
	     do i = 1 to err_cnt;
		errentp = addr (work.errentry (i));
		if err.count >= count_limit & err.day_count >= day_limit then do;
		     sort_count = sort_count+1;
		     sort_list.errentp (sort_count) = addr (work.errentry (i));
		end;
	     end;
	     sort_list.count = sort_count;
	     if sort_count < 2 then return;
	     call sort_items_$general (sort_listp, compare_error);
	     return;

	end sort_it;

compare_error: proc (p1, p2) returns (fixed bin (1));

dcl (p1, p2) ptr unal;

	     if p1 -> err.mem < p2 -> err.mem then return (-1);
	     if p1 -> err.mem > p2 -> err.mem then return (+1);
	     if p1 -> err.store < p2 -> err.store then return (-1);
	     if p1 -> err.store > p2 -> err.store then return (+1);
	     if p1 -> err.count < p2 -> err.count then return (+1);
	     if p1 -> err.count > p2 -> err.count then return (-1);
	     return (0);

	end compare_error;

/* Procedure to print results */

print_it:	proc;

dcl (tm1, tm2) char (24);				/* For editing times */
dcl  work bit (72) aligned;
dcl  mem_type char (32);
dcl  error char (32);
dcl  i fixed bin;
dcl  prev_mem char (1);
dcl  print_mem char (1);
dcl  prev_store char (2);
dcl  print_store char (2);
dcl  prev_type char (32);
dcl  print_type char (32);

	     call date_time_ (from_time, tm1);
	     call date_time_ (to_time, tm2);
	     call ioa_ ("Summary from ^a to ^a^/^/MEM STORE CNT  TYPE                 SYNDROME DECODE", tm1, tm2);
	     prev_mem, prev_store, prev_type = "";
	     scrp = addr (work);
	     do i = 1 to sort_list.count;
		errentp = sort_list.errentp (i);
		work = "0"b;
		scr_su.ZAC_line = err.ZAC_line;
		scr_su.syndrome = err.syndrome;
		scr_su.identification = err.identification;
		call edit_mos_rscr_$decode (scrp, mem_type, error);
		if err.mem = prev_mem then do;
		     print_mem = "";
		     if err.store = prev_store then do;
			print_store = "";
			if mem_type = prev_type then print_type = "";
			else print_type = mem_type;
		     end;
		     else do;
			print_store = err.store;
			print_type = mem_type;
		     end;
		end;
		else do;
		     call ioa_ ("");
		     print_mem = err.mem;
		     print_store = err.store;
		     print_type = mem_type;
		end;
		prev_type = mem_type;
		prev_mem = err.mem;
		prev_store = err.store;
		call ioa_ (" ^1a   ^2a^6d  ^20a ^a", print_mem, print_store, err.count, print_type, error);
	     end;
	     return;

	end print_it;

/* Cleanup handler */

clean_up:	proc;

	     call syserr_log_util_$close (code);

	     if segs_allocated then do;
		segs_allocated = "0"b;
		call release_temp_segments_ (name, ptr_array, code);
	     end;
	     return;

	end clean_up;



%include syserr_message;

%include scr;

%include syserr_binary_def;

     end mos_edac_summary;




		    print_projfile.pl1              08/29/88  0949.4rew 08/29/88  0858.6       42426



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

print_projfile: proc;

/* Print out "projfile" */
/*
   Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures. (UNCA)
   Modified June 1981 by E. N. Kittlitz for UNCA rate structures.
   Modified 1984-08-27 BIM for projfile version, unaligned strings.
*/


/****^  HISTORY COMMENTS:
  1) change(87-08-11,GDixon), approve(88-08-15,MCR7969),
     audit(88-08-04,Lippard), install(88-08-29,MR12.2-1093):
     Set ec error code when only rate structure 0 is used. (phx14422)
                                                   END HISTORY COMMENTS */


dcl  ap ptr,
     al fixed bin (21),
     bchr char (al) based (ap),
     dn char (168),
    (dt1, dt2) char (8),
     x (0:7) float bin,
     disk_price (0:9) float bin,
     dcost float bin,
    (co, dp) char (64) aligned,
     en char (32),
    (i, np) fixed;
dcl  pp ptr;
dcl  ec fixed bin (35);
dcl  rs_number fixed bin;				/* rate structure index */
dcl  max_rs_number fixed bin;

dcl  com_err_ entry options (variable),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
     get_wdir_ entry () returns (char (168)),
     cv_$mwvf entry (float bin) returns (char (15)),
     date_time_ entry (fixed bin (71), char (*)),
     system_info_$titles entry options (variable),
     system_info_$max_rs_number entry (fixed bin),
     expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)),
     hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35)),
     ioa_ entry options (variable);
dcl  search_sat_$rs_number entry (char (*), fixed bin, fixed bin (35));
dcl  search_sat_$clean_up entry;
dcl  system_info_$prices_rs entry (fixed bin,
    (0: 7) float bin, (0: 7) float bin, (0: 7) float bin, (0: 7) float bin, float bin, float bin);
dcl  error_table_$noentry external fixed bin (35);

dcl  null builtin;


%include projfile;

/* - - - - */

	call system_info_$max_rs_number (max_rs_number);

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then do;
	     dn = get_wdir_ ();
	     en = "projfile";
	end;
	else do;
	     call expand_pathname_ (bchr, dn, en, ec);
	     if ec ^= 0 then go to er;
	end;
	call hcs_$initiate (dn, en, "", 0, 1, pp, ec);
	if pp = null then do;
er:	     call com_err_ (ec, "print_projfile", "");
	     return;
	end;

	np = pp -> projfile.nproj;

	call system_info_$titles (co, dp);
	call ioa_ ("^|^a^/^/^-^a^/^/Project file listing: ^d entries^/^/",
	     co, dp, np);
	if projfile.version ^= PROJFILE_VERSION
	then call com_err_ (0, "print_projfile", "Warning, projfile version is ^d, not current version ^d.", projfile.version, PROJFILE_VERSION);

	do rs_number = 0 to max_rs_number;		/* get all rates */
	     call system_info_$prices_rs (rs_number, x, x, x, x, disk_price (rs_number), x (1));
	end;

	do i = 1 to np;
	     call date_time_ (on (i), dt1);
	     if off (i) = 0 then dt2 = "";
	     else call date_time_ (off (i), dt2);
	     if max_rs_number = 0 then ec, rs_number = 0;
	     else call search_sat_$rs_number ((id (i)), rs_number, ec); /* get rate index */
	     if ^(ec = error_table_$noentry & disk_psec (i) = 0) then do;
		if ec ^= 0 then
		     call com_err_ (ec, "print_projfile",
		     "Trying to locate project ""^a"" in the sat.  Default rates will be used.", id (i));
	     end;
	     dcost = disk_psec (i) * disk_price (rs_number);
	     call ioa_ ("^9a^3x^52a ^8a ^8a",
		id (i), title (i), dt1, dt2);
	     call ioa_ ("^12xInvestigator: ^32a ^32a", inv (i), inv_addr (i));
	     call ioa_ ("^12xSupervisor:^3x^32a ^32a ^16a", sup (i), sup_addr (i), sup_phone (i));
	     call ioa_ ("^12xDisk charge:  ^15a  ^d/^d directory ^d/^d",
		cv_$mwvf (dcost), disk_quota (i), disk_use (i), dir_disk_quota (i), dir_disk_use (i));
	     if misc_charges (i) ^= 0e0 then
		call ioa_ ("^12xMisc charges: ^15a  ^d", cv_$mwvf (misc_charges (i)), n_misc (i));
	     call ioa_ ("");
	end;
	call hcs_$terminate_noname (pp, ec);
	call search_sat_$clean_up;			/* tidy up */
     end;




		    print_reqfile.pl1               09/18/84  1252.5rew 09/18/84  0758.5       24183



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


print_reqfile: proc;

/* print reqfile */

dcl  dn char (168) aligned,
     ap ptr,
     al fixed bin,
     bchr char (al) based (ap),
     en char (32) aligned,
     i fixed bin,
     nq fixed bin,
     ec fixed bin (35),
     qp ptr,
    (co, dp) char (64) aligned,
    (dt1, dt2, dt3) char (8) aligned,
     facev char (15) aligned;


dcl  cv_$mwvf ext entry (float bin) returns (char (15)),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     get_wdir_ entry () returns (char (168)),
     system_info_$titles entry options (variable),
     date_time_ entry (fixed bin (71), char (*) aligned),
     hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned,
     fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35)),
     expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)),
     ioa_ entry options (variable),
     com_err_ entry options (variable);

dcl  null builtin;

%include reqfile;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then do;
	     dn = get_wdir_ ();
	     en = "reqfile";
	end;
	else do;
	     call expand_path_ (ap, al, addr (dn), addr (en), ec);
	end;
	call hcs_$initiate (dn, en, "", 0, 1, qp, ec);
	if qp = null then do;
er:	     call com_err_ (ec, "print_reqfile", "");
	     return;
	end;

	nq = qp -> reqfile.nacts;
	call system_info_$titles (co, dp);
	call ioa_ ("^|^a^/^/^-^a^/^/Requisition file listing: ^d accounts.^/^/", co, dp, nq);

	call ioa_ ("Acct ID^5xAcct no^6xRequisition^3x  Cutoff^5xReq. Amount^11xSpent^6xThis Month^8xOn^7xOff^/");
	do i = 1 to nq;
	     call date_time_ (cutoff (i), dt1);
	     call date_time_ (qdn (i), dt2);
	     if qdf (i) ^= 0 then call date_time_ (qdf (i), dt3);
	     else dt3 = "";
	     facev = cv_$mwvf ((req_amt (i)));
	     if facev = "" then facev = "           open";
	     call ioa_ ("^9a^3x^12a ^12a  ^8a ^15a ^15a ^15a  ^8a  ^8a",
	     acctid (i), mitacct (i), reqno (i), dt1,
	     facev, cv_$mwvf (chg_tr (i) + chg_mo (i)), cv_$mwvf ((chg_mo (i))), dt2, dt3);
	     call ioa_ ("^25x^32a^8x^32a^/", billing_name (i), billing_addr (i));
	end;

	call hcs_$terminate_noname (qp, ec);

     end;




		    print_sat.pl1                   07/13/88  1112.5r w 07/13/88  0942.4       86913



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


/* PRINT_SAT - procedure to print the binary System Administrator's Table

   coded by Eleanor Stone January 1970 */
/*  modified on 04/13/70 12:59 */

/* modified for new SAT format by Janice B. Phillipps, March 12, 1972 */
/* Modified 741107 by PG for authorizations & audit */
/* Modified by T. Casey, June 1975, for per-user load control groups */
/* Modified May 1976 by T. Casey to print project cutoff limits */
/* Modified May 1978 by T. Casey to print pdir_quota */
/* Modified January 1979 by T. Casey to print max_foreground, max_background, and abs_foreground_cpu_limit. */
/* Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures (UNCA). */
/* Modified June 1981 by E. N. Kittlitz for UNCA rate structures */
/* Modified 1984-07-05 BIM for min and max authorizations. */
/* Modified 1984-12-14 by EJ Sharpe for new audit flags */

print_sat:
     procedure;


/* automatic */

dcl 1 temp aligned like project.at;
dcl 1 global_attr aligned like project.at;
dcl  sat_dir char (168);
dcl  rs_number fixed bin;				/* rate structure index */
dcl  rs_name (0:9) char (32);
dcl  char_string char (256);
dcl  datestr char (24);
dcl  sel_proj char (32) init ("");
dcl  sat_name char (32);
dcl (i, jj) fixed bin;
dcl  code fixed bin (35);
dcl (argp, satp, satep) pointer;
dcl  slng fixed bin (21);
dcl  attr char (512) varying;
dcl  max_rs_number fixed bin;

/* DECLARATION OF BASED STRUCTURES */

dcl  arg char (slng) based (argp);

/* entries */

dcl  convert_access_audit_flags_$to_string entry (bit (36) aligned, char (*), fixed bin (35));
dcl  convert_access_class_$to_string_range_short entry ((2) bit (72) aligned, char (*), fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  expand_path_ entry (ptr, fixed bin (21), ptr, ptr, fixed bin (35));
dcl  format_attributes_ entry (ptr, char (*) var);
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  system_info_$max_rs_number entry (fixed bin);
dcl  system_info_$rs_name entry (fixed bin, char (*), fixed bin (35));

/* builtin functions */

dcl (addr, char, clock, hbound, length, ltrim, null, reverse, string, substr, verify) builtin;

/* internal static */

dcl  my_name char (9) internal static initial ("print_sat");

/* include files */

/* ================================================ */

%include sat;
%include user_attributes;
/* ================================================ */

/* INITIALIZATION - LOCATE AND INITIATE SAT */

	call system_info_$max_rs_number (max_rs_number);
	do i = 0 to hbound (rs_name, 1);
	     rs_name = " rate structure " || ltrim (char (i));
	end;

	call cu_$arg_ptr (1, argp, slng, code);
	if code ^= 0 then do;
	     call com_err_ (code, my_name, "");
	     return;
	end;

	call expand_path_ (argp, slng, addr (sat_dir), addr (sat_name), code);
	if code ^= 0 then do;
	     call com_err_ (code, my_name, arg);
	     return;
	end;

	i = length (sat_name) - verify (reverse (sat_name), " ") + 1;
	if i > length (".sat")
	then if substr (sat_name, i - 3, 4) ^= ".sat"
	     then substr (sat_name, i + 1, 4) = ".sat";
	     else;
	else if sat_name ^= "sat"
	then substr (sat_name, i + 1, 4) = ".sat";

	call hcs_$initiate (sat_dir, sat_name, "", 0, 0, satp, code);
	if satp = null then do;
	     call com_err_ (code, my_name, "^a>^a", sat_dir, sat_name);
	     return;
	end;

	if satp -> sat.version ^= SAT_version then do;
	     call com_err_ (0, my_name, "SAT version ^d is inconsistent with declarations used by this program (version ^d).", satp -> sat.version, SAT_version);
	     return;
	end;

	call cu_$arg_ptr (2, argp, slng, code);
	if code = 0 then do;
	     sel_proj = arg;
	     go to plp;
	end;

	call date_time_ ((clock ()), datestr);
	call ioa_ ("^//*  ^a>^a  ^a */^/", sat_dir, sat_name, datestr);
	call ioa_ ("/* author.process_group_id:^6x^a; */", satp -> sat.author.proc_group_id);
	call ioa_ ("/* author.w_dir:^17x^a; */", satp -> sat.author.w_dir);

	call ioa_ ("/* max_size:^18x^4d; */", sat.max_size);
	call ioa_ ("/* current_size:^14x^4d; */", sat.current_size);
	call ioa_ ("/* version:^22x^d; */", sat.version);
	call ioa_ ("/* freep:^21x^4d; */", sat.freep);
	call ioa_ ("/* n_projects:^16x^4d; */", sat.n_projects);
	call ioa_ ("   Maxunits:^16x^6d;", sat.max_units);
	if satp -> sat.uwt_size ^= 0 then do;
	     call ioa_ ("/* uwt_size:^20x^2d; */", sat.uwt_size);
	     do i = 1 to satp -> sat.uwt_size;
		call ioa_ ("^3xUwt:^2-^a, ^d;", sat.uwt (i).initproc, sat.uwt (i).units);
	     end;
	end;

	do jj = 1 to 2;
	     if sat.system_admin (jj) ^= ""
	     then call ioa_ ("^3xAdministrator:^-^a;", sat.system_admin (jj));
	end;

/* Compute Global attribute bits */

	string (global_attr) = (36)"1"b;		/* initially assume all are ON */

	do i = 1 to sat.current_size;			/* turn off all non-global attrs */
	     satep = addr (sat.project (i));
	     if project.state ^= 0 then do;
		string (temp) = string (project.at);	/* copy attributes */
		temp.sb_ok = ^(temp.sb_ok);		/* normalize inverted attrs */
		temp.pm_ok = ^(temp.pm_ok);		/* (names are opposite of bits) */
		temp.eo_ok = ^(temp.eo_ok);		/* .. */
		string (global_attr) = string (global_attr) & string (temp);
	     end;
	end;

	string (temp) = string (global_attr);		/* leave global alone, make copy */
	temp.sb_ok = ^(temp.sb_ok);
	temp.pm_ok = ^(temp.pm_ok);
	temp.eo_ok = ^(temp.eo_ok);
	call format_attributes_ (addr (temp), attr);
	call ioa_ ("   Attributes:^6x^a", attr);

/* NOW PRINT OUT ALL PROJECT ENTRIES */

plp:
	do rs_number = 0 to max_rs_number;		/* get all the rate structure names */
	     call system_info_$rs_name (rs_number, rs_name (rs_number), code);
	end;

	do i = 1 to sat.current_size;

	     satep = addr (satp -> sat.project (i));
	     if project.state ^= 0 then do;
		if sel_proj ^= "" then if sel_proj ^= project.project_id then go to skip;
		call ioa_ ("^/^3xprojectid:^-^a;", project.project_id);
		call ioa_ ("/* state:^2-^d; */", project.state);
		call ioa_ ("^3xprojectdir:^-^a;", project.project_dir);
		if project.pdt_ptr ^= null
		then call ioa_ ("/* pdt_ptr:^-^p; */", project.pdt_ptr);
		call ioa_ ("^3xmaxprim:^-^d;", project.max_users);
		call ioa_ ("/* n_users:^-^d; */", project.n_users);
		string (temp) = string (project.at);
		temp.nopreempt = "0"b;		/* only used in PDT */

		if sel_proj = "" then do;		/* if printing whole SAT */
		     temp.sb_ok = ^(temp.sb_ok);
		     temp.pm_ok = ^(temp.pm_ok);
		     temp.eo_ok = ^(temp.eo_ok);
		     string (temp) = string (temp) & ^string (global_attr); /* turn OFF bits that are global */
		     temp.sb_ok = ^(temp.sb_ok);
		     temp.pm_ok = ^(temp.pm_ok);
		     temp.eo_ok = ^(temp.eo_ok);
		end;
		call format_attributes_ (addr (temp), attr);
		call ioa_ ("^3xattributes:^-^a", attr);
		if project.audit ^= ""b then do;
		     call convert_access_audit_flags_$to_string (project.audit, char_string, code);
		     if code ^= 0
		     then call com_err_ (code, my_name, "Could not convert audit flags.");

		     if char_string ^= ""
		     then call ioa_ ("^3xaudit:^2-""^a"";", char_string);
		end;

		call convert_access_class_$to_string_range_short (project.project_authorization, char_string, code);
		if code ^= 0
		then call com_err_ (code, my_name, "Could not convert authorization.");

		if char_string ^= ""
		then call ioa_ ("^3xauthorization:^-""^a"";", char_string);

		if max_rs_number > 0 then
		     call ioa_ ("/* rate_structure:^-^a (^d); */", rs_name (project.rs_number), project.rs_number);

		if project.cutoff ^= " "
		then call ioa_ ("^3xcutoff:^-^-^a;", project.cutoff);
		call ioa_ ("/* days_to_cutoff:^-^d; */", project.days_to_cutoff);
		call ioa_ ("/* pct_balance:^-^d%; */", project.pct_balance);
		call ioa_ ("/* dollars_to_cutoff: $^.2f; */", project.dollars_to_cutoff);
		call ioa_ ("^3xring:^-^-^d,^d;", project.min_ring, project.max_ring);
		if project.alias ^= ""
		then call ioa_ ("^3xalias:^-^-^a;", project.alias);
		call ioa_ ("^3xgroup:^-^-^a;", project.group);
		if project.at.igroup then do;
		     if project.groups (1) ^= "" then do; /* if any authorized groups */
			if project.groups (2) ^= "" then /* if two of them */
			     call ioa_ ("^3xgroups:^-^a, ^a;", project.groups (1), project.groups (2));
			else call ioa_ ("^3xgroups:^-^a;", project.groups (1));
		     end;
		end;
		call ioa_ ("^3xgrace:^2-^d;", project.grace_max);
		call ioa_ ("^3xpdir_quota:^-^d;", project.pdir_quota);
		call ioa_ ("^3xmax_foreground:^-^d;", project.max_foreground);
		call ioa_ ("^3xmax_background:^-^d;", project.max_background);
		call ioa_ ("^3xabs_foreground_cpu_limit:^x^d;", project.abs_foreground_cpu_limit);
		do jj = 1 to 4;
		     if project.admin (jj).userid ^= "" then
			call ioa_ ("^3xadministrator:^-^a;", project.admin (jj).userid);
		end;
	     end;
skip:	end;

	call ioa_ ("");

	if sel_proj = ""
	then call ioa_ ("end;^/");

	call hcs_$terminate_noname (satp, code);
	return;

     end print_sat;




		    print_syserr_msg_.pl1           03/14/85  0810.8r w 03/13/85  1100.2      209277



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


/* Procedure to print a syserr message */

/* Coded November 1975 by Larry Johnson */
/* Modified January 1976 by Larry Johnson */
/* Modified October 1976 by Larry Johnson for new hardware fault messages. */
/* Modified November 1979 by Larry Johnson for detailed device status */
/* Modified June 1982 by E. N. Kittlitz to handle (i.e. do nothing for) config deck. */
/* Modified May 1983 by E. N. Kittlitz to print config decks nicely. (There! that wasn't so hard, was it?) */

/* format: style4 */
print_syserr_msg_: proc (argp, code);


dcl  code fixed bin (35);				/* Status code */
dcl  (ctp, ptp) ptr;				/* Pointers to times */
dcl  cur_time char (24);				/* Current time from date_time_ */
dcl  seq_edit picture "zzzzzzzzzzz9";			/* To edit sequence number field */
dcl  seq_sz fixed bin;				/* Number of chars in sequence number  */
dcl  tpos fixed bin;				/* Current position while scanning text */
dcl  (i, j) fixed bin;
dcl  tlen fixed bin;				/* Length of portion of text being checked */
dcl  room fixed bin;				/* Number of characters on line available for text */
dcl  start fixed bin;				/* Starting position for characters */
dcl  line_length fixed bin;				/* Length of line */
dcl  moved fixed bin (21);				/* Number of characters moved into line */
dcl  fl bit (1) init ("1"b);				/* Set while 1st line is edited */
dcl  line char (1024);				/* Print line is built here */
dcl  aline (1024) char (1) based (addr (line));		/* Another way of addressing line */
dcl  next fixed bin;				/* Next character position available on line */
dcl  restl fixed bin;				/* Length of rest of line */
dcl  restp ptr;					/* Pointer to rest of line */
dcl  rest char (restl) based (restp);			/* Rest of the line */
dcl  arrayl fixed bin;				/* Length of portion of array */
dcl  arrayp ptr;					/* Pointer to portion of array */
dcl  based_array (arrayl) bit (36) aligned based (arrayp);	/* Portion of array */
dcl  work char (1024) var;				/* A temp string */
dcl  work2 char (128) var;				/* Another */
dcl  code_edit picture "zzz9";			/* To edit the action code */
dcl  bin_mode bit (1) init ("0"b);			/* Set while editing the binary part of message */
dcl  first_bin bit (1) init ("0"b);			/* Set until 1st line of binary data printed */
dcl  hold_moved fixed bin;				/* Used during binary editing to save text length */
dcl  nwords fixed bin;				/* Number of words of binary data */
dcl  wordp ptr;					/* Pointer to binary data */
dcl  words (nwords) based (wordp);

dcl  1 tm based,					/* Structure that overlays time from date_time_ */
       2 date char (8) unal,				/* MM/DD/YY */
       2 fill1 char (2) unal,
       2 time char (6) unal,				/* HHMM.T */
       2 fill2 char (1) unal,
       2 zone char (3) unal,				/* ZZZ - time zone */
       2 fill3 char (1) unal,
       2 day char (3) unal;				/* DDD - day of week */

dcl  1 dtl,					/* Date line printed when day changes */
       2 nl1 char (1) unal,				/* A newline */
       2 day char (3) unal,				/* The day of the week */
       2 bl1 char (2) unal,				/* "  " */
       2 date char (8) unal,				/* MM/DD/YY */
       2 bl2 char (2) unal,				/* " (" */
       2 zone char (3) unal,				/* The time zone */
       2 bl3 char (1) unal,				/* ")" */
       2 nl2 char (1) unal;				/* A newline */


dcl  newline char (1) int static init ("
");						/* A new line character */

%include print_syserr_msg_args;

dcl  text_data char (parg.textl) based (parg.textp);	/* Text from param list */
dcl  print_data char (parg.printl) based (parg.printp);

dcl  date_time_ entry (fixed bin (71), char (*));
dcl  ioa_$rsnpnnl entry options (variable);
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  syserr_log_util_$search entry (fixed bin (71), fixed bin (71), fixed bin (35), fixed bin (35));

dcl  com_err_ entry options (variable);

dcl  error_table_$smallarg ext fixed bin (35);

dcl  (addr, addrel, bin, divide, index, hbound, length, max, min, reverse, rtrim, string, substr, verify) builtin;

%include syserr_message;
%include mc;

/* Get time of message */

	syserr_msgp = parg.msgp;			/* Get pointer to message */

	call date_time_ ((syserr_msg.time), cur_time);
	ctp = addr (cur_time);			/* Get pointers to time structures */
	ptp = addr (parg.prev_time);
	if ctp -> tm.date ^= ptp -> tm.date then do;	/* If date change */
	     dtl.nl1, dtl.nl2 = newline;		/* Fill in line to print */
	     dtl.day = ctp -> tm.day;
	     dtl.bl1 = "  ";
	     dtl.date = ctp -> tm.date;
	     dtl.bl2 = " (";
	     dtl.zone = ctp -> tm.zone;
	     dtl.bl3 = ")";
	     call iox_$put_chars (iocbp, addr (dtl), length (string (dtl)), code);
	     if code ^= 0 then return;		/* If put_chars error */
	end;
	parg.prev_time = cur_time;			/* Remember for next call */


/* Determine how much space is on line for text */

	line = "";				/* Clear line */
	moved = 0;				/* No characters in it */
	seq_edit = syserr_msg.seq_num;		/* Edit the sequence number */
	seq_sz = max (6, 13 - verify (seq_edit, " "));	/* Characters in edited number with leading spaces removed */
	start = seq_sz + 12;			/* Starting column for text */
	line_length = min (parg.linelen, length (line) - 1);
	room = line_length - start + 1;		/* Characters available in text portion of line */
	if room <= 25 then do;			/* If too small */
	     code = error_table_$smallarg;
	     return;
	end;

	tpos = 1;					/* Start with first character */


/* This routine edits the line. If it is too long, or contains newline, it will be
   broken into several lines */

top:	if tpos > length (print_data) then go to done;	/* Done if finished line */


	i = index (substr (print_data, tpos), newline);
						/* Check for newline */
	if i = 0 then				/* No newline in remaining text */
	     tlen = length (print_data) - tpos + 1;	/* Length to consider is rest of line */
	else if i = 1 then do;			/* If newline is first */
	     tpos = tpos + 1;			/* Skip over it */
	     go to top;
	end;
	else tlen = i - 1;				/* Consider just stuff before newline */

	i = verify (substr (print_data, tpos, tlen), " ");/* Count leading blanks */
	if i = 0 then do;				/* Line is all blank */
	     tpos = tpos + tlen;			/* Skip it all */
	     go to top;
	end;
	if i > 1 then do;				/* Some leading blanks */
	     tpos = tpos + i - 1;			/* Skip them */
	     tlen = tlen - i + 1;			/* Adjust count */
	end;

	if moved ^= 0 then call put;			/* If stuff already on line, dump it */

	if tlen <= room then do;			/* If it all fits */
	     substr (line, start, tlen) = substr (print_data, tpos, tlen); /* Copy it all */
	     moved = tlen;				/* Remember how much */
	     tpos = tpos + tlen;
	end;
	else do;
	     i = index (reverse (substr (print_data, tpos + room - 20, 20)), " ");
						/* Check last 20 characters that fit for a blank */

	     if i = 0 then do;			/* If no blank, break is arbitrary */
		substr (line, start, room) = substr (print_data, tpos, room); /* Fill line */
		moved = room;			/* Remember how much */
		tpos = tpos + room;			/* Skip over what moved */
	     end;
	     else do;				/* Be neat and break on blank */
		tlen = room - i;			/* Length to copy */
		substr (line, start, tlen) = substr (print_data, tpos, tlen); /* Do it */
		moved = tlen;			/* Remember how much */
		tpos = tpos + tlen + 1;		/* Skip over stuff copied, + blank */
	     end;
	end;
	go to top;				/* Back for more */

done:	if parg.bin_sw then if syserr_msg.data_size > 0 then call edit_binary;

	if fl | moved ^= 0 then call put;		/* Write last line */

	code = 0;

finish:	return;

/* Procedure to print 1 line */

put: proc;

	if fl then do;				/* If first line */
	     substr (line, 1, 6) = ctp -> tm.time;	/* Move in time */
	     substr (line, 8, seq_sz) = substr (seq_edit, 13 - seq_sz); /* And sequence number */
	     code_edit = syserr_msg.code;		/* Edit the action code */
	     substr (line, seq_sz + 8, 3) = substr (code_edit, 2, 3); /* Move into line */
	     fl = "0"b;				/* Only do this once */
	end;

	if first_bin then do;			/* If first line of binary data */
	     first_bin = "0"b;
	     if (hold_moved > 0) & (hold_moved ^= moved) then
		moved = moved + 2;			/* This accounts for the 2 spaces between text and data
						   when they both appear on the same line */
	end;
	moved = moved + start;			/* Total length */
	substr (line, moved, 1) = newline;		/* Put new line at end */
	call iox_$put_chars (iocbp, addr (line), moved, code);
	if code ^= 0 then go to finish;
	line = "";				/* Initialize for next line */
	moved = 0;
	if bin_mode then do;			/* Binary editors need extra stuff */
	     restp = addr (aline (start));
	     restl = room;
	end;
	return;

     end put;

/* Procedure to edit binary data */

edit_binary: proc;

dcl  s fixed bin;
dcl  i fixed bin;
dcl  tbuf char (260);

%include syserr_binary_def;

dcl  binary_segmsg_util_ entry (ptr) returns (char (250));
dcl  binary_segmsg_util_$interpret_pvname entry (ptr) returns (char (32));

dcl  special_chars (15) char (32) var int static options (constant) init (/* Table of special messages */
	"ioi_interrupt: I/O error.",
	"op-not-complete fault by ",
	"startup fault by ",
	"shutdown fault by ",
	"parity fault by ",
	"mos_memory_check: EDAC error",
	"cache dir parity fault on",
	"cache store parity fault on",
	"cache store thru parity fault on",
	"cache load parity fault on",
	"parity fault on",
	"startup fault on",
	"shutdown fault on",
	"op_not_complete fault on",
	"command fault on");


	if moved = 0 then next = start;		/* Line empty */
	else next = start + moved + 2;		/* Next available column */
	hold_moved = moved;				/* Save text length */
	bin_mode = "1"b;				/* In binary mode now */
	first_bin = "1"b;				/* Editing first line */
	restp = addr (aline (next));			/* Address of rest of line */
	restl = line_length - next + 1;		/* Length of rest of line */

	if octal_sw then do;			/* Do simple dump */
	     call edit_std;
	     return;
	end;


	if syserr_msg.data_code ^= 0 then do;
	     s = syserr_msg.data_code;
	     if s = SB_mos_err then call edit_mos_memory;
	     else if s = SB_io_err then call edit_ioi;
	     else if s = SB_io_err_detail then call edit_ioi_detail;
	     else if s = SB_ocdcm_err then call edit_ioi;
	     else if s = SB_hw_fault then go to scan;
	     else if s = SB_verify_lock then call edit_fault;
	     else if s = SB_config_deck then call edit_config;
	     else if s < 0 | s > SB_end_of_table then ;
	     else if substr (syserr_binary_seg_damage_mask, s, 1) then do;
		tbuf = "Segment: " || binary_segmsg_util_ (addr (syserr_msg.data));
		go to out_tbuf;
	     end;
	     else if substr (syserr_binary_vol_damage_mask, s, 1) then do;
		tbuf = "Volume: " || binary_segmsg_util_$interpret_pvname (addr (syserr_msg.data));
out_tbuf:		i = length (rtrim (tbuf));
		if i > restl then call put;
		moved = min (i, length (line));
		rest = tbuf;
		call put;
		return;
	     end;
	     else call edit_std;

	     return;
	end;

scan:
	do i = 1 to hbound (special_chars, 1);		/* Scan table of names */
	     if length (text_data) >= length (special_chars (i)) then
		if index (text_data, special_chars (i)) ^= 0 then
		     go to make_call;
	end;

	call edit_std;				/* Use a standard routine */
	return;

make_call: go to c (i);				/* Branch to appropriate call */
c (1):	call edit_ioi;				/* Ioi error */
	return;
c (2):	call edit_old_onc;				/* Op-not-complete fault */
	return;
c (3):	call edit_old_startup;			/* Startup fault */
	return;
c (4):	call edit_old_startup;			/* Shutdown fault */
	return;
c (5):	call edit_old_parity;			/* Parity fault */
	return;
c (6):	call edit_mos_memory;			/* Mos memory EDAC error */
	return;
c (7):						/* Cache dir parity fault */
c (8):						/* Cache store parity fault */
c (9):						/* Cache store thru parity fault */
c (10):						/* Cache load parity fault */
c (11):						/* Parity fault */
c (12):						/* Startup fault */
c (13):						/* Shutdown fault */
c (14):						/* Op not complete fault */
c (15):						/* Command fault */
	call edit_fault;
	return;

     end edit_binary;

/* Procedure to edit unidentified binary data */

edit_std: proc;

	nwords = syserr_msg.data_size;
	wordp = addr (syserr_msg.data);
	call edit_words;
	return;
     end edit_std;


/* Procedure that edits any random words */
/* It will be put on the current line if it fits, otherwise on succeeding lines
   with some power of 2 words per line */

edit_words: proc;

	i = 13 * nwords - 1;			/* Space needed for all words */
	if i <= restl then do;			/* It fits */
all_fits:	     call ioa_$rsnpnnl ("^(^w ^)", rest, (0), words); /* Edit it */
	     moved = moved + i;
	     call put;
	     return;
	end;

	if moved > 0 then call put;			/* Dump current line */
	if i <= restl then go to all_fits;		/* Fits on one line now */

/* Determine number of words to print per line */

	i, j = 1;
	do while (j <= room);
	     i = 2 * i;				/* A power of 2 */
	     j = 13 * i - 1;			/* Space for that many words */
	end;
	i = divide (i, 2, 17, 0);			/* Last power of two that fit */

	do j = 1 by i while (j <= nwords);		/* Loop to print the lines */
	     arrayp = addr (words (j));		/* Addr of current piece */
	     arrayl = min (i, nwords - j + 1);
	     call ioa_$rsnpnnl ("^(^w ^)", rest, moved, based_array);
	     call put;
	end;

	return;

     end edit_words;

/* Procedure to edit a config deck fragment */

edit_config: proc;
dcl  data_left fixed bin;
dcl  field_no fixed bin;
dcl  config_card_field_in_ascii char (4) based;
%include config_deck;
	data_left = syserr_msg.data_size;
	cardp = addr (syserr_msg.data);
	do while (data_left > 0);
	     call ioa_$rsnpnnl ("^a", work, (0), config_card.word);
	     do field_no = 1 to config_card.type_word.n_fields by 1;
		if config_card.type_word.field_type (field_no) = CONFIG_STRING_TYPE
		then call ioa_$rsnpnnl ("^a  ^a", work, (0), work,
			addr (config_card.data_field (field_no)) -> config_card_field_in_ascii);
		else if config_card.type_word.field_type (field_no) = CONFIG_OCTAL_TYPE
		then call ioa_$rsnpnnl ("^a  ^o", work, (0), work, fixed (config_card.data_field (field_no)));
		else if config_card.type_word.field_type (field_no) = CONFIG_DECIMAL_TYPE
		then call ioa_$rsnpnnl ("^a  ^d.", work, (0), work, fixed (config_card.data_field (field_no)));
		else if config_card.type_word.field_type (field_no) = CONFIG_SINGLE_CHAR_TYPE
		then call ioa_$rsnpnnl ("^a  ^a", work, (0), work,
			substr ("abcdefgh", fixed (config_card.data_field (field_no)), 1));
		else ;
	     end;
	     call put;
	     substr (rest, 1, length (work)) = work;
	     moved = moved + length (work);
	     data_left = data_left - size (config_card);
	     cardp = addrel (cardp, size (config_card));
	end;
	call put;
     end edit_config;

/* Procedure to edit an ioi syserr message */

edit_ioi: proc;

dcl  edit_detail bit (1) init ("0"b);
dcl  detailed_status_length fixed bin;
dcl  i fixed bin;
dcl  dtstat (detailed_status_length) bit (8) unal based (addr (io_msg.detailed_status));

%include io_syserr_msg;

edit_ioi_join: io_msgp = addr (syserr_msg.data);
	call ioa_$rsnpnnl ("channel=^a device=^2.3b", work, (0),
	     io_msg.channel, io_msg.device);
	if io_msg.time_out then work = work || "  timeout";
	else do;
	     call ioa_$rsnpnnl ("  status=^w", work2, (0), io_msg.status);
	     work = work || work2;
	end;

	if io_msg.count ^= "0"b then do;
	     call ioa_$rsnpnnl (" (^d times)", work2, (0), bin (io_msg.count, 6) + 1);
	     work = work || work2;
	end;

	if room < length (work) then do;		/* If terminal too short for this message */
	     call edit_std;
	     return;
	end;

	if length (work) > restl then			/* If it won't fit on current line */
	     call put;				/* Dump line */

	substr (rest, 1, length (work)) = work;		/* Copy line */
	moved = moved + length (work);

	if edit_detail then do;
	     call put;
	     detailed_status_length = 27;
	     do i = detailed_status_length to 1 by -1 while (dtstat (i) = "0"b);
	     end;
	     detailed_status_length = max (i, 1);
	     call ioa_$rsnpnnl ("Detailed status:^( ^.4b^)", work, (0), dtstat);
	     substr (rest, 1, length (work)) = work;	/* Copy line */
	     moved = moved + length (work);

	end;

	return;

edit_ioi_detail: entry;

	edit_detail = "1"b;
	go to edit_ioi_join;

     end edit_ioi;

/* Edit message from a fault */

edit_fault: proc;

dcl  fault_msgp ptr;
dcl  1 fault_msg aligned based (fault_msgp),
       2 mcx like mc aligned,
       2 hist_reg (128) bit (36) aligned;

	fault_msgp = addr (syserr_msg.data);
	scup = addr (mcx.scu);
	call edit_text ("Pointer Registers:");
	wordp = addr (fault_msg.prs);
	nwords = 16;
	call edit_words;
	call ioa_$rsnpnnl ("x0-7:^( ^.3b^)", rest, moved, fault_msg.x);
	call put;
	call ioa_$rsnpnnl ("a: ^.3b q: ^.3b e: ^.3b t: ^.3b ralr: ^.3b", rest, moved,
	     fault_msg.a, fault_msg.q, "0"b || fault_msg.e,
	     fault_msg.t, fault_msg.ralr);
	call put;
	call edit_scu (addr (fault_msg.scu));
	call ioa_$rsnpnnl ("Fault Register: ^.3b", rest, moved, fault_msg.fault_reg);
	call put;
	call edit_text ("EIS Info:");
	nwords = 8;
	wordp = addr (fault_msg.eis_info);
	call edit_words;
	call edit_hist (addr (fault_msg.hist_reg), (scu.pad2));
	return;

     end edit_fault;

edit_scu: proc (p);

dcl  p ptr;

	call edit_text ("SCU data:");
	nwords = 8;
	wordp = p;
	call edit_words;
	return;

     end edit_scu;

edit_hist: proc (p, cpu_type);

dcl  p ptr;
dcl  cpu_type bit (9);

	if cpu_type = "0"b then
	     call edit_text ("OU History Reg Data:");
	else call edit_text ("DU/OU History Reg Data:");
	nwords = 32;
	wordp = p;
	call edit_words;
	call edit_text ("CU History Reg Data:");
	wordp = addrel (p, 32);
	call edit_words;
	if cpu_type = "0"b then
	     call edit_text ("DU History Reg Data:");
	else call edit_text ("APU#2 History Reg Data:");
	wordp = addrel (p, 64);
	call edit_words;
	if cpu_type = "0"b then
	     call edit_text ("APU History Reg Data:");
	else call edit_text ("APU#1 History Reg Data:");
	wordp = addrel (p, 96);
	call edit_words;
	return;

     end edit_hist;

edit_text: proc (msg);

dcl  msg char (*);

	if moved > 0 then call put;
	substr (rest, 1, length (msg)) = msg;
	moved = length (msg);
	call put;
	return;

     end edit_text;

/* Edit old style parity message */

edit_old_parity: proc;

dcl  parity_msgp ptr;

dcl  1 parity_msg aligned based (parity_msgp),
       2 scu (8) bit (36) aligned,
       2 inst_addr fixed bin (18),
       2 inst (3) bit (36) aligned,
       2 abs_tsr_valid bit (1) unal,
       2 tsr_repeat bit (1) unal,
       2 fill1 bit (9) unal,
       2 tsr_loc fixed bin (24) unal,
       2 tsr_data bit (36) unal,
       2 abs_psr_valid bit (1) unal,
       2 psr_repeat bit (1) unal,
       2 fill2 bit (9) unal,
       2 psr_loc fixed bin (24) unal,
       2 psr_data bit (36) aligned;

	parity_msgp = addr (syserr_msg.data);
	if moved > 0 then call put;
	call ioa_$rsnpnnl ("inst at ^o: ^w ^w ^w", rest, moved, parity_msg.inst_addr, parity_msg.inst);
	call put;
	call edit_scu (addr (parity_msg.scu));
	call ioa_$rsnpnnl ("PSR: ^o", work, 0, parity_msg.psr_loc);
	if parity_msg.abs_psr_valid then do;
	     call ioa_$rsnpnnl (" (^w)", work2, 0, parity_msg.psr_data);
	     work = work || work2;
	     work = work || " Retry ";
	     if parity_msg.psr_repeat then work = work || "succeeded.";
	     else work = work || "failed.";
	end;
	else work = work || " invalid absaddr.";
	rest = work;
	moved = length (work);
	call put;
	call ioa_$rsnpnnl ("TSR: ^o", work, 0, parity_msg.tsr_loc);
	if parity_msg.abs_tsr_valid then do;
	     call ioa_$rsnpnnl (" (^w)", work2, 0, parity_msg.tsr_data);
	     work = work || work2;
	     work = work || " Retry ";
	     if parity_msg.tsr_repeat then work = work || "succeeded.";
	     else work = work || "failed.";
	end;
	else work = work || " invalid absaddr.";
	rest = work;
	moved = length (work);
	call put;
	return;

     end edit_old_parity;

/* Edit old style op-not-complete fault */

edit_old_onc: proc;

dcl  onc_msgp ptr;
dcl  cpu_type bit (9);
dcl  1 onc_msg aligned based (onc_msgp),
       2 scu (8) bit (36),
       2 inst_addr fixed bin (18),
       2 inst (3) bit (36) aligned,
       2 hist_reg (128) bit (36) aligned;

	onc_msgp = addr (syserr_msg.data);
	cpu_type = substr (scu (3), 19, 9);
	if moved > 0 then call put;
	call ioa_$rsnpnnl ("inst at ^o: ^w ^w ^w", rest, moved, onc_msg.inst_addr, onc_msg.inst);
	call put;
	call edit_scu (addr (onc_msg.scu));
	call edit_hist (addr (onc_msg.hist_reg), cpu_type);
	return;

     end edit_old_onc;

/* Edit old style startup and shutdown faults */

edit_old_startup: proc;

dcl  startup_msgp ptr;
dcl  1 startup_msg aligned based (startup_msgp),
       2 scu (8) bit (36) aligned;

	startup_msgp = addr (syserr_msg.data);
	call edit_scu (addr (startup_msg.scu));
	return;

     end edit_old_startup;

/* Edit message from mos memory EDAC error */

edit_mos_memory: proc;

dcl  edit_mos_rscr_ entry (ptr, char (*) var);

	call edit_mos_rscr_ (addr (syserr_msg.data), work);
	if room < length (work) then do;
	     call edit_std;
	     return;
	end;
	if length (work) > restl then call put;
	substr (rest, 1, length (work)) = work;
	moved = moved + length (work);
	return;

     end edit_mos_memory;

/* Procedure called to print errors by interpreting status from syserr_log_util_$open */

open_err: entry (open_status, caller, code);

dcl  open_status bit (36) aligned;			/* Set by syserr_log_util_$open */
dcl  caller char (*);				/* Name of caller for com_err_ */
dcl  msg_time fixed bin (71);				/* Time of a syserr message */
dcl  msg_seq fixed bin (35);				/* Sequence number */
dcl  sw fixed bin;
dcl  code2 fixed bin (35);

	if substr (open_status, 1, 2) = "11"b then do;	/* If all access needed is present */
	     code = 0;				/* No error */
	     return;
	end;

	if substr (open_status, 1, 2) = "00"b then do;	/* If no access */
	     call com_err_ (code, caller, "Unable to open syserr_log");
	     return;
	end;

	sw = 0;					/* An ioa_ switch */

	if substr (open_status, 1, 2) = "01"b then do;	/* No access to current log */
	     call syserr_log_util_$search (-1, msg_time, msg_seq, code2); /* Get time of last message */
	     if code2 = 0 then do;			/* It workd */
		sw = 1;
		call date_time_ (msg_time, cur_time);
	     end;
	     call com_err_ (code, caller, "Current log not available. ^v(Permanent log ends ^a.^)",
		sw, cur_time);
	     code = 0;
	     return;
	end;

	else do;					/* No access to permanent log */
	     call syserr_log_util_$search (0, msg_time, msg_seq, code2); /* Read oldest message */
	     if code2 = 0 then do;
		sw = 1;
		call date_time_ (msg_time, cur_time);
	     end;
	     call com_err_ (code, caller, "Permanent log not available. ^v(Current log starts ^a.^)",
		sw, cur_time);
	     code = 0;
	     return;
	end;

     end print_syserr_msg_;




		    print_urf.pl1                   10/27/83  1614.3rew 10/27/83  1442.0       18468



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


print_urf: procedure options (variable);

%include urf_entry;

dcl  argument char (al) based (ap);

dcl (error_table_$bad_index,
     error_table_$no_record) fixed bin (35) external;

dcl (ioa_, com_err_) entry options (variable);
dcl  cu_$arg_count entry returns (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  urf_manager_$get_abs_entry entry (fixed bin (35), char (*), ptr, fixed bin (35));
dcl  urf_manager_$get_entry entry (char (*), ptr, fixed bin (35));

dcl 1 urfe aligned like urf_entry;
dcl  rec fixed bin (35);
dcl  i fixed bin;
dcl  ap ptr;
dcl  al fixed bin (21);
dcl  code fixed bin (35);
dcl  uid char (32);

	if cu_$arg_count () = 0
	then do rec = 1 by 1;
	     call urf_manager_$get_abs_entry (rec, uid, addr (urfe), code);
	     if code = error_table_$bad_index then return;
	     if code = 0 then call print_entry;
	     else if code ^= error_table_$no_record then do;
		call com_err_ (code, "print_urf");
		return;
	     end;
	end;
	else do i = 1 by 1;
	     call cu_$arg_ptr (i, ap, al, code);
	     if code ^= 0 then return;
	     uid = argument;
	     call urf_manager_$get_entry (uid, addr (urfe), code);
	     if code = 0
	     then call print_entry;
	     else call com_err_ (code, "print_urf", "Getting entry for ^a.", uid);
	end;
	return;

print_entry: procedure;
	     call ioa_ ("^20a ^9a ^a ^a, ^[^a: ^;^s^]^a; ^a; ^a",
		uid, urfe.project, urfe.prog_number, urfe.last_name, (urfe.title ^= ""), urfe.title, urfe.first_name,
		urfe.address, urfe.notes);
	end;
     end;




		    remove_user.pl1                 11/01/83  1112.9r w 11/01/83  1039.6       23400



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


/* Modified July 1983 by B. Margolin to delete the corresponding
   Mail Table entry */

remove_user: procedure options (variable);

declare  iox_$user_input pointer external;

declare  pnt_manager_$remove_entry entry (character (*), fixed bin (35)),
         urf_manager_$remove_entry entry (character (*), fixed bin (35)),
         mail_table_priv_$delete entry (char (*) varying, bit (1), fixed bin (35)),
         cu_$arg_ptr entry (fixed bin, pointer, fixed bin (21), fixed bin (35)),
         cu_$arg_count entry returns (fixed bin),
         iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)),
        (com_err_, ioa_) entry options (variable);

declare  ME char (32) init ("remove_user") static options (constant);

declare  arg char (al) based (ap);
declare  al fixed bin (21),
         ap pointer,
        (nargs, i) fixed bin,
         uid character (32),
         code fixed bin (35);

declare (addr, length, substr) builtin;

	nargs = cu_$arg_count ();
	if nargs = 0
	then do;
	     call ioa_ ("User ID:");
	     call iox_$get_line (iox_$user_input, addr (uid), length (uid), al, code);
	     if code ^= 0 then do;
		call com_err_ (code, ME, "Reading user ID.");
		return;
	     end;
	     substr (uid, al) = "";			/* blank out rest of string */
	     call process (uid);
	end;
	else do i = 1 to nargs;
	     call cu_$arg_ptr (i, ap, al, code);
	     if code ^= 0 then do;
		call com_err_ (code, ME, "Getting argument ^d.", i);
		return;
	     end;
	     call process (arg);
	end;
	return;

process:	procedure (User);
declare  User char (*) parameter;
declare  code fixed bin (35);

	     call pnt_manager_$remove_entry (User, code);
	     if code ^= 0 then call com_err_ (code, ME, "Deleting PNT entry for ""^a"".", User);
	     call urf_manager_$remove_entry (User, code);
	     if code ^= 0 then call com_err_ (code, ME, "Deleting URF entry for ""^a"".", User);
	     call mail_table_priv_$delete (rtrim (User), "1"b, code);
	     if code ^= 0 then call com_err_ (code, ME, "Deleting Mail Table entry for ""^a"".", User);
	end process;

     end;




		    reset_cdt_meters.pl1            07/20/88  1249.0r w 07/19/88  1536.1       25245



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


/* RESET_CDT_METERS - Program to reset the meters kept by dialup_ in
   the header of the Channel Definition Table, and in each CDTE.

   Written 750818 by PG
   cleanup handler added by F.W. Martinson June 1982
*/

reset_cdt_meters:
     procedure;

/* entries */

dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
     com_err_ entry options (variable),
     expand_path_ entry (ptr, fixed bin (21), ptr, ptr, fixed bin (35)),
     hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35));

/* automatic */

dcl  arg_len fixed bin (21),
     arg_ptr ptr,
     cdtex fixed bin,
     code fixed bin (35),
     dname char (168),
     ename char (32),
     now fixed bin (71);

/* internal static initial */

dcl  my_name char (16) internal static initial ("reset_cdt_meters");

/* based */

dcl  arg_string char (arg_len) based (arg_ptr);

/* builtins */

dcl (addr, clock, null) builtin;

/* conditions */

dcl cleanup condition;

/* include files */

%include author_dcl;
%include cdt;
%include dialup_values;

/* program */

	cdtp = null;
          on cleanup call clean_up;
	dname = ">system_control_1";
	ename = "cdt";

	call cu_$arg_ptr (1, arg_ptr, arg_len, code);
	if code = 0 then do;
	     call expand_path_ (arg_ptr, arg_len, addr (dname), addr (ename), code);
	     if code ^= 0 then do;
		call com_err_ (code, my_name, "^a", arg_string);
		return;
	     end;
	end;

	call hcs_$initiate (dname, ename, "", 0, 1, cdtp, code);
	if cdtp = null then do;
	     call com_err_ (code, my_name, "^a>^a", dname, ename);
	     return;
	end;

	cdt.realtime_in_dialup = 0;
	cdt.cpu_in_dialup = 0;
	cdt.pf_in_dialup = 0;
	cdt.pp_in_dialup = 0;
	cdt.entries_to_dialup = 0;
	now = clock ();
	cdt.meters_last_reset = now;

	do cdtex = 1 to cdt.current_size;
	     cdtep = addr (cdt.cdt_entry (cdtex));

	     cdte.n_dialups = 0;
	     cdte.n_logins = 0;
	     cdte.dialed_up_time = 0;
	     if cdte.in_use < NOW_DIALED then
		cdte.dialup_time = 0;
	     else cdte.dialup_time = now;
	end;
          call clean_up;
          return;

clean_up: proc;
          if cdtp ^= null then
	call hcs_$terminate_noname (cdtp, code);
	return;

     end clean_up;
     end reset_cdt_meters;




		    restore_pdt_access.pl1          07/13/88  1112.5r w 07/13/88  0942.4       47682



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


restore_pdt_access: proc;

/* RESTORE_PDT_ACCESS - This program can be run after a crash to regenerate the ACL's of
   the PDT's in >sc1>pdt, and also the ACL of >sc1>update.
   (Access control lists seem to be expecially vulnerable to crashes.)

   THVV 1/74 */
/* Modified March 1982 by E. N. Kittlitz to eliminate proj_admin_seg */

dcl  pdtdir char (168) aligned int static init (">system_control_1>pdt"),
     pdtname char (32) aligned,
     sc1 char (168) aligned int static init (">system_control_1"),
     nacl fixed bin,
     sel_proj char (32) aligned init (""),
     sat_name char (32) aligned,
     datestr char (16) aligned,
    (i, ii, iii, m, lng, sm, slng, j, k) fixed bin,
     ec fixed bin (35),
     an fixed bin init (1),
    (argp, satp, satep) pointer,
     arg char (slng) based (argp),
     strn1 char (28) aligned init (""),
     ct fixed bin init (0),
     ct1 fixed bin init (0);

dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     com_err_ entry options (variable),
     ioa_ entry options (variable),
     ioa_$rsnnl entry options (variable),
     hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned,
     fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35)),
     clock_ entry () returns (fixed bin (71)),
     date_time_ entry (fixed bin (71), char (*) aligned);
dcl  hcs_$add_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35));
dcl  hcs_$add_dir_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35));

dcl 1 acls (6) aligned,
    2 name char (32),
    2 modes bit (36),
    2 mbz bit (36),
    2 erc fixed bin (35);

dcl 1 dacls (6) aligned,
    2 name char (32),
    2 modes bit (36),
    2 erc fixed bin (35);

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

/* ================================================ */

%include sat;
%include user_attributes;
/* ================================================ */

/* INITIALIZATION - LOCATE AND INITIATE SAT */


	do j = 1 to 6;				/* Set up acl structures. */
	     acls.mbz (j) = "0"b;
	     acls.modes (j) = "100"b;			/* "R" access for pdt */
	     dacls.modes (j) = "001"b;		/* "A" access for dir update */
	end;
	acls.name (1) = "*.SysDaemon.*";
	acls.name (2) = "*.SysAdmin.*";
	acls.modes (1), acls.modes (2) = "101"b;	/* These guys get RW. */

	call hcs_$initiate (sc1, "sat", "", 0, 0, satp, ec);
	if satp = null then do;
	     call com_err_ (ec, "restore_pdt_access", "sat");
	     return;
	end;
	if sat.version ^= SAT_version then do;
	     call com_err_ (0, "restore_pdt_access",
	     "SAT version is inconsistent with declarations used by this program");
	     go to exit;
	end;

arglp:	call cu_$arg_ptr (an, argp, slng, ec);		/* get next arg -- a project name */
	if ec ^= 0 then go to endarg;			/* last arg? */
	else do;
	     sel_proj = arg;
	end;

next_arg: an = an + 1;
	go to arglp;				/* loop on args */
endarg:	if sel_proj ^= "" then go to quickie;

quickie:	do i = 1 to sat.current_size;			/* loop thru SAT looking for delegated projects */
	     satep = addr (sat.project (i));		/* get ptr to slide down sat entries */
	     if project.state = 1 then do;
		if sel_proj ^= "" then if sel_proj ^= project.project_id then go to endsatloop;
		ct = ct + 1;			/* Count all valid projects found. */
		call ioa_$rsnnl ("^a.pdt", pdtname, k, project.project_id);
		if project.admin (1).userid = "" then do;
		     call hcs_$add_acl_entries (pdtdir, pdtname, addr (acls), 2, ec);
		     if ec ^= 0 then call com_err_ (ec, "restore_pdt_access", "Cannot set ACL of ^a", pdtname);
		end;
		else do;
		     ct1 = ct1 + 1;
		     nacl = 0;			/* Found pdt to be fixed. */
		     do j = 1 to 4;			/* Make up acls. */
			acls.name (j+2) = project.admin.userid (j);
			if acls.name (j+2) = "" then go to setit;
			k = index (acls.name (j+2), " ");
			substr (acls.name (j+2), k, 2) = ".*";
			dacls.name (j) = acls.name (j+2);
			nacl = nacl + 1;
		     end;
setit:		     call hcs_$add_acl_entries (pdtdir, pdtname, addr (acls), nacl+2, ec);
		     if ec ^= 0 then call com_err_ (ec, "restore_pdt_access", "Cannot restore ACL of ^a", pdtname);
		     call hcs_$add_dir_acl_entries (sc1, "update", addr (dacls), nacl, ec);
		     if ec ^= 0 then call com_err_ (ec, "restore_pdt_access", "Cannot add ACL to update: ^a",
			project.project_id);
		end;
	     end;
endsatloop: end;
	if sel_proj ^= "" then if ct = 0 then do;
	     call ioa_ (" Project ^a not found in SAT", sel_proj);
	end;
	else if ct1 = 0 then do;
	     call ioa_ ("^a is not currently a delegated project", sel_proj);
	end;

exit:	call hcs_$terminate_noname (satp, ec);
	return;

     end restore_pdt_access;




		    search_sat_.pl1                 07/13/88  1112.5r w 07/13/88  0942.4       52659



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


/* format: style4 */

/*
   Written Feb 1980 by M. B. Armstrong to implement multiple rate structures. (UNCA)
   Modified June 1981 by E. N. Kittlitz to implement UNCA rate structures.
   Modified June 1982 by E. N. Kittlitz to return initiate error code correctly.
*/

search_sat_:
     proc;					/* this entry should not be called */
	return;

/*
   This procedure locates the named project in the sat and returns project information
   Current entry points are:
   search_sat_$rs_number (P_project, P_rs_number, error_code)            return the rate_structure index
   search_sat_$sequential (P_first, P_project, P_rs_number, error_code)    get the next entry in sat - first if P_first = "1"b
   search_sat_$clean_up                                              reset internal static variables
*/

/* Parameters */

dcl  P_code fixed bin (35);
dcl  P_project_name char (*);
dcl  P_first bit (1) aligned;
dcl  P_rs_number fixed bin;

/* Automatic */

dcl  satep ptr;
dcl  code fixed bin (35);

/* Internal static */

dcl  static_satx fixed bin internal static;		/* index into sat projects */
dcl  satp internal static ptr init (null);		/* pointer to SAT */
dcl  shtp internal static ptr init (null);		/* pointer to SAT hash table */
dcl  no_hash bit (1) aligned internal static init ("0"b);	/* on if we couldn't find the sat.ht */
dcl  no_sat bit (1) aligned internal static init ("0"b);	/* on if we couldn't find the sat */

/* External entries */

dcl  hash_$search entry (ptr, char (*), fixed bin, fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));	/* file system */

/* External static */

dcl  (
     error_table_$noentry,
     error_table_$end_of_info
     ) external fixed bin (35);

/* builtins and conditions */

dcl  no_write_permission condition;

dcl  (addr, null) builtin;
%page;
/* =================================================== */

rs_number:
     entry (P_project_name, P_rs_number, P_code);		/* This entry returns the rate index for the named project */

	if ^setup () then do;
	     P_rs_number = 0;
	     go to error_return;
	end;
	satep = find_project (P_project_name);
	if satep = null then do;
	     P_rs_number = 0;
	     P_code = error_table_$noentry;
	end;
	else do;
	     P_rs_number = project.rs_number;
	     P_code = 0;
	end;
	return;

/* =================================================== */

sequential:
     entry (P_first, P_project_name, P_rs_number, P_code);	/* This entry will search the sat sequentially */

	if ^setup () then do;
	     P_project_name = "";
	     P_rs_number = 0;
	     go to error_return;
	end;
	if P_first then static_satx = 0;		/* start at the beginning */

next:
	static_satx = static_satx + 1;
	if static_satx > sat.current_size then do;	/* all finished? */
	     P_project_name = "";
	     P_rs_number = 0;
	     P_code = error_table_$end_of_info;
	     return;
	end;
	satep = addr (sat.project (static_satx));	/* point to the project */
	if project.state = 0 then goto next;		/* not a valid entry */

	P_project_name = project.project_id;
	P_rs_number = project.rs_number;
	P_code = 0;
	return;

/* =================================================== */

clean_up:
     entry;					/* This entry allows a process to clean up its KST */

	call hcs_$terminate_noname (satp, code);	/* clean up */
	call hcs_$terminate_noname (shtp, code);	/* clean up */
	satp, shtp = null;				/* reset internal static */
	no_hash, no_sat = "0"b;
	static_satx = 0;
	return;

error_return:
	if code ^= 0 then
	     P_code = code;
	else P_code = error_table_$noentry;
	return;
%page;
find_project:
     proc (P_proj) returns (ptr);			/* internal procedure to locate a project in the sat */

dcl  P_proj char (*);
dcl  satx fixed bin;

	if ^no_hash then do;			/* i.e. there is a hash table */
	     on no_write_permission
		begin;
		     revert no_write_permission;
		     no_hash = "1"b;
		     goto sequential_search;		/* too bad but them's the breaks */
		end;
	     call hash_$search (shtp, P_proj, satx, code);/* search the SAT hash table for project */
	     revert no_write_permission;
	     if code = 0 then			/* don't believe everything you're told */
		if addr (sat.project (satx)) -> project.state ^= 0
		     & addr (sat.project (satx)) -> project.project_id = P_proj then
		     return (addr (sat.project (satx)));
	end;

sequential_search:
	do satx = 1 to sat.current_size;
	     satep = addr (sat.project (satx));		/* point to a project */
	     if project.state ^= 0 then		/* is it not a hole? */
		if project.project_id = P_proj then return (addr (sat.project (satx)));
	end;
	return (null);				/* couldn't find the project anywhere */

     end find_project;


setup:
     proc returns (bit (1) aligned);			/* initiates the sat and the sat hash table */

	code = 0;
	if no_sat then return ("0"b);
	if satp ^= null then return ("1"b);
	call hcs_$initiate (">system_control_dir", "sat", "", 0, 0, satp, code);
	if satp = null then do;
	     no_hash = "1"b;
	     no_sat = "1"b;
	     return ("0"b);
	end;
	call hcs_$initiate (">system_control_dir", "sat.ht", "", 0, 0, shtp, code);
	if shtp = null then no_hash = "1"b;		/* must search whole sat */
	return ("1"b);

     end setup;
%page;
%include sat;
%page;
%include user_attributes;

     end search_sat_;




		    set_special_password.pl1        10/19/92  1615.2rew 10/19/92  1612.2       58752



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

/* set_special_password: Manipulates non-alias non-mte PNTE's */
/* format: style2 */

set_special_password:
     procedure options (variable);

/* BIM 1984-10-08 */


/****^  HISTORY COMMENTS:
  1) change(89-05-23,Beattie), approve(89-09-29,MCR8113),
     audit(89-10-02,Farley), install(89-10-03,MR12.3-1082):
     Display an appropriate error message if the add or update to the
     PNT operation returns a non-zero error code.
  2) change(90-11-22,Vu), approve(90-11-22,MCR8230),
     audit(92-09-30,WAAnderson), install(92-10-19,MR12.5-1029):
     Query the user twice for the password by default.
                                                   END HISTORY COMMENTS */


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

	if arg_count = 0
	then do;
		call com_err_$suppress_name (0, ME, USAGE_LINE);
		return;
	     end;

	user_name = "";
	user_index = 0;
	none_flag = "0"b;
	prompt_flag = "1"b;
	password_flag = "0"b;
	password = "";
	do argx = 1 to arg_count;
	     call cu_$arg_ptr (argx, ap, al, (0));
	     if index (argument, "-") ^= 1
	     then do;
		     if user_name ^= ""
		     then do;
			     call com_err_ (0, ME, "More than one user name supplied.");
			     return;
			end;
		     user_name = argument;
		end;
	     else if argument = "-none"
	     then do;
		     none_flag = "1"b;
		     prompt_flag = "0"b;
		     password = "";
		end;
	     else if argument = "-prompt"
	     then do;
		     prompt_flag = "1"b;
		     none_flag = "0"b;
		     password = "";
		end;
	     else if argument = "-password"
	     then do;
		     prompt_flag = "0"b;
		     none_flag = "0"b;
		     if argx = arg_count
		     then do;
			     call com_err_ (error_table_$noarg, ME, "A password must be given after -password");
			     return;
			end;
		     argx = argx + 1;
		     call cu_$arg_ptr (argx, ap, al, (0));
		     password = argument;
		end;
	     else do;
		     call com_err_ (error_table_$badopt, ME, USAGE_LINE);
		     return;
		end;
	end;
	if user_name = ""
	then do;
		call com_err_ (error_table_$noarg, ME, USAGE_LINE);
		return;
	     end;

	do user_index = 1 to hbound (SPECIAL_USER_NAME_ARRAY, 1);
	     if user_name = SPECIAL_USER_NAME_ARRAY (user_index).command_line_name
	     then go to HAVE_USER_INDEX;
	end;
	call com_err_ (0, ME, "The name ""^a"" is not a special person name.", user_name);
	return;

HAVE_USER_INDEX:
	if prompt_flag
          then do;
               call read_password_ ("Password", password);
               save_password = password;
               password = " ";
               call read_password_ ("Password Again", password);
               if password ^= save_password
               then do;
                    call com_err_$suppress_name (0, ME, "Password typed incorrectly second time.");
                    call com_err_$suppress_name (0, ME, "Password has not been changed.");
                    password = " ";
                    save_password = " ";
                    return;
                end;
                save_password = " ";
           end;

	if ^none_flag
	then password = scramble_ (password);
	else password = "";

	pnt_entry_name = SPECIAL_USER_NAME_ARRAY (user_index).pnte_entry_name;

	unspec (PNTE) = ""b;
	call pnt_manager_$admin_get_entry (pnt_entry_name, addr (PNTE), code);
	if code = 0
	then update = "1"b;
	else if code = error_table_$id_not_found
	then do;
		update = "0"b;
		unspec (PNTE) = ""b;
		PNTE.version = PNT_ENTRY_VERSION_2;
		PNTE.user_id = pnt_entry_name;
	     end;
	else do;
		call com_err_ (code, ME, "Looking in PNT for ^a", pnt_entry_name);
		return;
	     end;

	PNTE.private.pw_flags.short_pw = "1"b;
	PNTE.password = password;
	PNTE.alias = "";
	PNTE.default_project = "";
	PNTE.flags = "0"b;
	PNTE.flags.trap, PNTE.flags.lock = "1"b;
	PNTE.flags.has_password = (password ^= "");

	if update
	then call pnt_manager_$update_entry (addr (PNTE), "1"b, "0"b, code);
						/* set password, leave network PW alone */
	else call pnt_manager_$add_entry (pnt_entry_name, addr (PNTE), code);

	if code ^= 0
	then call com_err_ (code, ME, "Error encountered while ^[updating^;adding to^] the PNT.", update);

	return;
%page;
	declare com_err_		 entry () options (variable);
	declare com_err_$suppress_name entry () options (variable);
	declare cu_$arg_count	 entry (fixed bin, fixed bin (35));
	declare cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	declare pnt_manager_$admin_get_entry
				 entry (char (*), pointer, fixed bin (35));
	declare pnt_manager_$update_entry
				 entry (pointer, bit (1) aligned, bit (1) aligned, fixed bin (35));
	declare pnt_manager_$add_entry entry (char (*), pointer, fixed bin (35));
	declare read_password_	 entry (character (*), character (*));
	declare scramble_		 entry (character (8)) returns (character (8));
	declare error_table_$badopt	 fixed bin (35) ext static;
	declare error_table_$id_not_found
				 fixed bin (35) ext static;
	declare error_table_$noarg	 fixed bin (35) ext static;

	declare arg_count		 fixed bin;
	declare argx		 fixed bin;
	declare ap		 pointer;
	declare al		 fixed bin (21);
	declare argument		 char (al) based (ap);
	declare code		 fixed bin (35);
	declare ME		 char (20) int static options (constant) init ("set_special_password");
	declare none_flag		 bit (1) aligned;
	declare prompt_flag		 bit (1) aligned;
	declare password_flag	 bit (1) aligned;
	declare password		 char (8);
	declare pnt_entry_name	 char (32);
          declare save_password          char (8);
	declare USAGE_LINE		 char (80) int static options (constant)
				 init (
				 "Usage: set_special_password special_person_name -prompt|-none|-password PASSWORD"
				 );
	declare user_index		 fixed bin;
	declare user_name		 char (32);
	declare update		 bit (1) aligned;
	declare 1 PNTE		 aligned like pnt_entry;

	declare addr		 builtin;
	declare hbound		 builtin;
	declare index		 builtin;
	declare unspec		 builtin;

%page;
%include pnt_entry;
%page;
%include special_person_names;

     end set_special_password;




		    set_system_console.pl1          03/25/86  0848.0r   03/25/86  0847.6      117468



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: off */

set_system_console:
ssc:
     proc;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*										*/
	/* Purpose:									*/
	/* 										*/
	/*      This module implements the set_system_console operator console reconfiguration command. Its	*/
	/* sole charter in life is to manipulate operator's consoles.				*/
	/*										*/
	/* Syntax:									*/
	/*										*/
	/* 	set_system_console {console_name} {-control_arg}					*/
	/*										*/
	/* Arguments:									*/
	/*										*/
	/*	console_name -	Is the name of the console to be affected by the call. If ommitted	*/
	/*			the bootload console is assumed.				*/
	/*										*/
	/* Control arguments:								*/
	/*										*/
	/* 	-crash		specifies that the system is to crash if all attempts at console	*/
	/*			recovery fail.						*/
	/*										*/
	/*	-reset		resets the bootload console. The given console_name is ignored.	*/
	/*										*/
	/*	-run		specifies that the system should continue to run as long as possible	*/
	/*			without a configured console should all attempts at recovery fail.	*/
	/*										*/
	/*	-state	<state>	specifies that the state of the console should be changed to the 	*/
	/*			given state. The state may have any of the following values:	*/
	/*										*/
	/*		on	makes the specified console the bootload console. The current	*/
	/*			bootload console becomes an I/O device.				*/
	/*										*/
	/*		alt	makes the specified console an alternate console, available for use 	*/
	/*			by console recovery.					*/
	/*										*/
	/*		io	makes the specified console an I/O device, available to IOI.	*/
	/*										*/
	/*		inop	makes the specified console an I/O device, available to IOI.	*/
	/*										*/
	/* The following control arguments are undocumented and are provided for system debug purposes:	*/
	/*										*/
	/*	-enable		enables the previously disabled console service.			*/
	/*										*/
	/*	-disable									*/
	/*	-suspend		both of these arguments can be used to disable / suspend console	*/
	/*			service. If the service is suspended the actions of the system will	*/
	/*			be subject to the current crash / run state. If the system is setup	*/
	/*			to crash on console recovery, it will.				*/
	/*										*/
	/* Note: 	Access to hphcs_ is required to utilize this command.				*/
	/*										*/
	/* Initial Coding:		830820							*/
	/*										*/
	/* Author:		E. A. Ranzenbach	(Ranzenbach.Multics@M)			*/
	/* Location:		System-M.							*/
	/* Release:		MR10.2							*/
	/*										*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*										*/
	/* Modifications:									*/
	/*										*/
	/* Date:   Author			Reason						*/
	/*										*/
	/* 840420  Edward A. Ranzenbach	Added -prompt control argument.			*/
	/*										*/
	/*										*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


     call process_arguments ();					/* get command options...		*/

     if setting_prompt then do;
	call hphcs_$ocdcm_set_prompt (prompt_string);
	return;
     end;

     if reconfiguring then do;
	if reconfig_option = RESET_CONSOLE then console_name = "";		/* can only reset the bootload console..*/
	call hphcs_$ocdcm_reconfigure (console_name, reconfig_option, code);	/* and let's do it...		*/
	if code ^= 0 then call err (exit, code, "Operation failed.");
     end;

     return;							/* done...			*/

process_arguments:
     proc;
     
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*										*/
	/* Internal procedure to obtain the argument count, check it for high and low bounds, and last but	*/
	/* not least process the command arguments...						*/
	/*										*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


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

     min_arg_count = 1;
     max_arg_count = 5;
     command_name = "set_system_console";

     call cu_$af_arg_count (arg_count, code);
     if code = 0 then do;
	call err (exit, error_table_$active_function, command_name);	/* can't be invoked as an AF...	*/
     end;
     else if code ^= error_table_$not_act_fnc then do;
	call err (exit, code, command_name);
     end;
     else code = 0;

     if (arg_count < min_arg_count | arg_count > max_arg_count) then do;
USAGE:	call ioa_$rs ("Usage:^-^a {console_name} {-control_args}", err_msg, 0, command_name);
	call err (exit, code, err_msg);
     end;

     do idx = 1 to arg_count;

	good_arg = false;

	call cu_$arg_ptr (idx, arg_ptr, arg_leng, code);
	if code ^= 0 then call err (exit, code, "Unable to obtain arg_ptr");

	if arg_leng = 0 then call err (exit, error_table_$badopt,
	     "Null input arguments are not allowed.");

	if substr (arg, 1, 1) = "-" then do;				/* must be a control argument...	*/

	     if arg = "-crash" then do;				/* -crash control argument...		*/
		reconfiguring = true;
		reconfig_option = CRASH_ON_CRF;			/* setup reconfiguration option...	*/
	     end;
	     
	     else if arg = "-run" then do;				/* -run control argument...		*/
		reconfig_option = RUN_ON_CRF;				/* setup reconfiguration option...	*/
		reconfiguring = true;
	     end;
	     
	     else if arg = "-enable" then do;				/* -enable control argument...	*/
		reconfig_option = ENABLE_CONSOLE_SERVICE;		/* setup reconfiguration option...	*/
		reconfiguring = true;
	     end;

	     else if arg = "-suspend" | arg = "-disable" then do;		/* -suspend | -disable control arg...	*/
		reconfig_option = SUSPEND_CONSOLE_SERVICE;		/* setup reconfiguration option...	*/
		reconfiguring = true;
	     end;

	     else if arg = "-reset" then do;				/* -reset control argument...		*/
		reconfig_option = RESET_CONSOLE;			/* setup reconfiguration option...	*/
		reconfiguring = true;
	     end;
	     
	     else if arg = "-state" then do;				/* -state control argument...		*/
		reconfiguring = true;
		idx = idx + 1;					/* get the requested state...		*/
		if idx > arg_count then call err (exit, error_table_$wrong_no_of_args, "A state must be supplied.");
		call cu_$arg_ptr (idx, arg_ptr, arg_leng, code);
		if code ^= 0 then call err (exit, code, "Unable to get state.");
		
		if arg = "on" then do;				/* ON state...			*/
		     reconfig_option = MAKE_BOOTLOAD_CONSOLE;		/* setup reconfiguration option...	*/
		end;

		else if arg = "alt" then do;				/* ALT state...			*/
		     reconfig_option = MAKE_ALTERNATE_CONSOLE;		/* setup reconfiguration option...	*/
		end;

		else if arg = "io" then do;				/* IO state...			*/
		     reconfig_option = MAKE_IO_DEVICE;			/* setup reconfiguration option...	*/
		end;

		else if arg = "inop" then do;				/* INOP state...			*/
		     reconfig_option = MAKE_INOP_DEVICE;		/* setup reconfiguration option...	*/
		end;

		else if arg = "off" then do;				/* OFF state...			*/
		     reconfig_option = MAKE_UNAVAILABLE;		/* setup reconfiguration option...	*/
		end;

		else do;						/* BAD state...			*/
		     call ioa_$rs ("^a is not a legal console state.", err_msg, 0, arg);
		     call err (exit, 0, err_msg);			/* and let them know...		*/
		end;
	     end;

	     else if arg = "-prompt" then do;
/*		setting_prompt = true;	UNCOMMENT FOR -prompt FEATURE */
		idx = idx + 1;					/* get the requested prompt...		*/
		if idx <= arg_count then do;				/* get specified prompt...		*/
		     call cu_$arg_ptr (idx, arg_ptr, arg_leng, code);
		     if code ^= 0 then call err (exit, code, "Unable to get prompt string.");
		     prompt_string = arg;
		end;
	     end;
	     
	     else do;
		code = error_table_$badopt;				/* setup the proper error...		*/
		call err (exit, code, arg);				/* and let them know...		*/
	     end;
	end;

	else do;							/* must be the console_name...	*/
	     if arg_leng = 4 then do;					/* console names are that long...	*/
		if substr (arg, 1, 3) = "opc" then do;			/* do some preliminary checking...	*/
		     if search (substr (arg, 4, 1), "abcdefgh") = 1 then do;/* must have "opcx" type name...	*/
			console_name = arg;				/* console name looks OK...		*/
			good_arg = true;
		     end;
		end;
	     end;
	     if ^good_arg then do;					/* BAD console name...		*/
		call ioa_$rs ("^a is not a legal console name.", err_msg, 0, arg);
		call err (exit, 0, err_msg);				/* let them know...			*/
	     end;
	end;
     end;

     return;
     
end process_arguments;

err:
     proc (exit_sw, err_code, ctl_str);
	

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*										*/
	/* Internal procedure that reports errors to the user and optionally exits then main procedure.	*/
	/* This last function is dependant upon the value of exit_sw. If found to be on a non-local go to	*/
	/* is made to the "EXIT" label in the main procedure. If off this procedure returns to its caller.	*/
	/*										*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/* parameters... (I) = Input, (O) = Output */

     dcl	exit_sw			bit	(1)	parameter;	/* to exit or not to exit...	      (I) */
     dcl	err_code			fixed bin	(35)	parameter;	/* passed to com_err_...	      (I) */
     dcl	ctl_str			char	(*)	parameter;
     /* optional com_err_ ctl string...  (I) */
	
/* entries... */

     dcl	com_err_ entry() options(variable);
     dcl	requote_string_ entry (char(*)) returns(char(*));
	
/* miscellaneous... */

     dcl	requoted_ctl_str		char	(256)	init	("");

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

     if index (ctl_str, """") > 0 then do;
	requoted_ctl_str = requote_string_ (ctl_str);
	call com_err_ (err_code, command_name, requoted_ctl_str);
     end;
     else do;
	call com_err_ (err_code, command_name, ctl_str);
     end;
     
     if exit_sw then go to EXIT;

     return;

end err;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*										*/
	/* 				Declarations...					*/
	/* format: off									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/* entries... */

     dcl	cu_$af_arg_count entry (fixed bin, fixed bin(35));
     dcl	cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
     dcl	hphcs_$ocdcm_reconfigure entry (char (4), fixed bin (17), fixed bin (35));
     dcl	ioa_$rs entry() options(variable);
     dcl	hphcs_$ocdcm_set_prompt entry (char (6));
     
/* builtins... */

     dcl	index			builtin;
     dcl	null			builtin;
     dcl	search			builtin;
     dcl	substr			builtin;
     
/* pointers... */

     dcl	arg_ptr			ptr		init	(null);	/* -> argument...			*/

/* switches... */

     dcl	true			bit	(1)	init	("1"b)
				internal static	options (constant);

     dcl	false			bit	(1)	init	("0"b)
				internal static	options (constant);

     dcl	exit			bit	(1)	init	("1"b)	/* exit -> fatal error...		*/
				internal static	options (constant);

     dcl	good_arg			bit	(1)	init	("0"b);	/* ON => valid argument...		*/
     dcl	reconfiguring		bit	(1)	init	("0"b);	/* ON => were reconfiguring consoles...	*/
     dcl	setting_prompt		bit	(1)	init	("0"b);	/* ON => were changing prompt...		*/

/* error_table_... */

     dcl	error_table_$active_function	fixed bin	(35)	external static;
     dcl	error_table_$badopt		fixed bin	(35)	external static;
     dcl	error_table_$not_act_fnc	fixed bin	(35)	external static;
     dcl	error_table_$wrong_no_of_args	fixed bin	(35)	external static;
     
/* miscellaneous... */

     dcl	arg			char	(arg_leng)		/* argument...			*/
				based	(arg_ptr);
     dcl	arg_count			fixed bin	(17)	init	(0);	/* number of arguments...		*/
     dcl	arg_leng			fixed bin	(21)	init	(0);	/* length, (in bytes), of argument...	*/
     dcl	command_name		char	(32)	init	("");
     dcl	console_name		char	(4)	init	("");	/* name of the console to be affected...*/
     dcl	code			fixed bin	(35)	init	(0);	/* standard Multics error code...	*/
     dcl	err_msg			char	(80)	init	("");	/* to report errors...		*/
     dcl	idx			fixed bin	(17)	init	(0);	/* miscellaneous working index...	*/
     dcl	min_arg_count		fixed bin	(17)	init	(0);	/* minimum number of arguments...	*/
     dcl	max_arg_count		fixed bin	(17)	init	(0);	/* maximum number of arguments...	*/
     dcl	prompt_string		char	(6)	init	("");
     dcl	reconfig_option		fixed bin	(17)	init	(0);	/* action to take...		*/

/* includes... */

%include opc_reconfig_options;

EXIT:

     return;

end set_system_console;




		    sweep_disk_.pl1                 10/27/83  1614.3rew 10/27/83  1442.0       66879



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


sweep_disk_: proc (path, counter);

/* SWEEP_DISK_ - driver for statistics programs.

   This program is called with a pathname, the root node of a tree
   to sweep, and a function, which will be called for each directory entry.
   The program recursively walks down the directory tree and
   calls the user function for each entry found.

   This version of the program will try to give itself access if it doesn't have it

   THVV

   Modified on 9 September 1976 by R. G. Bratt to not terminate and to use (get release)_temp_segments_.
   Modified on 5 June 1975 by J. C. Whitmore to attempt to set system privileges.
   sweep_disk_$dir_list entry point added to call hcs_$star_dir_list_ 05/29/79 S. Herbst

   */

dcl  path char (168) aligned,				/* path name to sweep */
     counter entry (char (168) aligned, char (32) aligned, fixed bin,
     char (32) aligned, ptr, ptr);

dcl  areap ptr,					/* ptr to area segment. */
     one_ptr (1) ptr init (null),
     myname char (11) init ("sweep_disk_") static options (constant),
     ec fixed bin (35);				/* err code */

dcl  bfsw bit (1) int static init ("1"b);		/* default will suppress non fatal errors */
dcl  dir_list_sw bit (1);				/* ON: sweep_disk_$dir_list */
dcl  priv_set bit (1);				/* flag to tell that system privileges are off */
dcl  priv fixed bin (35);				/* this will be zero if we set system privileges */

dcl  sys_info$max_seg_size fixed bin (35) ext;

dcl 1 acla (1) aligned,
    2 userid char (32),
    2 modes bit (36),
    2 erc fixed bin (35);

dcl 1 delacla (1) aligned,
    2 userid char (32),
    2 erc fixed bin (35);


dcl  com_err_ entry options (variable),
     get_group_id_ entry () returns (char (32) aligned),
     expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)),
     area_ entry (fixed bin (35), ptr);

dcl  error_table_$ai_restricted fixed bin (35) ext;

dcl  system_privilege_$dir_priv_on entry (fixed bin (35));
dcl  system_privilege_$dir_priv_off entry (fixed bin (35));
dcl  hcs_$add_dir_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35));
dcl hcs_$delete_dir_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35));
dcl (hcs_$star_list_, hcs_$star_dir_list_) entry
     (char (*) aligned, char (*) aligned, fixed bin (3), ptr, fixed bin, fixed bin, ptr, ptr, fixed bin (35));
dcl  get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
dcl  release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));

dcl (cleanup, linkage_error) condition;
dcl (addr, fixed, index, null, substr) builtin;

/* - - - - */


	dir_list_sw = "0"b;				/* sweep_disk_ entry */
	go to COMMON;

dir_list: entry (path, counter);

	dir_list_sw = "1"b;

COMMON:	call get_temp_segments_ (myname, one_ptr, ec);
	areap = one_ptr (1);
	call area_ (sys_info$max_seg_size, areap);
	acla (1).userid = get_group_id_ ();
	delacla (1).userid = acla (1).userid;
	acla (1).modes = "111"b;

	priv_set = "0"b;
	priv = 1;

	on cleanup call clean_up;			/* so we can undo what we did */

	call process (path, 0, dir_list_sw);		/* start recursion */
	call clean_up;

	return;					/* Done. */


/* - - - - - - - - - - - - - - */

process:	proc (apth, lvl, asw);

/* internal doit procedure */

dcl  apth char (168) aligned,				/* path of tree to process */
     lvl fixed bin,					/* recursion level */
     asw bit (1);					/* ON: star_dir_list_; OFF: star_list_ */

dcl  npth char (168) aligned,				/* new path for recursion */
     dstar char (32) aligned init ("**") internal static,	/* for star, gets all. */
     ddn char (168) aligned,				/* ... for expand */
     een char (32) aligned,				/* ... */
     c32 char (32) aligned,
     error_table_$nomatch fixed bin ext,
     ifail fixed bin (35),
    (eptr, nptr) ptr init (null),			/* for star */
     ecc fixed bin (35),
    (t, bcount, lc, ii, nix) fixed bin;			/* indices */

dcl  names (100) char (32) aligned based (nptr);		/* Structure returned by star_ */

dcl 1 branches (100) aligned based (eptr),		/* ... */
    2 type bit (2) unaligned,				/* 10b is directory */
    2 nnam bit (16) unaligned,			/* number of names this seg */
    2 nindex bit (18) unaligned,			/* index in names structure */
    2 padx bit (108) unaligned;

	     on cleanup begin;
		if eptr ^= null then free eptr -> branches;
		if nptr ^= null then free nptr -> names;
		if ifail = 0 then call hcs_$delete_dir_acl_entries (ddn, een, addr (delacla), 1, ecc);
	     end;

	     t = index (apth, " ") - 1;
	     call expand_path_ (addr (apth), t, addr (ddn), addr (een), ecc);
	     if ecc ^= 0 then do;
		call com_err_ (ecc, myname, apth);
		return;
	     end;
RETRY:	     call hcs_$add_dir_acl_entries (ddn, een, addr (acla), 1, ifail);
	     if ifail ^= 0 then
		if ifail = error_table_$ai_restricted & ^priv_set then do;

		     on linkage_error go to REVERT_HANDLER;

		     call system_privilege_$dir_priv_on (priv);
		     priv_set = "1"b;
REVERT_HANDLER:
		     revert linkage_error;
		     if ^priv_set then do;		/* linkage_error */
			if ^bfsw then call com_err_ (0, myname,
			     "Unable to set directory privilege.
Cannot reference AIM-restricted directory.");
			priv = 1;
		     end;

		     priv_set = "1"b;		/* try only once to set priv */
		     go to RETRY;
		end;
	     if asw then call hcs_$star_dir_list_ (apth, dstar, 111b, areap, bcount, lc, eptr, nptr, ecc);
	     else call hcs_$star_list_ (apth, dstar, 111b, areap, bcount, lc, eptr, nptr, ecc);
	     if ecc = error_table_$nomatch then go to pexit; /* Get all names. If none, go. */
	     if ecc ^= 0 then do;			/* If any other error from star, name it. */
		if ^bfsw then call com_err_ (ecc, myname, "Error listing contents of ^a", apth);
		go to pexit;
	     end;
inloop:	     do ii = 1 to bcount + lc;		/* Now do all branches, look for sub-dirs. */
		nix = fixed (eptr -> branches (ii).nindex);
		c32 = nptr -> names (nix);
		call counter (ddn, een, lvl, c32, addr (eptr -> branches (ii)), nptr);
		if eptr -> branches (ii).type = "10"b then do;
		     if t > 1 then			/* Fabricate path name. */
			npth = substr (apth, 1, t) || ">" || c32;
		     else do;			/* The root is special. */
			npth = ">" || c32;
			if npth = ">process_dir_dir" then go to nopdir;
			if npth = ">pdd" then go to nopdir;
			if npth = ">PDD" then go to nopdir;
		     end;
		     call process (npth, lvl+1, asw);	/* recursion here */
nopdir:		end;
	     end inloop;
	     free eptr -> branches;			/* Clean up area. */
	     free nptr -> names;			/* ... */
pexit:	     if ifail = 0 then call hcs_$delete_dir_acl_entries (ddn, een, addr (delacla), 1, ecc);
	end process;				/* Whew. */


loud:	entry;					/* entry to print more error messages */
	bfsw = "0"b;
	return;

clean_up:	proc;
	     if priv = 0 then call system_privilege_$dir_priv_off (priv);
	     if one_ptr (1) ^= null () then call release_temp_segments_ (myname, one_ptr, ec);
	     return;
	end clean_up;

     end;




		    syserr_log_util_.pl1            03/14/85  0810.8r w 03/13/85  1100.2       88047



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
syserr_log_util_:
     procedure ();

/* *	SYSERR_LOG_UTIL_
   *
   *	Interim version of syserr interface to new logging software, to be used
   *	until all relevant programs have been converted to use log_read_ instead.
   *
   *	84-09-30, W. Olin Sibert: Initial coding
   *    1985-01-21, BIM, EJ Sharpe: reverse-convert new data classes.
   */

declare	P_pathname char (*) parameter;
declare	P_access bit (36) aligned parameter;
declare	P_buffer_ptr pointer parameter;
declare	P_buffer_lth fixed bin parameter;
declare	P_message_lth fixed bin parameter;
declare	P_search_time fixed bin (71) parameter;
declare	P_position fixed bin (35) parameter;
declare	P_message_time fixed bin (71) parameter;
declare	P_message_sequence fixed bin (35) parameter;
declare	P_status_ptr pointer parameter;
declare	P_code fixed bin (35) parameter;

declare   binary_present bit (1) aligned;
declare	data_idx fixed bin;
declare	log_dname char (168);
declare	log_ename char (32);
declare   new_binary bit (1) aligned;
declare   old_data_class fixed bin (35);
declare	position_idx fixed bin (35);
declare	temp_code fixed bin (35);
declare	this_lth fixed bin;

declare	static_read_data_ptr pointer internal static init (null ());
declare	static_message_ptr pointer internal static init (null ());
declare	static_open_count fixed bin internal static init (0);

declare	error_table_$end_of_info fixed bin (35) external static;
declare	error_table_$long_record fixed bin (35) external static;
declare	error_table_$no_log_message fixed bin (35) external static;
declare	error_table_$not_open fixed bin (35) external static;
declare	error_table_$unsupported_operation fixed bin (35) external static;

declare	log_data_$syserr_log_dir char (168) external static;
declare	log_data_$syserr_log_name char (32) external static;

declare	com_err_ entry options (variable);
declare	expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
declare	log_read_$close entry (pointer, fixed bin (35));
declare	log_read_$next_message entry (pointer, pointer, fixed bin (35));
declare	log_read_$open entry (char (*), char (*), pointer, fixed bin (35));
declare	log_read_$position_time entry (pointer, fixed bin (71), bit (1) aligned, pointer, fixed bin (35));
declare	log_read_$prev_message entry (pointer, pointer, fixed bin (35));

declare  (abs, binary, currentsize, dimension, divide, hbound, length, max, null, size) builtin;

/* */

syserr_log_util_$open:
     entry (P_access, P_code);

	log_dname = log_data_$syserr_log_dir;
	log_ename = log_data_$syserr_log_name;
	goto OPEN_COMMON;



syserr_log_util_$open_path:
     entry (P_pathname, P_access, P_code);

	if (P_pathname = "") then do;
	     log_dname = log_data_$syserr_log_dir;
	     log_ename = log_data_$syserr_log_name;
	     end;

	else do;
	     call expand_pathname_ (P_pathname, log_dname, log_ename, P_code);
	     if (P_code ^= 0) then
		return;
	     end;


OPEN_COMMON:
	if (static_read_data_ptr = null ()) then do;
	     call log_read_$open (log_dname, log_ename, static_read_data_ptr, P_code);
	     if (P_code ^= 0) then			/* Open failed */
		return;
	     end;

	static_open_count = static_open_count + 1;

/* Once open, position to the first message in the log */

	call log_read_$position_time (static_read_data_ptr, 0, "1"b, static_message_ptr, P_code);
	P_access = "11"b;
	return;

/* */

syserr_log_util_$close:
     entry (P_code);

	if (static_read_data_ptr ^= null ()) then do;
	     call log_read_$close (static_read_data_ptr, (0));
	     static_open_count = static_open_count - 1;
	     static_message_ptr = null ();
	     end;

	P_code = 0;
	return;

/* */

syserr_log_util_$read:
     entry (P_buffer_ptr, P_buffer_lth, P_message_lth, P_code);

/* This entry converts from old format to new format */

	if (static_read_data_ptr = null ()) then do;
	     P_code = error_table_$not_open;
	     return;
	     end;

	if (static_message_ptr = null ()) then do;
	     P_code = error_table_$end_of_info;		/* Let our caller know we're done */
	     return;
	     end;

	log_message_ptr = static_message_ptr;	/* New format (input) */
	syserr_msgp = P_buffer_ptr;			/* Old format (output) */
	P_message_lth = 0;

/**** Investigate the data class, if any */

	if dimension (log_message.data, 1) = 0 then binary_present = "0"b;
	else do;
	     binary_present = "1"b;
	     if log_message.data_class = "syserr"
	     then new_binary = "0"b;		/* old data class is tucked into first word of binary */
					/* this was a compatability feature used across
					several implementation phases of the new logger */
	     else do;
		new_binary = "1"b;		/* old data class not in message */
		call convert_data_class (old_data_class);
		if old_data_class = -1	/* unrecognized? */
		then binary_present = "0"b;	/* ignore it */
	     end;
	end;
		    
	this_lth = size (syserr_msg);			/* Evaluate WITHOUT refer extents, to get header size only */
	this_lth = this_lth + divide ((3 + length (log_message.text)), 4, 17, 0);
	if binary_present then 
	     if new_binary then this_lth = this_lth + dimension (log_message.data, 1); /* binary is already the right length */
	else  this_lth = this_lth + max (0, dimension (log_message.data, 1) - 1); /* in old case, remove the word with the data class */

	if (this_lth > P_buffer_lth) then do;
	     P_code = error_table_$long_record;
	     return;
	     end;

	syserr_msg.seq_num = log_message.sequence;
	syserr_msg.time = log_message.time;
	syserr_msg.code = log_message.severity;
	syserr_msg.text_len = length (log_message.text);
	syserr_msg.text = log_message.text;
	syserr_msg.pad = ""b;

	if binary_present then do;
	     if ^new_binary then do;
		syserr_msg.data_code = binary (log_message.data (1));
		syserr_msg.data_size = dimension (log_message.data, 1) - 1;
		do data_idx = 2 to dimension (log_message.data, 1);
		     syserr_msg.data (data_idx - 1) = log_message.data (data_idx);
		end;
	     end;
	     else do;
		syserr_msg.data_code = old_data_class;
		syserr_msg.data_size = dimension (log_message.data, 1);
		syserr_msg.data (*) = log_message.data (*);
	     end;
	end;
	else do;
	     syserr_msg.data_code = 0;
	     syserr_msg.data_size = 0;
	     end;

	call log_read_$next_message (static_read_data_ptr, static_message_ptr, temp_code);
	if (temp_code = error_table_$no_log_message) then	     /* Prevent reading at the next call */
	     static_message_ptr = null ();

	P_message_lth = currentsize (syserr_msg);
	P_code = 0;
	return;

/* */

syserr_log_util_$search:
     entry (P_search_time, P_message_time, P_message_sequence, P_code);

	if (static_read_data_ptr = null ()) then do;
	     P_code = error_table_$not_open;
	     return;
	     end;

	if (P_search_time >= 0) then
	     call log_read_$position_time (static_read_data_ptr, P_search_time, "1"b, static_message_ptr, P_code);
	else call log_read_$position_time (static_read_data_ptr, 1f70b, "0"b, static_message_ptr, P_code);
	if (P_code ^= 0) then
	     return;

	P_message_time = static_message_ptr -> log_message.time;
	P_message_sequence = static_message_ptr -> log_message.sequence;
	P_code = 0;
	return;

/* */

syserr_log_util_$position:
     entry (P_position, P_message_time, P_message_sequence, P_code);

	if (static_read_data_ptr = null ()) then do;
	     P_code = error_table_$not_open;
	     return;
	     end;

	do position_idx = 1 to abs (P_position);
	     if (P_position > 0) then
		call log_read_$next_message (static_read_data_ptr, static_message_ptr, P_code);
	     else call log_read_$prev_message (static_read_data_ptr, static_message_ptr, P_code);

	     if (P_code ^= 0) then
		return;
	     end;

	P_message_time = static_message_ptr -> log_message.time;
	P_message_sequence = static_message_ptr -> log_message.sequence;
	P_code = 0;
	return;

/* */

/* Some unsupported or useless entrypoints */

syserr_log_util_$debug:
     entry ();

	return;



syserr_log_util_$trim:
     entry (P_search_time, P_code);

	goto TRIM_COMMON;



syserr_log_util_$trim_path:
     entry (P_pathname, P_search_time, P_code);


TRIM_COMMON:
	call com_err_ (0, "syserr_log_util_", "New format logs can only be trimmed with date_deleter.");
	P_code = error_table_$unsupported_operation;
	return;



syserr_log_util_$status:
     entry (P_status_ptr, P_code);;

declare 1 so_called_syserr_log_status aligned based,
	2 version fixed bin;


	P_status_ptr -> so_called_syserr_log_status.version = 1;
	P_code = 0;
	return;

convert_data_class:
	procedure (data_class);
declare data_class fixed bin (35);
declare i fixed bin;

/**** This converts character string data classes back into fixed bin
      ones. Note that some data is lost --- e.g. there is no distinguishing
      "disk_err" and "ioi" messages, they are both of new class io_status. */

       data_class = -1;

       do i = 1 to hbound(SB_char_data_classes, 1) while (data_class = -1);
	  if log_message.data_class = SB_char_data_classes(i)
	  then data_class = i;	/* pick up index of first match */
       end;

       if data_class = -1 then return;	/* didn't find a match */

       /* we can make a better guess on the io_status data */
       if log_message.data_class = "io_status" then 
	  if dimension (log_message.data, 1) > size (io_msg)
	  then data_class = SB_io_err_detail;
	  else data_class = SB_io_err;

       return;
       end convert_data_class;
       
%page; %include log_message;
%page; %include syserr_message;
%page; %include syserr_binary_def;
%page; %include io_syserr_msg;
	end syserr_log_util_;




		    unlock_oc.pl1                   10/27/83  1614.3rew 10/27/83  1442.0        8685



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

/* Command to unlock the operator's console when it appears to be "dead" */

/* Modified:
   19 March 1979 by D. Spector: created
   Modified: 830821 to obsolete the command... -E. A. Ranzenbach
*/

/* Requires access to gate hphcs_ */

unlock_oc:
     procedure;

	declare com_err_		 entry options (variable);

START_unlock_oc:

     call com_err_ (0, "unlock_oc", "This command is obsolete.^/To reset the console type ""set_system_console -reset"".");

     end unlock_oc;							/* unlock_oc */




		    terminal_report.pl1             07/13/88  1112.5r w 07/13/88  0942.4      295938



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1986 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(86-11-12,Parisek), approve(86-12-18,MCR7588),
     audit(87-07-17,Johnson), install(87-08-07,MR12.1-1070):
     Initially coded to scan the system answering service logs for login and
     logout messages, and build a list of used terminal types based on this
     information.
                                                   END HISTORY COMMENTS */

terminal_report:
	proc;

	log_read_ptr, log_message_ptr, vptr, sci_ptr, vptr_ansb, vptr_two,
	     temp_ptr, temp_two_ptr, ttp_tot_ptr, temp_as_ptr = null ();

	on cleanup begin;
	     if sci_ptr ^= null () then
		call ssu_$destroy_invocation (sci_ptr);
	end;
	
	call ssu_$standalone_invocation (sci_ptr, "terminal_report", "1.0",
	     cu_$arg_list_ptr (), ssu_abort, code);
	if code ^= 0 then do;
	     call com_err_ (code, "terminal_report", "Failed to create ssu_ invocation.");
	     return;
	end;					/* Using ssu_ entries because calls to log subroutines require the sci_ptr */

	call initialize_options ();
	
	on condition (cleanup)
	     call clean_up ();
	
	call log_match_$add_match (opt.lmd_ptr, "LOGIN");
						/* scan the logs for LOGIN messages only */
	call process_arguments ();			/* validate arguments */
	if ttpsw & usersw then do;
	     call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-user and -ttp");
	     call clean_up;
	end;
	if output_file ^= "" then do;			/* not default */
	     call iox_$attach_name ("terminal_report_output", opt.iocb,
		"vfile_ " || output_file, null, code);
	     if code ^= 0 then do;
		call ssu_$abort_line (sci_ptr, code, "Could not attach to ^a", output_file);
		call clean_up ();
	     end;
	     attached = "1"b;			/* output file is attached */
	     call iox_$open (opt.iocb, 2, ""b, code);
	     if code ^= 0 then do;
		call ssu_$abort_line (sci_ptr, code, "Could not open file ^a", output_file);
		call iox_$detach_iocb (opt.iocb, code);
		call clean_up ();
	     end;
	     opened = "1"b;				/* output file is opened */
	end;

	if opt.reader_procedure = "" then do;
	     call log_read_$open (">sc1>as_logs", "log", log_read_ptr, code);
	end;					/* get ptr to log segment */
	if code ^= 0 then 
	     call ssu_$abort_line (sci_ptr, code, "Cannot open log");

	call log_limit_scan_ (sci_ptr, addr(opt.limit), "0"b, log_read_ptr);
						/* determine where to start & stop in log scanning */
	log_message_ptr = opt.first_msg;
	first_msg_count, ansb_msg_count, index_count = 0;
						/* initialize */

	call get_temp_segments_ ("terminal_report", temp_ptrs, code);
	if code ^= 0 then do;
	     call com_err_ (code, "terminal_report", "Error opening temporary segment.");
	     call clean_up ();
	end;
	temp_ptr = temp_ptrs (1);
	temp_as_ptr = temp_ptrs (2);
	temp_two_ptr = temp_ptrs (3);
	ttp = temp_ptrs (4);
	ttp_tot_ptr = temp_ptrs (5);

	on condition (out_of_bounds)
	     call oob ();				/* it's possible we will fill a temp segment past 255K */

	call system_info_$titles (coxx, dpxx, cods, dpds);
						/* Report banner stuff */
	call ioa_$ioa_switch (opt.iocb, "^a^/^a^/", cods, dpds);
	if opt.first_msg = null () then
	     call ioa_$ioa_switch (opt.iocb, "Terminal report to ^a^3/", 
	     log_format_time_ ((opt.last_msg -> log_message.time)));
	else if opt.last_msg = null () then
	     call ioa_$ioa_switch (opt.iocb, "Terminal report from ^a^3/", 
	     log_format_time_ ((opt.first_msg -> log_message.time)));
	else call ioa_$ioa_switch (opt.iocb, "Terminal report from ^a to ^a^3/", 
	     log_format_time_ ((opt.first_msg -> log_message.time)),
	     log_format_time_ ((opt.last_msg -> log_message.time)));

scan_log: 
	do while (log_message_ptr ^= null ());
	     if log_match_$test (opt.lmd_ptr, log_message_ptr, "") then do;
						/* find log message containing info we want, based on match data */
		audit_record_ptr = addr (log_message.data (1));
		audit_record_size = dimension (log_message.data, 1);
		info_ptr = audit_record_ptr;
		info_size = audit_record_size;
		info_size = info_size - size (audit_record_header);
		info_ptr = addrel (info_ptr, size (audit_record_header));
						/* ptr to expanded data */
		if info_size > 0 & audit_record_header.subject.tag = "a"
		     & audit_record_header.subject.process_id = ""b then do;
						/* interactive only */
		     if looking_for ^= "" then do;
			if usersw then do;
			     if audit_record_header.subject.person ^= choosen_name then goto Next;
			end;
			else do;
			     if rtrim(info_ptr -> as_ia_audit_record_.terminal_type)
				^= rtrim(looking_for) then goto Next;
			end;			/* skip message if TTP match not found when -match was given */
		     end;
		     first_msg_count = first_msg_count + 1;
						/* increment valid message count */
		     temp.ttp (first_msg_count) = info_ptr -> as_ia_audit_record_.terminal_type;
		     temp.name (first_msg_count) = audit_record_header.subject.person;
		     temp.chn (first_msg_count) = info_ptr -> as_ia_audit_record_.channel;
		     temp.ansb (first_msg_count) = info_ptr -> as_ia_audit_record_.answerback;
		     temp_as.ansb (first_msg_count) = info_ptr -> as_ia_audit_record_.answerback;
		     temp.time (first_msg_count) = log_message.time;
		     temp.cpu (first_msg_count), temp.connect (first_msg_count) = "";
						/* fill in temp array data */
		     if index (log_message.text, "DENIED") ^= 0 then do;
						/* if this is a "LOGIN DENIED" message */
			temp.failed (first_msg_count) = "1"b;
			failsw = "1"b;
			call add_ttp_data ();
			failsw = ""b;
			first_msg_count = first_msg_count - 1;
			goto Next;
		     end;
		     else do;
			temp.failed (first_msg_count) = ""b;
			call add_ttp_data ();
		     end;
		     temp.logins (first_msg_count) = 1;
		     if ^mtsw then do;
			call check_for_dups (MCH);
			if MCH then first_msg_count = first_msg_count - 1;
			goto Next;
		     end;
		     NAME = rtrim(temp.name (first_msg_count));
		     CHN = rtrim(temp.chn (first_msg_count));
		     TIME = temp.time (first_msg_count);
		     auto_log_read_ptr = log_read_ptr;
		     auto_log_message_ptr = log_message_ptr;
		     call scan_LOGOUTS (NAME, CHN, TIME);
						/* called only for looking up cpu & connect data */
		     log_message_ptr = auto_log_message_ptr;
		     log_read_ptr = auto_log_read_ptr;
		end;
               end;

Next:
	     call log_read_$next_message (log_read_ptr, log_message_ptr, code);
	     if code = error_table_$no_log_message then log_message_ptr = null ();
						/* find next log message */
	     if log_message_ptr = opt.last_msg then goto sort_em;
	     else goto scan_log;
	end;

sort_em:						/* sort items */

	vptr = pointer (temp_ptr, currentsize (temp));
	vptr_ansb = pointer (temp_as_ptr, currentsize (temp_as));
	vptr_two = pointer (ttp_tot_ptr, currentsize (ttp_tot));

	V.n = first_msg_count;
	V_thr.n_thr = first_msg_count;

	do inx = 1 to V.n;
	     V.vector (inx) = addr (temp_ptr -> temp.data (inx));
	end;

	do inx = 1 to V_thr.n_thr;
	     V_thr.vector_thr (inx) = addr (temp_as_ptr -> temp_as.ansbs (inx));
	end;

	V_two.n_two = ttx;
	do inx = 1 to V_two.n_two;
	     V_two.vector_two (inx) = addr (ttp_tot_ptr -> ttp_tot.tot_data (inx));
	end;
	if V.n > 1 then call sort_items_$varying_char (vptr);
	if V_two.n_two > 1 then call sort_items_$varying_char (vptr_two);
	if V_thr.n_thr > 1 then call sort_items_$varying_char (vptr_ansb);

	if mtsw then call ioa_$ioa_switch (opt.iocb, 
	     "Terminal usage sorted by type:^50t(*) = Still active^2/");
	else call ioa_$ioa_switch (opt.iocb, 
	     "Terminal usage sorted by type:^2/");
	if mtsw then call ioa_$ioa_switch (opt.iocb, 
	     "Type^36tLogins^50tNologins^62tCpu^70tConnect^/");
	else call ioa_$ioa_switch (opt.iocb, "Type^36tLogins^50tNologins^/");
	if mtsw then do;
	     ttp_meters, final_tab = "1"b;
	end;
	do inx = 1 to ttx;
	     tot_logi, tot_logo = 0;
	     tot_cpu, tot_connect = "";
	     do inxx = 1 to V_two.vector_two (inx) -> ttp_tot_data.ascnt;
		tot_logi = tot_logi + V_two.vector_two (inx) 
		     -> ttp_tot_data.ansbks.login (inxx);
		tot_logo = tot_logo + V_two.vector_two (inx) 
		     -> ttp_tot_data.ansbks.fails (inxx);
		if mtsw then do;
		     add_cpus = "1"b;
		     if tot_cpu = "" then tot_cpu = "000:00";
		     call add_common_times ();
		     add_cpus = ""b;
		     if tot_connect = "" then tot_connect = "00000:00";
		     call add_common_times ();
		end;
	     end;
						/* add up number of logins and failed logins */

	     if mtsw then call ioa_$ioa_switch (opt.iocb, "^a^36t^5d^50t^5d^60t^a^70t^a", 
		V_two.vector_two (inx) -> ttp_tot_data.type, tot_logi, tot_logo, tot_cpu, tot_connect);
	     else call ioa_$ioa_switch (opt.iocb, "^a^36t^5d^50t^5d", 
		V_two.vector_two (inx) -> ttp_tot_data.type, tot_logi, tot_logo);
	end;
	if ttp_meters then ttp_meters, final_tab = ""b;

	if mtsw then call ioa_$ioa_switch (opt.iocb, 
	     "^3/Terminal usage sorted by Answerback:^50t(*) = Still active^2/");
	else call ioa_$ioa_switch (opt.iocb, 
	     "^3/Terminal usage sorted by Answerback:^2/");
	if mtsw then call ioa_$ioa_switch (opt.iocb, 
	     "Ansbk^8tType^38tLogins^52tNologins^64tCpu^72tConnect");
	else call ioa_$ioa_switch (opt.iocb, 
	     "Ansbk^8tType^38tLogins^52tNologins");
	call ioa_$ioa_switch (opt.iocb, "^10tUser");
	call output_data ();

	call clean_up;
	return;

						/* procedure for determining cpu times */
get_cpu_time:
	proc ();

	datax = index (temp_two.text (1), "$") - 7;
	cpu_data = substr (temp_two.text (1), datax, 6);
	temp.cpu (first_msg_count) = cpu_data;
	call get_connect_time ();
	ttp_meters = "1"b;
	call add_ttp_data ();
	ttp_meters = ""b;
	return;

     end get_cpu_time;

	
check_for_dups:					/* procedure to add cpu times up if user 
	     & ttp are listed in our temp array more than once */
          proc (match_made);

dcl match_made bit (1) aligned parameter;

	if first_msg_count < 2 then return;
	match_made = ""b;
	do inx = 1 to first_msg_count-1;
	     if rtrim(temp.ttp (inx)) = rtrim(temp.ttp (first_msg_count)) & 
		rtrim(temp.name (inx)) = rtrim(temp.name (first_msg_count)) &
		rtrim(temp.ansb (inx)) = rtrim(temp.ansb (first_msg_count)) then do;
		temp.logins (inx) = temp.logins (inx) + 1;
		if ^mtsw then do;
		     match_made = "1"b;
		     return;
		end;
		if index (temp.cpu (inx), ":") ^= 0 &
		     rtrim(temp.cpu (first_msg_count)) = "" then 
		     temp.cpu (inx) = rtrim(temp.cpu (inx)) || " (*)";
		else if index (temp.cpu (first_msg_count), ":") ^= 0 &
		     rtrim(temp.cpu (inx)) = "" then 
		     temp.cpu (inx) = rtrim(temp.cpu (first_msg_count)) || " (*)";
		else if index (temp.cpu (inx), ":") ^= 0 then do;
		     add_cpus = "1"b;     
		     call add_common_times ();
		     add_cpus = ""b;
		     call add_common_times ();
		end;
		match_made = "1"b;			/* match was found */
		return;
	     end;
	end;
	return;
	
     end check_for_dups;


get_connect_time:					/* procedure to determine connect times */
          proc ();

dcl date_time_$from_clock_interval entry (fixed bin(71), fixed bin(71), ptr, fixed bin(35));
dcl 1 to aligned like time_offset;
dcl 1 toa aligned like time_offset_array;
dcl (time_one, time_two) fixed bin (71);
dcl (ihour, imin, isec) fixed bin;
dcl connect_time char (8);

	to.version, toa.version = Vtime_offset_2;
	toa.flag (1) = UNUSED;
	toa.flag (2) = UNUSED;
	toa.flag (3) = UNUSED;
	toa.flag (4) = UNUSED;
	toa.flag (5) = INTEGER;
	toa.flag (6) = INTEGER;
	toa.flag (7) = INTEGER;
	toa.flag (8) = UNUSED;
	time_one = temp_two.time (1);
	time_two = temp.time (first_msg_count);
	call date_time_$from_clock_interval (time_two, time_one, addr(toa), code);
	ihour = toa.val (5) + .0;
	imin = toa.val (6) + .0;
	isec = toa.val (7) + .0;
	imin = imin + ihour*60;
	call ioa_$rsnnl ("^5d:^2d", connect_time, len, imin, isec);
	temp.connect (first_msg_count) = connect_time;
	
	return;
     end get_connect_time;
	

add_common_times:					/* procedure to add cpu/connect times for common ttps/users */
          proc ();

dcl (common_temp, common_tempx) char (8);
dcl (sub_one_one, sub_one_two, sub_two_one, sub_two_two,
	common_min_char, common_sec_char) char (5);
dcl (common_one_one, common_one_two, common_two_one, common_two_two,
	common_min, common_sec) fixed bin;

	if ttp_meters then do;
	     if add_cpus then do;
		if final_tab then do;
		     common_temp = rtrim(V_two.vector_two (inx) -> 
			ttp_tot_data.ansbks.cpu (inxx));
		     common_tempx = rtrim(tot_cpu);
		end;
		else do;
		     common_temp = rtrim(temp.cpu (first_msg_count));
		     common_tempx = rtrim(tot_cpu);
		end;
	     end;
	     else do;
		if final_tab then do;
		     common_temp = rtrim(V_two.vector_two (inx) ->
			ttp_tot_data.ansbks.connect (inxx));
		     common_tempx = rtrim(tot_connect);
		end;
		else do;
		     common_temp = rtrim(temp.connect (first_msg_count));
		     common_tempx = rtrim(tot_connect);
		end;
	     end;
	end;

	else do;
	     if add_cpus then do;
		common_temp = rtrim(temp.cpu (inx));
		common_tempx = rtrim(temp.cpu (first_msg_count));
	     end;
	     else do;
		common_temp = rtrim(temp.connect (inx));
		common_tempx = rtrim(temp.connect (first_msg_count));
	     end;
	end;

	if add_cpus then do;
	     sub_one_one = substr (common_temp, 1, 3);
	     sub_one_two = substr (common_temp, 5, 2);
	     sub_two_one = substr (common_tempx, 1, 3);
	     sub_two_two = substr (common_tempx, 5, 2);
	end;
	else do;
	     sub_one_one = substr (common_temp, 1, 5);
	     sub_one_two = substr (common_temp, 7, 2);
	     sub_two_one = substr (common_tempx, 1, 5);
	     sub_two_two = substr (common_tempx, 7, 2);
	end;
	
	common_one_one = cv_dec_check_ (rtrim(ltrim(sub_one_one)), code);
	common_one_two = cv_dec_check_ (rtrim(sub_one_two), code);
	common_two_one = cv_dec_check_ (rtrim(ltrim(sub_two_one)), code);
	common_two_two = cv_dec_check_ (rtrim(sub_two_two), code);
	
	common_min = common_one_one + common_two_one;
	common_sec = common_one_two + common_two_two;
	if common_sec > 59 then do;
	     common_min = common_min + 1;
	     common_sec = common_sec - 60;
	end;
	
	if add_cpus then call ioa_$rsnnl ("^3d", common_min_char, len, common_min);
	else call ioa_$rsnnl ("^5d", common_min_char, len, common_min);
	call ioa_$rsnnl ("^2d", common_sec_char, len, common_sec);
	if ttp_meters then do;
	     if add_cpus then tot_cpu = rtrim(common_min_char) || ":" || rtrim(common_sec_char);
	     else tot_connect = rtrim(common_min_char) || ":" || rtrim(common_sec_char);
	     return;
	end;
	if add_cpus then temp.cpu (inx) = rtrim(common_min_char) || ":" || rtrim(common_sec_char);
	else temp.connect (inx) = rtrim(common_min_char) || ":" || rtrim(common_sec_char);
	return;
     end add_common_times;



scan_LOGOUTS:
          proc (login_name, chan_name, login_time);	/* procedure that scans the logs finding "LOGOUT" messages
	     that correspond to "LOGIN" messages for determining cpu & connect time usage */

dcl login_name char(22) parameter;
dcl chan_name char(32) parameter;
dcl login_time fixed bin (71) parameter;
dcl msg_count fixed bin (35);

	msg_count = 0;
	log_message_ptr = opt.first_msg;		/* start with first message again */
	call log_match_$clear_text_strings (opt.lmd_ptr);
	call log_match_$add_match (opt.lmd_ptr, "LOGOUT");
						/* change the match string from LOGIN to LOGOUT */
	do while (log_message_ptr ^= null ());
	     if log_match_$test (opt.lmd_ptr, log_message_ptr, "") then do;
		msg_count = msg_count + 1;
		audit_record_ptr = addr (log_message.data (1));
		audit_record_size = dimension (log_message.data, 1);
		info_ptr = audit_record_ptr;
		info_size = audit_record_size;
		info_size = info_size - size (audit_record_header);
		info_ptr = addrel (info_ptr, size (audit_record_header));
		if index (log_message.text, "disconnect") = 0 then do;	
		     if index (log_message.text, rtrim(login_name)) ^= 0 &
			index (log_message.text, rtrim(chan_name)) ^= 0 &
			log_message.time > login_time then do;
			if index_count > 0 then do inx = 1 to index_count;
			     if msg_count = temp_thr.index (inx) then goto skip_msg_count;
			end;
			temp_two.text (1) = log_message.text;
			temp_two.time (1) = log_message.time;
			index_count = index_count + 1;
			temp_thr.index (index_count) = msg_count;
			call get_cpu_time ();
			goto setup;
		     end;
		end;
               end;
skip_msg_count:
	     
	     call log_read_$next_message (log_read_ptr, log_message_ptr, code);
						/* goto next log message */
	     if log_message_ptr = opt.last_msg then do;
		temp.cpu (first_msg_count) = "";
		temp.connect (first_msg_count) = "";
		goto setup;
	     end;
	     if code = error_table_$no_log_message then log_message_ptr = null ();
	end;

setup:	call check_for_dups (MCH);
	if MCH then first_msg_count = first_msg_count - 1;
	call log_match_$clear_text_strings (opt.lmd_ptr);
	call log_match_$add_match (opt.lmd_ptr, "LOGIN");
						/* change the match string back to LOGIN before returning
		to original log scan */
	return;

     end scan_LOGOUTS;
     

add_ttp_data:
          proc ();					/* procedure for adding up & sorting different answerbacks
	     per different ttps */

	if ttx = 0 then do;
	     ttx = ttx + 1;
	     ttp_tot.type (ttx) = temp.ttp (first_msg_count);
	     ttp_tot.ascnt (ttx) = 1;
	     ttp_tot.ansbks (ttx).ansbk (1) = temp.ansb (first_msg_count);
	     if failsw then ttp_tot.ansbks (ttx).fails (1) = 1;
     	     else ttp_tot.ansbks (ttx).login (1) = 1;
	     ttp_tot.ansbks (ttx).cpu (1) = "  0: 0";
	     ttp_tot.ansbks (ttx).connect (1) = "    0: 0";
	end;
	else do;
	     do inx = 1 to ttx;
		if temp.ttp (first_msg_count) = ttp_tot.type (inx) then do;
		     do ttxx = 1 to ttp_tot.ascnt (inx);
			if ttp_tot.ansbks (inx).ansbk (ttxx) = 
			     temp.ansb (first_msg_count) then do;
			     if ttp_meters then do;
				add_cpus = "1"b;
				if tot_cpu = "" then tot_cpu = "000:00";
				else tot_cpu = ttp_tot.ansbks (inx).cpu (ttxx);
				call add_common_times ();
				add_cpus = ""b;
				ttp_tot.ansbks (inx).cpu (ttxx) = 
				     tot_cpu;
				if tot_connect = "" then tot_connect = "00000:00";
				else tot_connect = ttp_tot.ansbks (inx).connect (ttxx);
				call add_common_times ();
				ttp_tot.ansbks (inx).connect (ttxx) = 
				     tot_connect;
			     end;
			     else if failsw then ttp_tot.ansbks (inx).fails (ttxx) = 
				ttp_tot.ansbks (inx).fails (ttxx) + 1;
			     else ttp_tot.ansbks (inx).login (ttxx) = 
				ttp_tot.ansbks (inx).login (ttxx) + 1;
			     return;
			end;
		     end;
		     ttp_tot.ascnt (inx) = ttp_tot.ascnt (inx) + 1;
		     ttp_tot.ansbks (inx).ansbk (ttp_tot.ascnt (inx)) = 
			temp.ansb (first_msg_count);
		     ttp_tot.ansbks (inx).cpu (ttp_tot.ascnt (inx)) = "  0: 0";
		     ttp_tot.ansbks (inx).connect (ttp_tot.ascnt (inx)) = "    0: 0";
		     if failsw then ttp_tot.ansbks (inx).fails (ttp_tot.ascnt (inx)) = 
			ttp_tot.ansbks (inx).fails (ttp_tot.ascnt (inx)) + 1;
		     else ttp_tot.ansbks (inx).login (ttp_tot.ascnt (inx)) = 
			ttp_tot.ansbks (inx).login (ttp_tot.ascnt (inx)) + 1;
		     return;
		end;
	     end;
	     ttx = ttx + 1;
	     ttp_tot.ascnt (ttx) = 1;
	     ttp_tot.type (ttx) = temp.ttp (first_msg_count);
	     ttp_tot.ansbks (ttx).ansbk (ttp_tot.ascnt (ttx)) = 
		temp.ansb (first_msg_count);
	     ttp_tot.ansbks (ttx).cpu (ttp_tot.ascnt (ttx)) = "  0: 0";
	     ttp_tot.ansbks (ttx).connect (ttp_tot.ascnt (ttx)) = "    0: 0";
	     if failsw then ttp_tot.ansbks (ttx).fails (ttp_tot.ascnt (ttx)) = 1;
	     else ttp_tot.ansbks (ttx).login (ttp_tot.ascnt (ttx)) = 1;
	end;
	return;
     end add_ttp_data;
	     

output_data:
          proc ();					/* display results to user_output or output file */

dcl (inxxx, inxxxx) fixed bin;
dcl atype char (36) varying;

	ttype, atype = "";
	
	do inx = 1 to V_thr.n_thr;
	     if  V_thr.vector_thr (inx) -> temporary_ansb.ansb ^= atype then do;
		atype = V_thr.vector_thr (inx) -> temporary_ansb.ansb;
	     end;
	     else goto skip_call;
	     do inxx = 1 to V_two.n_two;
		do inxxx = 1 to V.n;
		     if V.vector (inxxx) -> temporary.ttp = 
			V_two.vector_two (inxx) -> ttp_tot_data.type & V.vector (inxxx) -> temporary.ansb = 
			V_thr.vector_thr (inx) -> temporary_ansb.ansb then do;
			if ttype ^= V_thr.vector_thr (inx) -> temporary_ansb.ansb 
			     || "   " || V_two.vector_two (inxx) -> ttp_tot_data.type then do;
			     ttype = V_thr.vector_thr (inx) -> temporary_ansb.ansb 
				|| "   " || V_two.vector_two (inxx) -> ttp_tot_data.type;
			     tot_logi, tot_logo = 0;
			     do inxxxx = 1 to V_two.vector_two (inxx) -> ttp_tot_data.ascnt;
				if V_two.vector_two (inxx) -> ttp_tot_data.ansbk (inxxxx) = 
				     V_thr.vector_thr (inx) -> temporary_ansb.ansb then do;
				     tot_logi = tot_logi + V_two.vector_two (inxx) 
					-> ttp_tot_data.ansbks.login (inxxxx);
				     tot_logo = tot_logo + V_two.vector_two (inxx) 
					-> ttp_tot_data.ansbks.fails (inxxxx);
				     if mtsw then do;
					tot_cpu = V_two.vector_two (inxx)
					-> ttp_tot_data.ansbks.cpu (inxxxx);
					tot_connect = V_two.vector_two (inxx)
					-> ttp_tot_data.ansbks.connect (inxxxx);
				     end;
				end;
			     end;
			     if mtsw then call ioa_$ioa_switch (opt.iocb, "^/^a^38t^5d^52t^5d^62t^a^72t^a", 
				ttype, tot_logi, tot_logo, tot_cpu, tot_connect);
			     else call ioa_$ioa_switch (opt.iocb, "^/^a^38t^5d^52t^5d", 
				ttype, tot_logi, tot_logo);
			end;
			if mtsw then do;
			     if index (V.vector (inxxx) -> temporary.cpu, ":") = 0 then
			     V.vector (inxxx) -> temporary.cpu = "  (*)";
			call ioa_$ioa_switch (opt.iocb, "^10t^a^38t^5d^62t^a^72t^a", 
			     V.vector (inxxx) -> temporary.name,
			     V.vector (inxxx) -> temporary.logins,
			     V.vector (inxxx) -> temporary.cpu,
			     V.vector (inxxx) -> temporary.connect);
                   	          end;
			else do;
			     call ioa_$ioa_switch (opt.iocb, "^10t^a^38t^5d",
				V.vector (inxxx) -> temporary.name,
				V.vector (inxxx) -> temporary.logins);
			end;
		     end;
		end;
	     end;
skip_call:     
	end;
	return;
     end output_data;


oob:      proc ();
	call ioa_$ioa_switch (opt.iocb, "Cannot continue... Out_of_bounds condition detected.");
	call clean_up ();
     end oob;
     

	
clean_up:	proc ();
	if log_read_ptr ^= null () then
	     call log_read_$close (log_read_ptr, (0));
	if opt.lmd_ptr ^= null () then
	     call log_match_$free (opt.lmd_ptr);
	if temp_ptrs (1) ^= null () then
	     call release_temp_segments_ ("terminal_report", temp_ptrs, code);
	if opened then do;
	     call iox_$close (opt.iocb, code);
	     if code ^= 0 then do;
		call ssu_$abort_line (sci_ptr, code, "Could not close file ^a", output_file);
	     end;
	     opened = ""b;
	end;
	if attached then do;
	     call iox_$detach_iocb (opt.iocb, code);
	     if code ^= 0 then do;
		call ssu_$abort_line (sci_ptr, code, "Could not detach file ^a", output_file);
	     end;
	     attached = ""b;
	end;
	if sci_ptr ^= null () then
	     call ssu_$destroy_invocation (sci_ptr);

	goto exit;
     end clean_up;

     
exit:	return;
	

process_arguments:
          proc ();					/* validate arguments */
	
dcl arg char (argl) based (argp);
dcl (argn, nargs) fixed bin;
dcl argl fixed bin (21);
dcl argp ptr;
dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	
	call ssu_$arg_count (sci_ptr, nargs);

	looking_for = "";
	do argn = 1 to nargs;
	     call ssu_$arg_ptr (sci_ptr, argn, argp, argl);
	     if arg = "-from" | arg = "-fm" then 
		call get_next_arg (opt.limit.from_opt);
	     else if arg = "-to" then call get_next_arg (opt.limit.to_opt);
	     else if arg = "-for" then call get_next_arg (opt.limit.for_opt);
	     else if arg = "-last" | arg = "-lt" then 
		call get_next_arg (opt.limit.last_opt);
	     else if arg = "-output_file" | arg = "-of" then do;
		call get_next_arg (output_file);
		if code ^= 0 then output_file = "terminal_report_output";
		else output_file = arg;
	     end;
	     else if arg = "-no_output_file" | arg = "-nof" then output_file = "";
	     else if arg = "-terminal_type" | arg = "-ttp" then do;
		call get_next_arg (looking_for);
		call process_looking_for ();
		ttpsw = "1"b;
	     end;
	     else if arg = "-all_terminal_types" | arg = "-att" then do;
		looking_for = "";
		ttpsw = "0"b;
	     end;
	     else if arg = "-user" then do;
		call get_next_arg (looking_for);     
		call process_looking_for ();
		choosen_name = looking_for;
		usersw = "1"b;
	     end;
	     else if arg = "-all_users" | arg = "-au" then do;
		looking_for = "";
		usersw = "0"b;
	     end;
	     else if arg = "-meters" | arg = "-mt" then mtsw = "1"b;
	     else if arg = "-nometers" | arg = "-nmt" then mtsw = ""b;
	     else if substr (arg, 1, 1) = "-" then do;
		call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a", arg);
		call clean_up ();
	     end;
	     else call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^a", arg);
	end;
	call check_options ();
	return;
	

process_looking_for:
	proc ();					/* procedure for validating -match or -ttp strings */

	if substr (arg, 1, 1) = "/" & substr (arg, argl, 1) ^= "/" then do;
INVALID_ERROR:
	          call ssu_$abort_line (sci_ptr, error_table_$bad_arg,
		"Invalid regular expression ""^a""", arg);
		call clean_up ();
	     end;
	     else if substr (arg, argl, 1) = "/" & substr (arg, 1, 1) ^= "/" then
		goto INVALID_ERROR;
	     else if arg = "/" then goto INVALID_ERROR;
	     return;
     end process_looking_for;


get_next_arg:
          proc (option);

dcl option char (*) varying parameter;
	
	argn = argn + 1;
	call cu_$arg_ptr (argn, argp, argl, code);
	option = arg;
	return;
     end get_next_arg;
     
check_options:
          proc ();					/* procedure for determining what date/time to start & stop
	     log scanning */
	
dcl temp_number fixed bin;
dcl (from_time, to_time) fixed bin(71);
dcl exchange_opt char (50) varying;

	if opt.limit.from_opt ^= "" & opt.limit.to_opt ^= "" then do;
	     temp_number = cv_dec_check_ ((opt.limit.from_opt), code);
	     if code ^= 0 then do;
		temp_number = cv_dec_check_ ((opt.limit.to_opt), code);
		if code ^= 0 then do;
		     call convert_date_to_binary_ ((opt.limit.from_opt), from_time, 0);
		     call convert_date_to_binary_ ((opt.limit.to_opt), to_time, 0);
		     if from_time > to_time then do;
			exchange_opt = opt.limit.from_opt;
			opt.limit.from_opt = opt.limit.to_opt;
			opt.limit.to_opt = exchange_opt;
		     end;
		end;
	     end;
	end;
	return;
     end check_options;
     end process_arguments;

     
ssu_abort:
	proc ();
	call clean_up ();
	return;
     end ssu_abort;
     

initialize_options:
	proc ();
	unspec (opt) = ""b;
	opt.pointers = null ();
	opt.lmd_ptr = null ();
	opt.limit.version = LOG_LIMIT_INFO_VERSION_1;
	opt.limit.to_opt = "";
	opt.limit.from_opt = "";
	opt.limit.for_opt = "";
	opt.log_pathname = "";
	opt.iocb = iox_$user_output;
	opt.reader_procedure = "";
/*	unspec (log_message) = ""b;*/
	output_file, tot_cpu, tot_connect = "";
	attached, opened, mtsw, failsw, ttp_meters, final_tab, usersw,
	     ttpsw = ""b;
	ttx = 0;
	unspec (ttp_tot) = ""b;
	return;
     end initialize_options;
     


%include log_limit_info;
%include as_audit_structures;
%include log_message;
%include user_attributes;
%include access_audit_bin_header;
%include time_offset;


/* Builtins */

dcl (index, substr, addr, addrel, currentsize, ltrim, rtrim,
     null, pointer, unspec, dimension, size) builtin;


/* Automatic */

dcl 1 opt automatic,				/* structure required by the system log subroutines */
      2 log_pathname char (168),
      2 pointers,
        3 expand_select_ptr ptr,
        3 lmd_ptr ptr,
      2 limit aligned like log_limit_info,
      2 reader_procedure char (32) varying,
      2 iocb ptr,
      2 flags aligned,
        3 debug_sw bit (1),
        3 dm_system_log_sw bit (1),
        3 reverse_sw bit (1),
        3 from_sw bit (1),
        3 to_sw bit (1),
        3 for_sw bit (1),
        3 last_sw bit (1),
        3 expand_sw bit (1),
        3 octal_sw bit (1),
        3 interpret_sw bit (1),
        3 log_path_sw bit (1),
        3 no_header_sw bit (1),
        3 limit_sw bit (1),
        3 process_id_sw bit (1),
        3 data_class_sw bit (1);

dcl 1 ttp_tot (ttx) aligned based (ttp_tot_ptr),
      2 tot_data like ttp_tot_data;
						/* ttp & ansback data */
dcl 1 ttp_tot_data aligned based,			/* above data sorted */
      2 type char(32) varying,
      2 ascnt fixed bin,
      2 ansbks (1000),
        3 ansbk char(4),
        3 login fixed bin(35),
        3 fails fixed bin(35),
        3 connect char(8),
        3 cpu char(6);

dcl 1 temp_as (first_msg_count) aligned based (temp_as_ptr),
      2 ansbs like temporary_ansb;			/* ansback data */
dcl 1 temporary_ansb aligned based,
      2 ansb char (4) varying;			/* above data sorted */

dcl 1 temporary aligned based,			/* terminal data */
      2 name char (22) varying,
      2 ttp char(32),
      2 ansb char(4),
      2 chn char(32),
      2 time fixed bin(71),
      2 logins fixed bin(35),
      2 failed bit (1) aligned,
      2 connect char(8),
      2 cpu char(10);

dcl 1 temp (first_msg_count) aligned based (temp_ptr),
      2 data like temporary;				/* above data sorted */

dcl 1 temp_two (1) aligned based (temp_two_ptr),
      2 text char(128) varying,			/* LOGOUT data */
      2 time fixed bin(71);

dcl 1 temp_thr (index_count) aligned based (ttp),
      2 index fixed bin (35);				/* array of LOGOUT messages already seen and matched */

dcl 1 V aligned based (vptr),
      2 n fixed bin(18),
      2 vector (n) ptr unaligned;
dcl 1 V_two aligned based (vptr_two),
      2 n_two fixed bin(18),
      2 vector_two (n_two) ptr unaligned;
dcl 1 V_thr aligned based (vptr_ansb),
      2 n_thr fixed bin(18),
      2 vector_thr (n_thr) ptr unaligned;

dcl (info_size, audit_record_size, ttx, ttxx, inx, inxx, datax, tot_logi,
          tot_logo) fixed bin;
dcl tot_connect char (8);
dcl tot_cpu char (6);
dcl choosen_name char (22) varying;
dcl looking_for char (32) varying;
dcl CHN char (32);
dcl NAME char (22);
dcl (cods, dpds) char (120) aligned;
dcl (coxx, dpxx) char (4) aligned;
dcl cpu_data char (9);
dcl output_file char (168) varying;
dcl ttype char (32);
dcl (code, index_count) fixed bin (35);
dcl (attached, opened, add_cpus) bit (1);
dcl (failsw, ttp_meters, final_tab, MCH, mtsw, usersw, ttpsw) bit (1) aligned;
dcl TIME fixed bin (71);
dcl len fixed bin (21);
dcl (first_msg_count, ansb_msg_count) fixed bin (35);


/* External entries */

dcl log_read_$open entry (char (*), char (*), ptr, fixed bin (35));
dcl log_read_$close entry (ptr, fixed bin (35));
dcl log_read_$next_message entry (ptr, ptr, fixed bin (35));
dcl log_match_$add_match entry (ptr, char (*));
dcl log_match_$free entry (ptr);
dcl log_match_$test entry (ptr, ptr, char (*) varying) returns (bit (1) aligned);
dcl log_match_$clear_text_strings entry (ptr);
dcl log_limit_scan_ entry (ptr, ptr, bit (1) aligned, ptr);
dcl log_format_time_ entry (fixed bin (71)) returns (char (32) varying);
dcl (ioa_$ioa_switch, ioa_$rsnnl, com_err_) entry options (variable);
dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35));
dcl system_info_$titles entry (char (*) aligned, char (*) aligned,
          char (*) aligned, char (*) aligned);
dcl sort_items_$varying_char entry (ptr);
dcl (get_temp_segments_, release_temp_segments_) entry (char (*), (*) ptr,
          fixed bin (35));
dcl ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry,
          fixed bin (35));
dcl ssu_$destroy_invocation entry (ptr);
dcl ssu_$abort_line entry options (variable);
dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21));
dcl ssu_$arg_list_ptr entry returns (ptr);
dcl ssu_$arg_count entry (ptr, fixed bin);
dcl cu_$arg_list_ptr entry returns (ptr);
dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35));
dcl iox_$open entry (ptr, fixed bin, bit (*), fixed bin (35));
dcl iox_$detach_iocb entry (ptr, fixed bin (35));
dcl iox_$close entry (ptr, fixed bin (35));


/* Pointers */

dcl (log_read_ptr, temp_as_ptr, temp_ptrs (5), auto_log_read_ptr,
          auto_log_message_ptr, sci_ptr, temp_ptr, temp_two_ptr, ttp_tot_ptr,
          ttp, vptr, vptr_two, vptr_ansb, info_ptr) ptr;
dcl iox_$user_output ptr ext static;


/* conditions */

dcl (out_of_bounds, cleanup) condition;


/* error messages */

dcl (error_table_$no_log_message, error_table_$badopt, error_table_$bad_arg,
          error_table_$inconsistent) fixed bin (35) ext static;

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