



		    change_tuning_parameters.pl1    11/15/82  1908.1rew 11/15/82  1453.7       84834



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


change_tuning_parameters:
change_tuning_parameter:
ctp:

	procedure () options (variable);

/* Completely rewritten, for hc_tune, 27 June 1981, W. Olin Sibert */

dcl  argno fixed bin;
dcl  nargs fixed bin;
dcl  al fixed bin (21);
dcl  ap pointer;
dcl  arg char (al) based (ap);
dcl  code fixed bin (35);

dcl  tp_type fixed bin;
dcl  tp_value bit (36) aligned;
dcl  tp_name char (32);

dcl  have_name bit (1) aligned;
dcl  silent_sw bit (1) aligned;
dcl  gate_name char (32);
dcl  set_entry variable entry (char (*), bit (36) aligned, bit (36) aligned, pointer, char (*), fixed bin (35));
dcl  requested_value char (64);
dcl  answer char (4) varying;

dcl  com_err_ entry options (variable);
dcl  command_query_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, pointer, fixed bin (21), fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  cv_float_ entry (char (*), fixed bin (35)) returns (float bin (27));
dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  metering_gate_$get_tuning_parameter entry
    (char (*), fixed bin, bit (36) aligned, pointer, char (*), char (*), fixed bin (35));
dcl  hphcs_$set_tuning_parameter entry
    (char (*), bit (36) aligned, bit (36) aligned, pointer, char (*), fixed bin (35));
dcl  initializer_gate_$set_tuning_parameter entry
    (char (*), bit (36) aligned, bit (36) aligned, pointer, char (*), fixed bin (35));

dcl  error_table_$badopt fixed bin (35) external static;
dcl  error_table_$noarg fixed bin (35) external static;
dcl  error_table_$odd_no_of_args fixed bin (35) external static;

dcl  WHOAMI char (32) internal static options (constant) init ("change_tuning_parameters");

dcl  linkage_error condition;

dcl (addr, bit, char, decimal, float, length, maxlength, null, round, rtrim, unspec) builtin;

/*  */

	call cu_$arg_count (nargs, code);
	if code ^= 0 then do;
	     call com_err_ (code, WHOAMI);
MAIN_RETURN:   return;
	     end;

	silent_sw = "0"b;
	have_name = "0"b;

	do argno = 1 to nargs;
	     call cu_$arg_ptr (argno, ap, al, (0));

	     if (arg = "-silent") then silent_sw = "1"b;

	     else if (char (arg, 1) = "-") then do;
		call com_err_ (error_table_$badopt, WHOAMI, "^a", arg);
		goto MAIN_RETURN;
		end;

	     else do;
		if argno = nargs then do;
		     call com_err_ (error_table_$odd_no_of_args, WHOAMI, "Value missing after ^a", arg);
		     goto MAIN_RETURN;
		     end;

		argno = argno + 1;			     /* Skip value argument */
		have_name = "1"b;
		end;
	     end;

	if ^have_name then do;
	     call com_err_ (error_table_$noarg, WHOAMI,
		"^/Usage:^-^a Name1 Value1 {... NameN ValueN} {-control_args}", WHOAMI);
	     goto MAIN_RETURN;
	     end;


/* Now, see if we have all the access we will need to accomplish this operation */

	if silent_sw then gate_name = "initializer_gate_"; /* Print the right name */
	else gate_name = "hphcs_";

	on condition (linkage_error) begin;
	     call com_err_ (0, WHOAMI, "This procedure requires access to metering_gate_ and ^a.", gate_name);
	     goto MAIN_RETURN;
	     end;

	if silent_sw then set_entry = initializer_gate_$set_tuning_parameter;
	else set_entry = hphcs_$set_tuning_parameter;

	call metering_gate_$get_tuning_parameter ("tefirst", (0), (""b), (null ()), (""), (""), (0));
						/* This call is just to see if we have access */
	revert condition (linkage_error);


/* Finally, loop through and make all the requested changes */

	do argno = 1 to nargs;
	     call cu_$arg_ptr (argno, ap, al, (0));
	     if char (arg, 1) = "-" then goto SKIP_THIS_ARGUMENT;

	     tp_name = arg;
	     call metering_gate_$get_tuning_parameter (tp_name, tp_type, tp_value, (null ()), tp_name, (""), code);
	     if code ^= 0 then do;
		call com_err_ (code, WHOAMI, "^a", arg);
		argno = argno + 1;			/* Skip over new value */
		goto SKIP_THIS_ARGUMENT;
		end;

	     argno = argno + 1;			/* This is guaranteed to work, tested above */
	     call cu_$arg_ptr (argno, ap, al, (0));
	     requested_value = arg;

	     call change ();			/* Convert the argument, and try to change */

SKIP_THIS_ARGUMENT:
	     end;

	return;					/* End of main procedure */

/*  */

change: procedure ();

/* This procedure sets the parameter to the new value, appropriately converted */

dcl  char_value char (4) aligned;
dcl  scaled_value fixed bin (35, 18);
dcl  binary_value fixed bin (35);
dcl  float_value float bin (27);

dcl  new_value bit (36) aligned;
dcl  new_char_value char (4) aligned;
dcl  new_scaled_value fixed bin (35, 18);
dcl  new_binary_value fixed bin (35);
dcl  new_float_value float bin (27);

dcl  error_message char (128);


	unspec (char_value) = tp_value;
	unspec (scaled_value) = tp_value;
	unspec (binary_value) = tp_value;
	unspec (float_value) = tp_value;

	if tp_type = TP_CHAR then do; 		/* First, try to convert to appropriate format */
	     if length (rtrim (requested_value)) > 4 then
		call bad_value ("four characters or less");
	     new_char_value = requested_value;
	     new_value = unspec (new_char_value);
	     end;

	else if tp_type = TP_INTEGER then do;
	     new_binary_value = cv_dec_check_ (requested_value, code);
	     if code ^= 0 then call bad_value ("a decimal integer");
	     new_value = unspec (new_binary_value);
	     end;

	else if tp_type = TP_SCALED_INTEGER then do;
	     new_scaled_value = cv_float_ (requested_value, code);
	     if code ^= 0 then call bad_value ("a scaled integer");
	     new_value = unspec (new_scaled_value);
	     end;

	else if tp_type = TP_MICROSECONDS then do;
	     new_binary_value = (0.5 + 1.0e6 * cv_float_ (requested_value, code));
	     if code ^= 0 then call bad_value ("a positive number of seconds");
	     if new_binary_value < 0 then call bad_value ("a positive number of seconds");
	     new_value = unspec (new_binary_value);
	     end;

	else if tp_type = TP_ON_OFF then do;
	     if requested_value = "on" then new_binary_value = 1;
	     else if requested_value = "off" then new_binary_value = 0;
	     else call bad_value ("either ""on"" or ""off""");
	     unspec (new_value) = unspec (new_binary_value);
	     end;

	else if tp_type = TP_FLOAT then do;
	     new_float_value = cv_float_ (requested_value, code);
	     if code ^= 0 then call bad_value ("a floating point number");
	     unspec (new_value) = unspec (new_float_value);
	     end;

	else do;
	     new_binary_value = cv_oct_check_ (requested_value, code);
	     if code ^= 0 then call bad_value ("an octal number");
	     new_value = unspec (new_binary_value);
	     end;

	unspec (new_char_value) = unspec (new_value);	/* Copy back just in case */
	unspec (new_scaled_value) = unspec (new_value);
	unspec (new_binary_value) = unspec (new_value);
	unspec (new_float_value) = unspec (new_value);

	query_info.yes_or_no_sw = "1"b;
	query_info.version = query_info_version_4;

	if tp_type = TP_CHAR then			/* Make discreet inquiry about the change */
	     call command_query_ (addr (query_info), answer, WHOAMI,
		"OK to change ^a from ""^4a"" to ""^4a""?",
		tp_name, char_value, new_char_value);

	else if tp_type = TP_INTEGER then
	     call command_query_ (addr (query_info), answer, WHOAMI,
		"OK to change ^a from ^d to ^d?",
		tp_name, binary_value, new_binary_value);

	else if tp_type = TP_SCALED_INTEGER then
	     call command_query_ (addr (query_info), answer, WHOAMI,
		"OK to change ^a from ^f to ^f?",
		tp_name, round (decimal (scaled_value), 4), round (decimal (new_scaled_value), 4));

	else if tp_type = TP_MICROSECONDS then
	     call command_query_ (addr (query_info), answer, WHOAMI,
		"OK to change ^a from ^f to ^f seconds?",
		tp_name, (float (binary_value) / 1.0e6), (float (new_binary_value) / 1.0e6));

	else if tp_type = TP_ON_OFF then
	     call command_query_ (addr (query_info), answer, WHOAMI,
		"OK to change ^a from ^[on^;off^] to ^[on^;off^] ?",
		tp_name, (binary_value ^= 0), (new_binary_value ^= 0));

	else if tp_type = TP_FLOAT then
	     call command_query_ (addr (query_info), answer, WHOAMI,
	     "OK to change ^a from ^f to ^f?",
	     tp_name, float_value, new_float_value);

	else call command_query_ (addr (query_info), answer, WHOAMI,
		"OK to change ^a from ^w to ^w?",
		tp_name, tp_value, new_value);

	if answer ^= "yes" then return;		/* Chickened out */

	call set_entry (tp_name, new_value, (""b), (null ()), error_message, code);

	if code ^= 0 then call com_err_ (code, WHOAMI,
	     "^/^3xCannot change ^a to ^a^[: Must be ^a.^]",
	     tp_name, requested_value, (error_message ^= ""), error_message);

	return;
	end change;

/*  */

bad_value: proc (P_error);

dcl  P_error char (*);

	call com_err_ (0, WHOAMI, "Value for ^a must be ^a, not ""^a"".", tp_name, P_error, requested_value);

	goto SKIP_THIS_ARGUMENT;

	end bad_value;

%page; %include tuning_parameter_info;
%page; %include query_info;

	end change_tuning_parameters;




		    check_sst_size.pl1              04/09/85  1511.1r w 04/08/85  1133.8       87507



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

/* format: ^inddcls,ind4,ifthenstmt,ifthendo,thendo,ifthen,tree,^case */

check_sst_size: proc;

        call cu_$arg_count (n_args, code);
        if code ^= 0 then go to REPORT_ERROR;

        do arg_no = 1 to n_args;

	  call cu_$arg_ptr (arg_no, argp, argl, code);
	  if code ^= 0 then go to REPORT_ERROR;

	  if expect_4k_value then do;
		expect_4k_value = "0"b;
		ctl_arg = "-4k";
		aste_entries (0) = cv_dec_check_ (arg, code);
		if code ^= 0 then go to REPORT_CV_ERROR;
		if aste_entries (0) < 1 then go to REPORT_VALUE_ERROR;
	      end;

	  else if expect_16k_value then do;
		     expect_16k_value = "0"b;
		     ctl_arg = "-16k";
		     aste_entries (1) = cv_dec_check_ (arg, code);
		     if code ^= 0 then go to REPORT_CV_ERROR;
		     if aste_entries (1) < 1 then go to REPORT_VALUE_ERROR;
		 end;

	       else if expect_64k_value then do;
			expect_64k_value = "0"b;
			ctl_arg = "-64k";
			aste_entries (2) = cv_dec_check_ (arg, code);
			if code ^= 0 then go to REPORT_CV_ERROR;
			if aste_entries (2) < 1 then go to REPORT_VALUE_ERROR;
		      end;

		  else if expect_256k_value then do;
			     expect_256k_value = "0"b;
			     ctl_arg = "-256k";
			     aste_entries (3) = cv_dec_check_ (arg, code);
			     if code ^= 0 then go to REPORT_CV_ERROR;
			     if aste_entries (3) < 1 then go to REPORT_VALUE_ERROR;
			 end;

		       else if expect_pn_value then do;
				ctl_arg = "-pn";
				if index (arg, "-") = 1 & ^accept_hyphen_path then do;
				        if arg = "-name" | arg = "-nm" then accept_hyphen_path = "1"b;
				        else go to REPORT_VALUE_ERROR;
				    end;
				else do;
				        expect_pn_value = "0"b;
				        accept_hyphen_path = "0"b;
				        call expand_pathname_ (arg, config_dir_name, config_ename, code);
				        if code ^= 0 then do;
					      call com_err_ (code, my_name,
						"^/Pathname expansion for config deck: ^a", arg);
					      return;
					  end;

				        have_path = "1"b;
				    end;
			      end;

			  else do;
				if arg = "-4k" then expect_4k_value = "1"b;
				else if arg = "-16k" then expect_16k_value = "1"b;
				     else if arg = "-64k" then expect_64k_value = "1"b;
					else if arg = "-256k" then expect_256k_value = "1"b;
					     else if arg = "-pathname" then expect_pn_value = "1"b;
						else if arg = "-pn" then expect_pn_value = "1"b;
						     else if index (arg, "-") = 1 then do;
							        code = error_table_$badopt;
							        go to REPORT_ARG_ERROR;
							    end;
							else do;
							        code = error_table_$bad_arg;
							        go to REPORT_ARG_ERROR;
							    end;
			      end;		/* ends ctl arg do */

        end;					/* ends arg do loop */

/* Check for missing arguments. */

        if expect_4k_value | expect_16k_value | expect_64k_value | expect_256k_value | expect_pn_value then do;
	      code = error_table_$noarg;
	      go to REPORT_ARG_ERROR;
	  end;

/* If any values were not supplied, find a config deck, and get them. */

        configp = null ();
        do i = 0 to hbound (aste_entries, 1);
	  if aste_entries (i) = 0 then do;
		if configp = null () then do;
		        on cleanup call clean_up ();

		        if have_path then do;
			      call initiate_file_ (config_dir_name, config_ename, R_ACCESS, configp, bitcnt, code);
			      if code ^= 0 then do;
				    call com_err_ (code, my_name,
				        "^/Cannot access config deck with pathname, ^a", pathname_ (config_dir_name, config_ename));
				    return;
				end;
			  end;
		        else do;
			      configp = addr (config_deck$);
			      call hcs_$status_mins (configp, stype, bitcnt, code);
			      if code ^= 0 then do;
				    call com_err_ (code, my_name, "^/Cannot get bit count of config deck.");
				    return;
				end;
			  end;

		        config_n_cards = divide (divide (bitcnt, 36, 17, 0), size (config_card), 17, 0);
		        config_max_cards = 128;	/* a guess */

		        sst_cardp = null ();
		        do card_no = 1 by 1 while (config_deck.cards (card_no).word ^= FREE_CARD_WORD & sst_cardp = null ());
			  cardp = addr (config_deck.cards (card_no));
			  if config_card.word = SST_CARD_WORD then sst_cardp = cardp;
		        end;

		        if sst_cardp = null () then do;
			      call com_err_ (0, my_name, "Unable to find SST card in configuration deck.");
			      return;
			  end;
		    end;				/* ends do if configp = null */

		aste_entries (i) = sst_card.no_aste (i);
	      end;				/* ends do if aste_entries(i) = 0 */
        end;					/* ends do loop through aste_entries */
        call clean_up ();

/* Calculate size of hash table. */

        n_astes = sum (aste_entries);
        n_buckets = divide (n_astes, AVG_HT_DEPTH, 17);
        do i = 1 to hbound (HT_SIZES, 1) while (n_buckets > HT_SIZES (i));
        end;
        if i > hbound (HT_SIZES, 1) then i = hbound (HT_SIZES, 1);
        n_buckets = HT_SIZES (i);

/* Calculate total size of SST. */

        n_sst_words = size (sst) + n_buckets;
        do i = 0 to 3;
	  words_in_aste (i) = size (aste) + PTS (i);
	  n_sst_words = n_sst_words + words_in_aste (i) * aste_entries (i);
        end;

        n_pages = divide (n_sst_words, 1024, 35, 0);
        words_in_last_page = mod (n_sst_words, 1024);
        if words_in_last_page ^= 0 then n_pages = n_pages + 1;

        call ioa_ ("Size of SST header = ^d words^/Size of AST hash table = ^d words", size (sst), n_buckets);
        do i = 0 to 3;
	  call ioa_ ("Size of ^a ASTE pool with ^d entries (^d words in each) = ^d words",
	      aste_name (i), aste_entries (i), words_in_aste (i), words_in_aste (i) * aste_entries (i));
        end;
        call ioa_ ("Total size of SST = ^d words (^d pages^[ with ^d words used in last page^])",
	  n_sst_words,
	  n_pages, (words_in_last_page ^= 0), words_in_last_page
	  );
        return;

REPORT_ERROR:
        call com_err_ (code, my_name);
        go to DISPLAY_USAGE;

REPORT_ARG_ERROR:
        call com_err_ (code, my_name, arg);

DISPLAY_USAGE:
        call ioa_ ("Usage:  ^a <-4k N_4K_ASTE | -16k N_16K_ASTE | -64k N_64K_ASTE | -256k N_256K_ASTE | -pn PATH>", my_name);
        return;

REPORT_CV_ERROR:
        call com_err_ (error_table_$bad_conversion, my_name,
	  "^/Character ^d caused conversion error in arg, ^a, to control argument ""^a"".",
	  code, arg, ctl_arg);
        return;

REPORT_VALUE_ERROR:
        call com_err_ (error_table_$bad_arg, my_name, "^a to control argument ^a.", arg, ctl_arg);
        return;

clean_up: proc;

        if have_path then if configp ^= null then do;
		 call terminate_file_ (configp, 0, TERM_FILE_TERM, (0));
		 configp = null;
	       end;
    end;
%page;
dcl     AVG_HT_DEPTH	 fixed bin init (5) int static options (constant);
dcl     HT_SIZES		 (6) fixed bin init (64, 128, 256, 512, 1024, 2048) int static options (constant);
dcl     PTS		 (0:3) fixed bin init (4, 16, 64, 256);
dcl     accept_hyphen_path	 bit (1) init ("0"b);
dcl     addr		 builtin;
dcl     arg		 char (argl) based (argp);
dcl     argl		 fixed bin (21);
dcl     argp		 pointer;
dcl     arg_no		 fixed bin;
dcl     aste_entries	 (0:3) fixed bin init (0, 0, 0, 0);
dcl     aste_name		 (0:3) char (4) init ("4K", "16K", "64K", "256K");
dcl     bitcnt		 fixed bin (24);
dcl     card_no		 fixed bin;
dcl     cleanup		 condition;
dcl     code		 fixed bin (35);
dcl     com_err_		 entry () options (variable);
dcl     config_dir_name	 char (168);
dcl     config_ename	 char (32);
dcl     ctl_arg		 char (32);
dcl     cu_$arg_count	 entry (fixed bin, fixed bin (35));
dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl     cv_dec_check_	 entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl     divide		 builtin;
dcl     error_table_$active_function fixed bin (35) ext static;
dcl     error_table_$bad_arg	 fixed bin (35) ext static;
dcl     error_table_$bad_conversion fixed bin (35) ext static;
dcl     error_table_$badopt	 fixed bin (35) ext static;
dcl     error_table_$noarg	 fixed bin (35) ext static;
dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
dcl     expect_4k_value	 bit (1) init ("0"b);
dcl     expect_16k_value	 bit (1) init ("0"b);
dcl     expect_64k_value	 bit (1) init ("0"b);
dcl     expect_256k_value	 bit (1) init ("0"b);
dcl     expect_pn_value	 bit (1) init ("0"b);
dcl     hbound		 builtin;
dcl     have_path		 bit (1) init ("0"b);
dcl     hcs_$status_mins	 entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
dcl     i			 fixed bin;
dcl     initiate_file_	 entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl     ioa_		 entry () options (variable);
dcl     mod		 builtin;
dcl     my_name		 char (14) init ("check_sst_size") int static options (constant);
dcl     n_args		 fixed bin;
dcl     n_astes		 fixed bin;
dcl     n_buckets		 fixed bin;
dcl     n_pages		 fixed bin;
dcl     n_sst_words		 fixed bin;
dcl     null		 builtin;
dcl     pathname_		 entry (char (*), char (*)) returns (char (168));
dcl     size		 builtin;
dcl     stype		 fixed bin (2);
dcl     sum		 builtin;
dcl     terminate_file_	 entry (ptr, fixed bin (24), bit (*), fixed bin (35));
dcl     words_in_aste	 (0:3) fixed bin;
dcl     words_in_last_page	 fixed bin;
%page;
%include access_mode_values;
%page;
%include aste;
%page;
%include config_deck;
%page;
%include config_sst_card;
%page;
%include sst;
%page;
%include terminate_file;
    end check_sst_size;




		    check_tc_data_size.pl1          04/09/85  1511.1r w 04/08/85  1133.8       71946



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

/* format: ^inddcls,ind4,ifthenstmt,ifthendo,thendo,ifthen,tree,^case */

check_tc_data_size: proc;

        call cu_$arg_count (n_args, code);
        if code ^= 0 then go to REPORT_ERROR;

        do arg_no = 1 to n_args;

	  call cu_$arg_ptr (arg_no, argp, argl, code);
	  if code ^= 0 then go to REPORT_ERROR;

	  if expect_apt_value then do;
		expect_apt_value = "0"b;
		ctl_arg = "-apt";
		n_apt = cv_dec_check_ (arg, code);
		if code ^= 0 then go to REPORT_CV_ERROR;
		if n_apt < 1 then go to REPORT_VALUE_ERROR;
	      end;
	  else if expect_itt_value then do;
		     expect_itt_value = "0"b;
		     ctl_arg = "-itt";
		     n_itt = cv_dec_check_ (arg, code);
		     if code ^= 0 then go to REPORT_CV_ERROR;
		     if n_itt < 1 then go to REPORT_VALUE_ERROR;
		 end;
	       else if expect_pn_value then do;
			ctl_arg = "-pn";
			if index (arg, "-") = 1 & ^accept_hyphen_path then do;
			        if arg = "-name" | arg = "-nm" then accept_hyphen_path = "1"b;
			        else go to REPORT_VALUE_ERROR;
			    end;
			else do;
			        expect_pn_value = "0"b;
			        accept_hyphen_path = "0"b;
			        call expand_pathname_ (arg, config_dir_name, config_ename, code);
			        if code ^= 0 then do;
				      call com_err_ (code, my_name,
					"^/Pathname expansion for config deck: ^a", arg);
				      return;
				  end;

			        have_path = "1"b;
			    end;
		      end;

		  else do;
			if arg = "-apt" then expect_apt_value = "1"b;
			else if arg = "-itt" then expect_itt_value = "1"b;
			     else if arg = "-pathname" then expect_pn_value = "1"b;
				else if arg = "-pn" then expect_pn_value = "1"b;
				     else if index (arg, "-") = 1 then do;
					        code = error_table_$badopt;
					        go to REPORT_ARG_ERROR;
					    end;
					else do;
					        code = error_table_$bad_arg;
					        go to REPORT_ARG_ERROR;
					    end;
		      end;			/* ends ctl arg do */

        end;					/* ends arg do loop */

/* Check for a missing argument. */

        if expect_apt_value | expect_itt_value | expect_pn_value then do;
	      call com_err_ (error_table_$noarg, my_name, "^/after ^a", arg);
	      return;
	  end;

/* If either value is missing, find a config deck and get it. */

        if n_apt = 0 | n_itt = 0 then do;
	      configp = null ();
	      on cleanup call clean_up ();

	      if have_path then do;
		    call initiate_file_ (config_dir_name, config_ename, R_ACCESS, configp, bitcnt, code);
		    if code ^= 0 then do;
			  call com_err_ (code, my_name,
			      "^/Cannot access config deck with pathname, ^a", pathname_ (config_dir_name, config_ename));
			  return;
		        end;
		end;
	      else do;
		    configp = addr (config_deck$);
		    call hcs_$status_mins (configp, stype, bitcnt, code);
		    if code ^= 0 then do;
			  call com_err_ (code, my_name, "^/Cannot get bit count of config deck.");
			  return;
		        end;
		end;

	      config_n_cards = divide (divide (bitcnt, 36, 17, 0), size (config_card), 17, 0);
	      config_max_cards = 128;			/* a guess */

	      tcd_cardp = null ();
	      do card_no = 1 by 1 while (config_deck.cards (card_no).word ^= FREE_CARD_WORD & tcd_cardp = null ());
		cardp = addr (config_deck.cards (card_no));
		if config_card.word = TCD_CARD_WORD then tcd_cardp = cardp;
	      end;

	      if tcd_cardp = null () then do;
		    call com_err_ (0, my_name, "Unable to find TCD card in configuration deck.");
		    return;
		end;

	      if n_apt = 0 then n_apt = tcd_card.no_apt;
	      if n_itt = 0 then n_itt = tcd_card.no_itt;

	      call clean_up ();
	  end;

        n_tcm_words = size (tcm) - 1;
        n_apt_words = size (apte) * n_apt;
        n_itt_words = size (itt_entry) * n_itt;
        n_tc_data_words = n_tcm_words + n_apt_words + n_itt_words;
        n_pages = divide (n_tc_data_words, 1024, 35, 0);
        words_in_last_page = mod (n_tc_data_words, 1024);
        if words_in_last_page ^= 0 then n_pages = n_pages + 1;

        call ioa_ ("Size of tc_data metering (tcm) = ^d words^/Size of APT with ^d entries, ^d words each = ^d words^/Size of ITT with ^d entries, ^d words each = ^d words^/Size of tc_data = ^d words (^d pages^[ with ^d words in last page^])",
	  n_tcm_words,
	  n_apt, size (apte), n_apt_words,
	  n_itt, size (itt_entry), n_itt_words,
	  n_tc_data_words,
	  n_pages, (words_in_last_page ^= 0), words_in_last_page
	  );
        return;

REPORT_ERROR:
        call com_err_ (code, my_name);
        go to DISPLAY_USAGE;

REPORT_ARG_ERROR:
        call com_err_ (code, my_name, arg);

DISPLAY_USAGE:
        call ioa_ ("Usage:  ^a <-apt N_APTE | -itt N_ITTE | -pathname PATH>", my_name);
        return;

REPORT_CV_ERROR:
        call com_err_ (error_table_$bad_conversion, my_name,
	  "^/Character ^d caused conversion error in arg, ^a, to control argument ""^a"".",
	  code, arg, ctl_arg);
        return;

REPORT_VALUE_ERROR:
        call com_err_ (error_table_$bad_arg, my_name, "^a to control argument ^a.", arg, ctl_arg);
        return;

clean_up: proc;

        if have_path then if configp ^= null then do;
		 call terminate_file_ (configp, 0, TERM_FILE_TERM, (0));
		 configp = null;
	       end;
    end;

dcl     accept_hyphen_path	 bit (1) init ("0"b);
dcl     addr		 builtin;
dcl     arg		 char (argl) based (argp);
dcl     argl		 fixed bin (21);
dcl     argp		 pointer;
dcl     arg_no		 fixed bin;
dcl     bitcnt		 fixed bin (24);
dcl     card_no		 fixed bin;
dcl     cleanup		 condition;
dcl     code		 fixed bin (35);
dcl     com_err_		 entry () options (variable);
dcl     config_$find	 entry (char (4) aligned, ptr);
dcl     config_dir_name	 char (168);
dcl     config_ename	 char (32);
dcl     ctl_arg		 char (32);
dcl     cu_$arg_count	 entry (fixed bin, fixed bin (35));
dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl     cv_dec_check_	 entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl     divide		 builtin;
dcl     error_table_$active_function fixed bin (35) ext static;
dcl     error_table_$bad_arg	 fixed bin (35) ext static;
dcl     error_table_$bad_conversion fixed bin (35) ext static;
dcl     error_table_$badopt	 fixed bin (35) ext static;
dcl     error_table_$noarg	 fixed bin (35) ext static;
dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
dcl     expect_apt_value	 bit (1) init ("0"b);
dcl     expect_itt_value	 bit (1) init ("0"b);
dcl     expect_pn_value	 bit (1) init ("0"b);
dcl     have_path		 bit (1) init ("0"b);
dcl     hcs_$status_mins	 entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
dcl     index		 builtin;
dcl     initiate_file_	 entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl     ioa_		 entry () options (variable);
dcl     mod		 builtin;
dcl     my_name		 char (18) init ("check_size_tc_data") int static options (constant);
dcl     n_apt		 fixed bin (35) init (0);
dcl     n_args		 fixed bin;
dcl     n_itt		 fixed bin (35) init (0);
dcl     n_apt_words		 fixed bin (35);
dcl     n_itt_words		 fixed bin (35);
dcl     n_pages		 fixed bin (35);
dcl     n_tc_data_words	 fixed bin (35);
dcl     n_tcm_words		 fixed bin (35);
dcl     null		 builtin;
dcl     pathname_		 entry (char (*), char (*)) returns (char (168));
dcl     size		 builtin;
dcl     stype		 fixed bin (2);
dcl     terminate_file_	 entry (ptr, fixed bin (24), bit (*), fixed bin (35));
dcl     words_in_last_page	 fixed bin;
%page;
%include access_mode_values;
%page;
%include apte;
%page;
%include config_deck;
%page;
%include config_tcd_card;
%skip (4);
%include itt_entry;
%page;
%include tcm;
%page;
%include hc_lock;
%page;
%include terminate_file;
    end check_tc_data_size;




		    compare_configuration_deck.pl1  04/09/85  1511.1r w 04/08/85  1133.8      182574



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
compare_configuration_deck:
     procedure () options (variable);

/* *	Utility command to compare running config deck with saved copy, print
   *	out differences.
   *
   *	Created: 02/17/80, W. Olin Sibert, from print_configuration_deck.
   *	Modified: 02/01/84, Keith Loepere for -label, also to allow
   *	   comparison of two decks, neither the config_deck. */

	dcl     (argno, nargs)	 fixed bin;
	dcl     (al, rsl)		 fixed bin (21);
	dcl     (ap, rsp)		 pointer;
	dcl     arg		 char (al) based (ap);
	dcl     rs		 char (rsl) varying based (rsp);
	dcl     code		 fixed bin (35);
	dcl     whoami		 char (32);
	dcl     (idx, jdx)		 fixed bin;
	dcl     brief_sw		 bit (1) aligned;
	dcl     af_sw		 bit (1) aligned;
	dcl     label_output	 bit (1) aligned;

	dcl     (old_dname, new_dname) char (168);	/* also pathname for messages */
	dcl     (old_ename, new_ename) char (32);
	dcl     (old_dp, new_dp)	 pointer;
	dcl     (old_bc, new_bc)	 fixed bin (24);
	dcl     (old_recs, new_recs)	 fixed bin;
	dcl     (old_max_recs, new_max_recs) fixed bin;
	dcl     card_str		 char (256) varying;

/* The limit of 32 on the size of the changed_cards array is part of the heuristics
   used to decide whether the decks are "completely different". It is 32 because
   that is a convenient number, rather than from some sort of sacred principle. */

	dcl     n_changed		 fixed bin;
	dcl     1 changed_cards	 (32) aligned,	/* indices of changed cards */
		2 old		 fixed bin,
		2 new		 fixed bin;

	dcl     n_old_mem_cards	 fixed bin;
	dcl     n_new_mem_cards	 fixed bin;

	dcl     1 mem_cards		 (16) aligned,	/* should never be more than 16 memories, right? */
		2 old_idx		 fixed bin,
		2 old_port	 fixed bin (35),
		2 new_idx		 fixed bin,
		2 new_port	 fixed bin (35);

	dcl     decks_different	 bit (1) aligned;
	dcl     mem_cards_different	 bit (1) aligned;
	dcl     n_added		 fixed bin;
	dcl     n_deleted		 fixed bin;

	dcl     added		 bit (1024) aligned;/* bits indicating which cards were added, deleted, changed */
	dcl     deleted		 bit (1024) aligned;/* note that this puts a limit of 1024 cards in a config deck. */

	dcl     complain		 entry variable options (variable);

	dcl     active_fnc_err_	 entry options (variable);
	dcl     com_err_		 entry options (variable);
	dcl     config_deck_parse_$binary_to_ascii entry (ptr, char (256) var);
	dcl     cu_$af_return_arg	 entry (fixed bin, pointer, fixed bin (21), fixed bin (35));
	dcl     cu_$arg_ptr		 entry (fixed bin, pointer, fixed bin (21), fixed bin (35));
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     initiate_file_	 entry (char (*), char (*), bit (*), pointer, fixed binary (24), fixed binary (35));
	dcl     ioa_		 entry options (variable);
	dcl     ioa_$rsnnl		 entry options (variable);
	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));
     	dcl     terminate_file_	 entry (ptr, fixed bin (24), bit (*), fixed bin (35));

	dcl     (error_table_$noarg,
	        error_table_$badopt)	 fixed bin (35) external static;

/* The CARD_OPERANDS list defines all the cards which have several operands to
   be included in the comparison before deciding whether the cards are "changed",
   or deleted and added. */

	dcl     1 CARD_OPERANDS	 (9) aligned internal static options (constant),
		2 name		 char (4) aligned init
				 ("cpu ", "iom ", "mem ", "chnl", "mpc ", "prph", "part", "udsk", "parm"),
		2 count		 fixed bin init
				 (1, 1, 1, 1, 2, 1, 1, 1, 1);

	dcl     cleanup		 condition;

	dcl     (addr, char, copy, divide, hbound, null, rtrim, substr, unspec) builtin;

/*  */

	whoami = "compare_configuration_deck";
	old_dp = null ();
	new_dp = null ();

	on condition (cleanup) call clean_things_up ();

	call cu_$af_return_arg (nargs, rsp, rsl, code);

	if code ^= 0 then do;			/* assume it's a command */
		complain = com_err_;
		af_sw = "0"b;
	     end;

	else do;					/* otherwise, it's an AF */
		complain = active_fnc_err_;
		af_sw = "1"b;
		rs = "";
	     end;

	brief_sw = "0"b;
	label_output = "0"b;

	do argno = 1 to nargs;
	     call cu_$arg_ptr (argno, ap, al, (0));

	     if char (arg, 1) ^= "-" then do;		/* a pathname, perhaps? */
		     if new_dp ^= null () then do;	/* but at most two, thanks */
			     call complain (0, whoami, "At most two pathnames for config decks may be supplied. ^a", arg);
			     goto MAIN_RETURN;
			end;

		     if old_dp = null () then do;
			     call expand_pathname_ (arg, old_dname, old_ename, code);
			     if code ^= 0 then do;
				     call complain (code, whoami, "^a", arg);
				     goto MAIN_RETURN;
				end;

			     call initiate_file_ (old_dname, old_ename, R_ACCESS, old_dp, old_bc, code);
			     if old_dp = null () then do;
				     call complain (code, whoami, "^a", pathname_ (old_dname, old_ename));
				     goto MAIN_RETURN;
				end;
			end;
		     else do;			/* must be second (new) deck */
			     call expand_pathname_ (arg, new_dname, new_ename, code);
			     if code ^= 0 then do;
				     call complain (code, whoami, "^a", arg);
				     goto MAIN_RETURN;
				end;

			     call initiate_file_ (new_dname, new_ename, R_ACCESS, new_dp, new_bc, code);
			     if new_dp = null () then do;
				     call complain (code, whoami, "^a", pathname_ (new_dname, new_ename));
				     goto MAIN_RETURN;
				end;
			end;
		end;

	     else if arg = "-brief" | arg = "-bf" then brief_sw = "1"b;
	     else if arg = "-long" | arg = "-lg" then brief_sw = "0"b;
	     else if arg = "-label" | arg = "-lbl" then label_output = "1"b;
	     else if arg = "-no_label" | arg = "-nlbl" then label_output = "0"b;

	     else do;
		     call complain (error_table_$badopt, whoami, "^a", arg);
		     goto MAIN_RETURN;
		end;
	end;					/* of argument loop */

/*  */

	config_n_cards, config_max_cards = 1;		/* eliminate compiler warning */

	if old_dp = null () then do;
		call complain (error_table_$noarg, whoami, "^/^5xUsage:^3x^a pathname_of_old_deck {pathname_of_new_deck} {-brief}", whoami);
		goto MAIN_RETURN;
	     end;

	if new_dp = null () then do;			/* use system copy as new */
		new_dname = ">sl1";
		new_ename = "config_deck";
		call initiate_file_ (new_dname, new_ename, R_ACCESS, new_dp, new_bc, code);
		if new_dp = null () then do;
			call com_err_ (code, whoami, "Unable to initiate >sl1>config_deck");
			goto MAIN_RETURN;
		     end;
	     end;

	old_dname = pathname_ (old_dname, old_ename);
	new_dname = pathname_ (new_dname, new_ename);

	old_max_recs = divide (old_bc, (36 * 16), 17, 0); /* count the cards in each deck */
	new_max_recs = divide (new_bc, (36 * 16), 17, 0);

	call count_cards (new_dp, new_max_recs, new_recs);
	if new_recs < 0 then do;
		call complain (0, whoami, "Config deck ^a appears misformatted.", new_dname);
		goto MAIN_RETURN;
	     end;

	call count_cards (old_dp, old_max_recs, old_recs);
	if old_recs < 0 then do;
		call complain (0, whoami, "Config deck ^a appears misformatted.", old_dname);
		goto MAIN_RETURN;
	     end;


	call compare_decks ();

	if decks_different then do;			/* sorry, too different */
		if af_sw then do;			/* just return false */
			rs = "false";
			goto MAIN_RETURN;
		     end;

		call ioa_ ("Config deck^[s differ substantially.^; ^a differs substantially from ^a.^]",
		     brief_sw, new_dname, old_dname);

		if brief_sw then goto MAIN_RETURN;	/* don't bother printing them */

		call ioa_ ("Config deck 2 (^a):^/", new_dname);

		call print_deck (new_dp, new_recs, 3);

		call ioa_ ("^/Config deck 1 (^a):^/", old_dname);

		call print_deck (old_dp, old_recs, 3);

		call ioa_ ("");
		goto MAIN_RETURN;
	     end;

	if (n_added = 0) & (n_deleted = 0) & (n_changed = 0) & (^mem_cards_different) then do;
		if af_sw then do;
			rs = "true";
			goto MAIN_RETURN;
		     end;

		if ^brief_sw then /* no differences, report that fact, perhaps */
		     call ioa_ ("Decks are identical.^/");
		goto MAIN_RETURN;
	     end;

	if af_sw then do;				/* there are some differences... */
		rs = "false";
		goto MAIN_RETURN;
	     end;

	if n_added > 0 then do;
		if ^brief_sw then
		     call ioa_ ("^/Cards added in deck 2:");

		do idx = 1 to new_recs;
		     if substr (added, idx, 1) = "1"b then do;
			     cardp = addr (new_dp -> config_deck.cards (idx));
			     call get_card_str ();
			     if brief_sw then
				call ioa_ ("New:^2x^a", card_str);
			     else call ioa_ ("^2x^a", card_str);
			end;
		end;
	     end;					/* of processing for added cards */

	if n_deleted > 0 then do;
		if ^brief_sw then
		     call ioa_ ("^/Cards deleted from deck 2:");

		do idx = 1 to new_recs;
		     if substr (deleted, idx, 1) = "1"b then do;
			     cardp = addr (old_dp -> config_deck.cards (idx));
			     call get_card_str ();
			     if brief_sw then
				call ioa_ ("Old:^2x^a", card_str);
			     else call ioa_ ("^2x^a", card_str);
			end;
		end;
	     end;					/* of processing for deleted cards */

	if n_changed > 0 then do;
		if ^brief_sw then
		     call ioa_ ("^/Changed cards:");

		do idx = 1 to n_changed;
		     jdx = changed_cards.old (idx);
		     cardp = addr (old_dp -> config_deck.cards (jdx));
		     call get_card_str ();
		     call ioa_ ("Was:^2x^a", card_str); /* format is the same here, brief or not */

		     jdx = changed_cards.new (idx);
		     cardp = addr (new_dp -> config_deck.cards (jdx));
		     call get_card_str ();
		     call ioa_ ("^6x^a", card_str);
		end;
	     end;					/* of processing for changed cards */

	if mem_cards_different then do;		/* MEM cards are reorganized between the two decks, */
		if ^brief_sw then /* so print all the MEM cards */
		     call ioa_ ("^/MEM cards are reordered:");

		do idx = 1 to n_old_mem_cards;
		     cardp = addr (old_dp -> config_deck.cards (mem_cards.old_idx (idx)));
		     call get_card_str ();
		     call ioa_ ("^[Was:^2x^;^6x^]^a", (idx = 1), card_str);
		end;

		do idx = 1 to n_new_mem_cards;
		     cardp = addr (new_dp -> config_deck.cards (mem_cards.new_idx (idx)));
		     call get_card_str ();
		     call ioa_ ("^[Now:^2x^;^6x^]^a", (idx = 1), card_str);
		end;
	     end;

MAIN_RETURN:
	call clean_things_up ();

	return;

/*  */

count_cards: proc (P_dp, P_max_recs, P_recs);

/* *	This procedure counts the cards in a config deck, and decides whether the
   *	deck is properly formatted. */

	dcl     (P_dp		 pointer,
	        P_max_recs		 fixed bin,
	        P_recs		 fixed bin) parameter;

	dcl     idx		 fixed bin;
	dcl     done		 bit (1) aligned;
	dcl     count		 fixed bin;
	dcl     cp		 pointer;

	count = 0;
	done = "0"b;

	do idx = 1 to P_max_recs while (^done);		/* check format */
	     cp = addr (P_dp -> config_deck.cards (idx));
	     if cp -> config_card.word = FREE_CARD_WORD then done = "1"b; /* found the end */
	     else count = count + 1;			/* record count */
	end;

	if ^done then /* indicate error */
	     P_recs = -1;
	else P_recs = count;			/* otherwise, return count */

	return;
     end count_cards;

/*  */

get_card_str: proc ();

	dcl     idx		 fixed bin;
	dcl     type		 bit (2) aligned;
	dcl     char_field		 char (4);
	dcl     numeric_field	 fixed bin (35);
	dcl     temp_str		 char (16) varying;

	if label_output then call config_deck_parse_$binary_to_ascii (cardp, card_str);
	else do;
		card_str = config_card.word;		/* initialize output string */

		do idx = 1 to config_card.n_fields;	/* look at all words of the card */
		     type = config_card.field_type (idx); /* get the type for the current word */
		     unspec (numeric_field) = unspec (config_card.data_field (idx));

		     if type = CONFIG_OCTAL_TYPE then /* octal number */
			call ioa_$rsnnl ("^o", temp_str, (0), numeric_field);

		     else if type = CONFIG_SINGLE_CHAR_TYPE then /* letter, probably */
			if numeric_field > 8 | numeric_field < 1 then /* apparently not? */
			     call ioa_$rsnnl ("^o", temp_str, (0), numeric_field);
			else temp_str = substr ("abcdefgh", numeric_field, 1);

		     else if type = CONFIG_STRING_TYPE then do; /* string */
			     unspec (char_field) = unspec (config_card.data_field (idx));
			     temp_str = char_field;
			end;

		     else if type = CONFIG_DECIMAL_TYPE then /* decimal number */
			call ioa_$rsnnl ("^d.", temp_str, (0), numeric_field);

		     card_str = card_str || "  ";
		     card_str = card_str || temp_str;
		end;				/* of loop through card fields */
	     end;

	return;
     end get_card_str;

/*  */

compare_decks: proc ();

/* *	This procedure compares the two decks, after deciding whether the
   *	MEM cards should be compared directly or listed in their entirity. */

	dcl     (old_idx, new_idx, idx, jdx) fixed bin;
	dcl     (ocp, ncp)		 pointer;

/* First, we look through each deck to find all the MEM cards. This is done so that it is possible to
   detect whether the cards have been rearranged, and thus whether they should be listed. The object
   of this is to only print all the mem cards if their order is interestingly different; that is, to
   not print them if the only change is the turning on/off of a single memory. If there are a different
   number of MEM cards in the two decks, they are de-facto assumed to have been rearranged. */

	n_old_mem_cards = 0;
	n_new_mem_cards = 0;

	do old_idx = 1 to old_recs;			/* now, locate all the mem cards in the old deck */
	     ocp = addr (old_dp -> config_deck.cards (old_idx));

	     if ocp -> config_card.word = MEM_CARD_WORD then do; /* special-case MEM cards to detect reordering */
		     if n_old_mem_cards >= hbound (mem_cards, 1) then
			goto DECKS_DIFFERENT;

		     n_old_mem_cards = n_old_mem_cards + 1;

		     mem_cards (n_old_mem_cards).old_idx = old_idx; /* record info about this card */
		     mem_cards (n_old_mem_cards).old_port = ocp -> mem_card.tag;
		end;
	end;

	do new_idx = 1 to new_recs;			/* and look in the new deck, too */
	     ncp = addr (new_dp -> config_deck.cards (new_idx));

	     if ncp -> config_card.word = MEM_CARD_WORD then do; /* special-case MEM cards to detect reordering */
		     if n_new_mem_cards >= hbound (mem_cards, 1) then
			goto DECKS_DIFFERENT;

		     n_new_mem_cards = n_new_mem_cards + 1;

		     mem_cards (n_new_mem_cards).new_idx = new_idx; /* record info about this card */
		     mem_cards (n_new_mem_cards).new_port = ncp -> mem_card.tag;
		end;
	end;

	mem_cards_different = "0"b;

	if n_old_mem_cards ^= n_new_mem_cards then /* if different counts, one has been added/deleted, so we want */
	     mem_cards_different = "1"b;		/* to print out all of both sets of mem cards */

	else do;					/* otherwise, look through and see if the order is the same */
		do idx = 1 to n_old_mem_cards while (^mem_cards_different); /* and set the bit if it isn't */
		     if mem_cards.old_port (idx) ^= mem_cards.new_port (idx) then
			mem_cards_different = "1"b;
		end;
	     end;

/* Now, run through the two decks and compare individual cards, ignoring MEM cards if
   they have been determined above to be different. */

	n_changed = 0;
	n_added = new_recs;
	n_deleted = 0;

	substr (added, 1, new_recs) = copy ("1"b, new_recs); /* assume all have been added to start out with */
	substr (deleted, 1, old_recs) = copy ("0"b, old_recs); /* and that none have been deleted */
	decks_different = "0"b;

	do old_idx = 1 to old_recs;			/* look through all cards in the original deck */
	     ocp = addr (old_dp -> config_deck.cards (old_idx));

	     if ocp -> config_card.word = MEM_CARD_WORD then /* special-case MEM cards if necessary */
		if mem_cards_different then
		     goto NEXT_OLD_CARD;

	     do new_idx = 1 to new_recs;		/* compare against new cards */
		if substr (added, new_idx, 1) = "0"b then /* we've already hit this one, and gotten */
		     goto NEXT_NEW_CARD;		/* something from it, so don't compare again */

		ncp = addr (new_dp -> config_deck.cards (new_idx));

		if ncp -> config_card.word = MEM_CARD_WORD then /* ignore MEM cards, if necessary */
		     if mem_cards_different then
			goto NEXT_NEW_CARD;		/* and consider the next new card for comparison */

		if unspec (ocp -> config_card) = unspec (ncp -> config_card) then /* identical cards */
		     goto IDENTICAL;

		if ocp -> config_card.word ^= ncp -> config_card.word then /* see if they're similar */
		     goto DIFFERENT;

/* This loop tests to see whether the cards require any similar operands. Examples of this would be
   MEM cards, PRPH cards, etc. If the card name is not found in our list of cards, it is assumed to
   not need any similar operands, and thus be "changed" as long as the names are the same. */

		do idx = 1 to hbound (CARD_OPERANDS, 1);/* names are the same, see if we need similar operands, too */
		     if ocp -> config_card.word = CARD_OPERANDS.name (idx) then do; /* we know this card */
			     do jdx = 1 to CARD_OPERANDS.count (idx); /* see if the required operands are the same */
				if ocp -> config_card.data_field (jdx) ^= ncp -> config_card.data_field (jdx) then
				     goto DIFFERENT;/* words are different */

				if ocp -> config_card.field_type (jdx) ^= ncp -> config_card.field_type (jdx) then
				     goto DIFFERENT;/* types are different */
			     end;			/* of comparing required same operands */

			     goto CHANGED;		/* the cards are similar */
			end;			/* of checking operands for similarity */
		end;				/* of loop looking for cards which need similar operands */
						/* just fall through if not found */

CHANGED:		if n_changed >= hbound (changed_cards, 1) then /* too many different cards. */
		     goto DECKS_DIFFERENT;		/* decks are probably completely different */

		n_changed = n_changed + 1;		/* record the card indices */
		changed_cards.old (n_changed) = old_idx;
		changed_cards.new (n_changed) = new_idx;

		substr (added, new_idx, 1) = "0"b;	/* record that we've gotten something from this card */
		n_added = n_added - 1;		/* update the count of added cards */
		goto NEXT_OLD_CARD;			/* and get the next old card */

IDENTICAL:	substr (added, new_idx, 1) = "0"b;	/* the cards are identical, so flag it as seen, and continue */
		n_added = n_added - 1;		/* with the next new card */
		goto NEXT_OLD_CARD;

DIFFERENT:	goto NEXT_NEW_CARD;			/* if cards are different, do nothing and try the next card */

NEXT_NEW_CARD: end;					/* of loop through new cards */

	     substr (deleted, old_idx, 1) = "1"b;	/* if we fall out, there was no comprable card, so the old */
	     n_deleted = n_deleted + 1;		/* card has been deleted */

NEXT_OLD_CARD: end;					/* of loop through old cards */

	if mem_cards_different then do;		/* take the MEM cards out of the "added" list */
		do new_idx = 1 to new_recs;
		     ncp = addr (new_dp -> config_deck.cards (new_idx));

		     if ncp -> config_card.word = MEM_CARD_WORD then do;
			     substr (added, new_idx, 1) = "0"b;
			     n_added = n_added - 1;
			end;
		end;				/* of loop through cards */
	     end;

	if (n_added + n_deleted) > hbound (changed_cards, 1) then /* if too many, the decks are different */
	     goto DECKS_DIFFERENT;

	decks_different = "0"b;			/* minor differences, if at all */

	return;					/* normal return */


DECKS_DIFFERENT:					/* come here if the decks appear completely different */
	decks_different = "1"b;
	return;

     end compare_decks;

/*  */

print_deck: proc (P_dp, P_recs, P_indent);

/* *	This procedure prints a config deck */

	dcl     (P_dp		 pointer,
	        P_recs		 fixed bin,
	        P_indent		 fixed bin) parameter;

	dcl     idx		 fixed bin;

	do idx = 1 to P_recs;
	     cardp = addr (P_dp -> config_deck.cards (idx));
	     call get_card_str ();
	     call ioa_ ("^vx^a", P_indent, card_str);
	end;

	return;
     end print_deck;

/*  */

clean_things_up: proc ();

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

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

	return;
     end clean_things_up;
%page; %include config_deck;
%page; %include config_mem_card;
%page; %include access_mode_values;
%page; %include terminate_file;
     end compare_configuration_deck;




		    convert_configuration_deck.pl1  04/09/85  1511.1r w 04/08/85  1133.8       47592



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
convert_configuration_deck: proc;

/* Program to use config_deck_parse_ to convert an ascii source form of config 
deck to binary.  This would be done mostly to test the source for errors.  It
also allows for a compare_configuration_deck against a binary deck.
Keith Loepere, February 1984. */

/* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */

dcl  NL			        char (1) static options (constant) init ("
");
dcl  addr			        builtin;
dcl  arg			        char (arg_len) based (arg_ptr);
dcl  arg_count		        fixed bin;
dcl  arg_len		        fixed bin (21);
dcl  arg_ptr		        ptr;
dcl  ascii_config_card	        char (256) var;
dcl  ascii_ptr		        ptr;		/* to ascii input file */
dcl  bit_count		        fixed bin (24);	/* of ascii file */
dcl  card_len		        fixed bin (21);	/* length of text in card (minus nl) */
dcl  cleanup		        condition;
dcl  code			        fixed bin (35);
dcl  com_err_		        entry () options (variable);
dcl  config_deck_parse_$ascii_to_binary entry (char (256) var, ptr, fixed bin);
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  divide		        builtin;
dcl  entryname		        char (32);		/* with equals in it */
dcl  expand_pathname_	        entry (char (*), char (*), char (*), fixed bin (35));
dcl  expand_pathname_$component       entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  file			        char (file_lth) based (ascii_ptr); /* ascii input file */
dcl  file_lth		        fixed bin (21);
dcl  file_pos		        fixed bin (21);	/* starting pos in file for this new line */
dcl  get_equal_name_	        entry (char (*), char (*), char (32), fixed bin (35));
dcl  index		        builtin;
dcl  input_card_num		        fixed bin;		/* input line num */
dcl  initiate_file_$create	        entry (char (*), char (*), bit (*), ptr, bit (1) aligned, fixed bin (24), fixed bin (35));
dcl  initiate_file_$component	        entry (char (*), char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  me			        char (26) static options (constant) init ("convert_configuration_deck");
dcl  null			        builtin;
dcl  output_card_num	        fixed bin;		/* index into config deck */
dcl  s_componentname	        char (32);
dcl  s_dirname		        char (168);
dcl  s_entryname		        char (32);
dcl  size			        builtin;
dcl  substr		        builtin;
dcl  t_dirname		        char (168);
dcl  t_entryname		        char (32);
dcl  terminate_file_	        entry (ptr, fixed bin (24), bit (*), fixed bin (35));
%page;
	call cu_$arg_count (arg_count, code);
	if code ^= 0 | arg_count ^= 2 then do;
	     call com_err_ (code, me, "Usage: convert_configuration_deck ascii_file binary_file");
	     return;
	end;
	ascii_ptr = null;
	configp = null;
	on cleanup call clean_up;

	call cu_$arg_ptr (1, arg_ptr, arg_len, code);	/* find ascii source */
	call expand_pathname_$component (arg, s_dirname, s_entryname, s_componentname, code);
	if code ^= 0 then go to error;
	call initiate_file_$component (s_dirname, s_entryname, s_componentname, R_ACCESS, ascii_ptr, bit_count, code);
	if ascii_ptr = null then go to error;
	file_lth = divide (bit_count + 8, 9, 21);

	call cu_$arg_ptr (2, arg_ptr, arg_len, code);	/* find binary output seg */
	call expand_pathname_ (arg, t_dirname, entryname, code);
	if code ^= 0 then go to error;
	call get_equal_name_ (s_entryname, entryname, t_entryname, code);
	if code ^= 0 then go to error;
	call initiate_file_$create (t_dirname, t_entryname, RW_ACCESS, configp, ("0"b), (0), code);
	if configp = null then go to error;
%page;
	config_max_cards, config_n_cards = 256;
	input_card_num, output_card_num = 0;
	file_pos = 1;
	do while (file_pos <= file_lth);
	     input_card_num = input_card_num + 1;
	     card_len = index (substr (file, file_pos), NL);
	     if card_len = 0 then card_len = file_lth - file_pos + 1;
	     else card_len = card_len - 1;
	     ascii_config_card = substr (file, file_pos, card_len);
	     file_pos = file_pos + card_len + 1;
	     if card_len > 0 then do;
		output_card_num = output_card_num + 1;
		cardp = addr (config_deck.cards (output_card_num));
		call config_deck_parse_$ascii_to_binary (ascii_config_card, cardp, input_card_num);
	     end;
	end;
	do output_card_num = output_card_num + 1 to config_max_cards; /* blank out rest of deck */
	     config_deck.cards (output_card_num).word = FREE_CARD_WORD;
	end;

/*	call total_config_deck_check;  */

	call clean_up;
	return;

error:	call com_err_ (code, me, "^a", arg);
	call clean_up;
	return;
%page;
clean_up: proc;

	if configp ^= null then call terminate_file_ (configp, 36 * size (config_deck), TERM_FILE_BC | TERM_FILE_TERM, code);
	if ascii_ptr ^= null then call terminate_file_ (ascii_ptr, 0, TERM_FILE_TERM, code);
	return;
     end;
%page; %include access_mode_values;
%page; %include config_deck;
%page; %include terminate_file;
     end;




		    define_work_classes.pl1         11/15/82  1908.1rew 11/15/82  1526.9       37359



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


define_work_classes: dwc: proc;

/* Coded RE Mullen Spring 1975 for priority scheduler */
/* Modified 05/01/81, W. Olin Siebrt, for version 3 MGT */

dcl  linkage_error condition;
% include work_class_info;
% include mgt;
dcl  mgtp ptr;
dcl 1 wci like work_class_info;
dcl  i fixed bin;
dcl  hphcs_$define_work_classes entry (ptr, fixed bin (35));
dcl  hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1),
     fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl (addr, bin, null, unspec) builtin;


dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl  al fixed bin;
dcl  ap ptr;
dcl  arg char (al) based (ap);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  percent fixed bin;
dcl  cu_$arg_count entry (fixed bin);
dcl  ac fixed bin;
dcl (ioa_, com_err_) entry options (variable);
dcl  code fixed bin (35);

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



	unspec (wci) = "0"b;



	call cu_$arg_count (ac);
	if ac = 0 | ac > 16 then do;
USAGE:
	     call ioa_ ("define_work_classes: Usage:");
	     call ioa_ ("^-define_work_classes pct_wc_1 pct_wc_2 pct_wc_3  .. pct_wc_n");
	     call ioa_ ("^-define_work_classes  -sys pct_wc_0");
	     return;
	end;



	call cu_$arg_ptr (1, ap, al, code);
	if arg = "-sys" | arg = "-system" then do;
	     if ac ^= 2 then go to USAGE;
	     wci.set_system_wc = "1"b;
	     i = 2;
	     call cu_$arg_ptr (i, ap, al, code);
	     if code ^= 0 then go to ERR;

	     percent = cv_dec_check_ (arg, code);
	     if code ^= 0 then go to PCT_ERR;

	     wci.system_wc_min_pct = percent;
	end;

	else do;
	     wci.set_user_wc = "1"b;			/* Must be setting user work classes */

	     do i = 1 to ac;
		call cu_$arg_ptr (i, ap, al, code);
		if code ^= 0 then go to ERR;

		percent = cv_dec_check_ (arg, code);
		if code ^= 0 then go to PCT_ERR;

		if percent > 0 then do;
		     wci.user_wc_defined (i) = "1"b;
		     wci.user_wc_min_pct (i) = percent;
		end;
		else if percent < 0 then go to PCT_ERR;
						/* else percent = 0 => undefined */
	     end;					/* of arg-read & set-pct loop */
						/* dont undefine official work classes */
	     mgtp = null ();
	     call hcs_$initiate (">system_control_1", "mgt", "", 0b, 1b, mgtp, code);
	     if mgtp = null () then do;
		call com_err_ (bin (0, 35), "define_work_classes", "Unable to initiate mgt.");
		return;
	     end;
	     if mgt.version_indicator = "VERSION " then do;
		i = MGT_version_3;			/* Cause errmess if wrong vers at compile time */
		do i = 1 to 16;
		     if mgt.user_wc_defined (i) then
			if ^wci.user_wc_defined (i) then do;
			     call com_err_ (bin (0, 35), "define_work_classes", "Work class ^d must exist.", i);
			     call hcs_$terminate_noname (mgtp, code); /* be a good scout */
			     return;
			end;
		end;
	     end;
	     call hcs_$terminate_noname (mgtp, code);	/* be a good scout */
	end;

	on linkage_error begin;
	     call ioa_ ("define_work_classes: This command requires access to hphcs_.");
	     go to RETURN;
	end;

	call hphcs_$define_work_classes (addr (wci), code);
	if code ^= 0 then do;
	     if wci.error_process_id ^= ""b then
		call com_err_ (code, "define_work_classes", "err_pid = ^w, err_wc = ^d",
		wci.error_process_id, wci.error_work_class);
	     else go to ERR;
	end;


	return;
ERR:
	call com_err_ (code, "define_work_classes");
	return;

PCT_ERR:
						/* here if error on input percent */
	call com_err_ (bin (0, 35), "define_work_classes", "invalid percent in arg ^d", i);
	return;


RETURN:	return;
     end define_work_classes;




		    poll_mos_memory.pl1             11/15/82  1908.1rew 11/15/82  1527.0       15246



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


/* POLL_MOS_MEMORY: Command to read mos memory maintainance registers and print contents */

/* Written May 1976 by Larry Johnson */
/* Modified June 1977 by Larry Johnson for new phcs_ interface. */

poll_mos_memory: proc;

dcl  code fixed bin (35);
dcl  mem (0:31) char (1) unal;
dcl  store (0:31) char (2) unal;
dcl  data (0:31) fixed bin (71);
dcl  i fixed bin;
dcl  name char (15) int static options (constant) init ("poll_mos_memory");
dcl  descrip char (100) var;

dcl  phcs_$mos_memory_check entry (dim (0:31) char (1) unal, dim (0:31) char (2) unal, dim (0:31) fixed bin (71), fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  ioa_ entry options (variable);
dcl  edit_mos_rscr_ entry (ptr, char (*) var);

dcl (addr, unspec, substr) builtin;

	mem = "";
	store = "";
	data = 0;
	call phcs_$mos_memory_check (mem, store, data, code);
	if code ^= 0 then do;
	     call com_err_ (code, name);
	     return;
	end;

	do i = 0 to 31;
	     if mem (i) ^= "" then do;
		call edit_mos_rscr_ (addr (data (i)), descrip);
		call ioa_ ("mem ^a, store ^a: ^w ^a", mem (i), store (i), substr (unspec (data (i)), 37), descrip);
	     end;
	end;
	return;
     end poll_mos_memory;




		    print_configuration_deck.pl1    01/26/88  1338.4rew 01/26/88  1329.1      139671



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




/****^  HISTORY COMMENTS:
  1) change(87-06-23,Fawcett), approve(87-06-23,MCR7700),
     audit(87-06-23,Dickson), install(87-07-17,MR12.1-1042):
     Changed to display the negative numeric values as negative integers,
     instead of very positive large numbers.
  2) change(88-01-01,Gilcrease), approve(88-01-19,MCR7830),
     audit(88-01-20,Parisek), install(88-01-26,MR12.2-1018):
               Fix bug where -control argument is ignored.
                                                   END HISTORY COMMENTS */


/* format: style3 */
print_configuration_deck:
pcd:
     proc;

/* **************************************************************************
   *   This routine displays the desired card images in the configuration   *
   *   deck.  It can be called as a command or active function with up to   *
   *   32 card selection arguments, as well as with up to 16 field          *
   *   specification groups to be matched or excluded.                      *
   *   							      *
   *   Coded 1981/1982 by Warren Johnson and Jim Homan.	                *
   *   Modified: 16 January 1983 by G. Palter to add -pathname control      *
   *      control argument					      *
   *   Modified 83 June 15  by Art Beattie to increase length of line       *
   *      displayed.                                                        *
   *   Modified: 09 September 1983 by B. Braun to fix -match and -pathname  *
   *      when it's a zero length seg (phx15746).			      *
   *   Modified: 01 February 1984 by Keith Loepere for -label	      *
   ************************************************************************** */

dcl	(argN, nargs, max_size, card_no, field_no)
			fixed bin;
dcl	(card_args, match_args, exclude_args)
			fixed bin;
dcl	(argl, rsl)	fixed bin (21);
dcl	code		fixed bin (35);
dcl	(argp, rsp)	ptr;
dcl	af_sw		bit (1);
dcl	card_found	bit (1);
dcl	cards		(32) char (4);		/* card names to select */
dcl	label_output	bit (1) aligned;
dcl	match_cards	(16, 14) char (8);
dcl	exclude_cards	(16, 14) char (8);
dcl	out		char (256) varying;		/* output line */
dcl	have_pathname	bit (1);
dcl	config_dirname	char (168);
dcl	config_ename	char (32);
dcl	stype		fixed bin (2);		/* segment type */
dcl	bitcnt		fixed bin (24);		/* bit count of config deck segment */

dcl	error_routine_	entry variable options (variable);
						/* either com_err_ or active_fnc_err_ */

dcl	arg		char (argl) based (argp);
dcl	rs		char (rsl) varying based (rsp);
dcl	config_card_field_in_ascii
			char (4) based;

dcl	(addr, char, divide, fixed, index, null, substr, hbound, rtrim, size, verify)
			builtin;

dcl	cleanup		condition;

dcl	cname		char (24) init ("print_configuration_deck") int static options (constant);

dcl	error_table_$badcall
			fixed bin (35) external;
dcl	error_table_$badopt fixed bin (35) external;
dcl	error_table_$bigarg fixed bin (35) external;
dcl	error_table_$noarg	fixed bin (35) external;
dcl	error_table_$not_act_fnc
			fixed bin (35) external;
dcl	error_table_$too_many_args
			fixed bin (35) external;
dcl	error_table_$zero_length_seg
			fixed bin (35) external;

dcl	active_fnc_err_	entry options (variable);
dcl	com_err_		entry options (variable);
dcl	config_deck_parse_$binary_to_ascii
			entry (ptr, char (256) var);
dcl	cv_oct_		entry (char (*)) returns (fixed bin (35));
dcl	cu_$af_return_arg	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin bin (35));
dcl	expand_pathname_	entry (char (*), char (*), char (*), fixed bin (35));
dcl	hcs_$status_mins	entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
dcl	initiate_file_	entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl	ioa_		entry options (variable);
dcl	ioa_$rsnnl	entry options (variable);
dcl	pathname_		entry (char (*), char (*)) returns (char (168));
dcl	requote_string_	entry (char (*)) returns (char (*));
dcl	terminate_file_	entry (ptr, fixed bin (24), bit (*), fixed bin (35));
%page;
%include config_deck;
%page;
%include access_mode_values;

%include terminate_file;
%page;
	call cu_$af_return_arg (nargs, rsp, rsl, code);
	if code = 0
	then do;
		error_routine_ = active_fnc_err_;
		af_sw = "1"b;
		rs = "";
	     end;
	else if code = error_table_$not_act_fnc
	then do;
		error_routine_ = com_err_;
		af_sw = "0"b;
	     end;
	else do;
		call com_err_ (code, cname);
		return;
	     end;

	cards (*), match_cards (*, *), exclude_cards (*, *) = "";
	card_args, match_args, exclude_args = 0;
	label_output = "0"b;
	have_pathname = "0"b;			/* will default to the live config deck */

/* Argument processing loop. */

	do argN = 1 to nargs by 1;			/* get arguments */
	     call cu_$arg_ptr (argN, argp, argl, code);
	     if code ^= 0
	     then do;
		     call error_routine_ (code, cname, "Error getting argument ^d.", argN);
		     return;
		end;
	     else ;
	     if arg = "-match"			/* -MATCH */
	     then do;
		     call pick_up_match_exclude ("-match", match_cards, match_args, argN, code);
		     if code ^= 0
		     then return;
		end;

	     else if arg = "-exclude" | arg = "-ex"	/* -EXCLUDE */
	     then do;
		     call pick_up_match_exclude ("-exclude", exclude_cards, exclude_args, argN, code);
		     if code ^= 0
		     then return;
		end;				/* end -EXCLUDE */

	     else if arg = "-label" | arg = "-lbl"	/* -LABEL */
	     then label_output = "1"b;
	     else if arg = "-no_label" | arg = "-nlbl"
	     then label_output = "0"b;

	     else if arg = "-pathname" | arg = "-pn"	/* -PATHNAME */
	     then do;
		     if argN = nargs
		     then do;
			     call error_routine_ (error_table_$noarg, cname,
				"Config deck pathname after ""-pathname"".");
			     return;
			end;
		     if have_pathname
		     then do;
			     call error_routine_ (error_table_$too_many_args, cname,
				"Only one pathname may be given.");
			     return;
			end;
		     argN = argN + 1;
		     call cu_$arg_ptr (argN, argp, argl, code);
		     if code ^= 0
		     then do;
			     call error_routine_ (code, cname, "Error getting argument ^d.", argN);
			     return;
			end;
		     call expand_pathname_ (arg, config_dirname, config_ename, code);
		     if code ^= 0
		     then do;
			     call error_routine_ (code, cname, "^a", arg);
			     return;
			end;
		     have_pathname = "1"b;		/* have a config deck pathname now */
		end;

	     else /* cannot be a control argument */
		if substr (arg, 1, 1) = "-"
	     then do;
		     call error_routine_ (error_table_$badopt, cname, arg);
		     return;
		end;
	     else do;				/* must be a card name argument */
		     card_args = card_args + 1;
		     if card_args > hbound (cards, 1)
		     then do;
			     call error_routine_ (error_table_$too_many_args, cname,
				"^/Only the first ^d card arguments will be used.", hbound (cards, 1));
			     card_args = hbound (cards, 1);
			     go to process;
			end;
		     else ;
		     if argl > 4
		     then code = error_table_$bigarg;
		     else if verify (arg, "abcdefghijklmnopqrstuvwxyz") > 0
		     then code = error_table_$badcall;
		     else code = 0;
		     if code ^= 0
		     then do;
			     call error_routine_ (code, cname, "^/Invalid card name specifier ^a.", arg);
			     return;
			end;
		     else cards (card_args) = arg;
		end;
	end;					/* end argument processing */

process:						/* begin processing */
	configp = null ();				/* for cleanup handler */

	on cleanup
	     begin;
		if have_pathname
		then if configp ^= null ()
		     then do;
			     call terminate_file_ (configp, 0, TERM_FILE_TERM, (0));
			     configp = null ();
			end;
	     end;

	if have_pathname
	then do;					/* explicit config deck pathname */
		call initiate_file_ (config_dirname, config_ename, R_ACCESS, configp, bitcnt, code);
		if code ^= 0
		then do;
			call error_routine_ (code, cname, "^a", pathname_ (config_dirname, config_ename));
			return;
		     end;
		if bitcnt = 0
		then do;
			call error_routine_ (error_table_$zero_length_seg, cname, "^a",
			     pathname_ (config_dirname, config_ename));
			return;
		     end;
	     end;

	else do;					/* use live config deck */
		configp = addr (config_deck$);
		call hcs_$status_mins (configp, stype, bitcnt, code);
		if code ^= 0
		then do;
			call error_routine_ (code, cname, "Cannot get bit count of config_deck.");
			return;
		     end;
	     end;

	max_size = divide (bitcnt, 36, 17, 0);		/* get size of config deck seg */
	config_n_cards = divide (max_size, size (config_card), 17, 0);
						/* get number of cards */
	config_max_cards = 128;			/* a guess */

/* Loop through config_deck examining each card. */

	card_found = "0"b;
	if af_sw
	then ;
	else call ioa_ ();

	do card_no = 1 by 1 to config_n_cards while (config_deck.cards (card_no).word ^= FREE_CARD_WORD);
	     cardp = addr (config_deck.cards (card_no));
	     if match_config_card ()
	     then do;				/* display or return this card */
		     card_found = "1"b;
		     if label_output
		     then call config_deck_parse_$binary_to_ascii (cardp, out);
		     else do;
			     call ioa_$rsnnl ("^a", out, (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_$rsnnl ("^a  ^a", out, (0), out,
					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_$rsnnl ("^a  ^o", out, (0), out,
					fixed (config_card.data_field (field_no),35,0));
				else if config_card.type_word.field_type (field_no) = CONFIG_DECIMAL_TYPE
				then call ioa_$rsnnl ("^a  ^d.", out, (0), out,
					fixed (config_card.data_field (field_no),35,0));
				else if config_card.type_word.field_type (field_no) = CONFIG_SINGLE_CHAR_TYPE
				then call ioa_$rsnnl ("^a  ^a", out, (0), out,
					substr ("abcdefgh", fixed (config_card.data_field (field_no),35,0), 1));
				else ;
			     end;
			end;
		     if af_sw
		     then rs = rs || requote_string_ ((out)) || " ";
		     else call ioa_ ("^a", out);
		end;
	     else ;
	end;

	if af_sw
	then rs = rtrim (rs, " ");
	else call ioa_ ("^[^;No cards meet the match fields specified.^/^]", card_found);

	if have_pathname
	then if configp ^= null ()
	     then do;
		     call terminate_file_ (configp, 0, TERM_FILE_TERM, (0));
		     configp = null ();
		end;

	return;
%page;
match_config_card:
     proc returns (bit (1));

dcl	(m, f, k, l)	fixed bin;
dcl	fields		(14) char (8);
dcl	(part_match, match, exclude)
			bit (1);

	match = "0"b;

	do m = 1 to card_args by 1 while (^match);
	     match = cards (m) = config_card.word;
	end;

	if match | card_args = 0
	then if match_args + exclude_args > 0
	     then ;
	     else return ("1"b);
	else return ("0"b);

	fields (*) = "";

	do f = 1 to config_card.type_word.n_fields by 1;	/* canonicalize card */
	     if config_card.type_word.field_type (f) = CONFIG_STRING_TYPE
	     then fields (f) = addr (config_card.data_field (f)) -> config_card_field_in_ascii;
	     else if config_card.type_word.field_type (f) = CONFIG_SINGLE_CHAR_TYPE
	     then fields (f) = substr ("abcdefgh", fixed (config_card.data_field (f)), 1);
	     else call ioa_$rsnnl ("^d.", fields (f), (0), fixed (config_card.data_field (f)));
	end;

	match = match_args = 0;

	do m = 1 to match_args by 1 while (^match);

	     do k = 1 by 1 while (match_cards (m, k) ^= "");
		part_match = "0"b;
		if index (match_cards (m, k), "*") > 0
		then l = index (match_cards (m, k), "*") - 1;
		else l = 8;

		do f = 1 to config_card.type_word.n_fields by 1 while (^part_match);
		     part_match = substr (match_cards (m, k), 1, l) = substr (fields (f), 1, l);
		end;

		if part_match
		then ;
		else go to match_skip;

	     end;

	     match = "1"b;

match_skip:
	end;

	if exclude_args = 0 | ^match
	then return (match);
	else exclude = exclude_args = 0;

	do m = 1 to exclude_args by 1 while (^exclude);

	     do k = 1 by 1 while (exclude_cards (m, k) ^= "");
		part_match = "0"b;
		if index (exclude_cards (m, k), "*") > 0
		then l = index (exclude_cards (m, k), "*") - 1;
		else l = 8;

		do f = 1 to config_card.type_word.n_fields by 1 while (^part_match);
		     part_match = substr (exclude_cards (m, k), 1, l) = substr (fields (f), 1, l);
		end;

		if part_match
		then ;
		else go to exclude_skip;

	     end;

	     exclude = "1"b;

exclude_skip:
	end;

	return (^exclude);

     end match_config_card;

%page;
pick_up_match_exclude:
     proc (match_exclude_name, match_exclude_cards, match_exclude_args, arg_no, code);

dcl	match_exclude_name	char (*);
dcl	match_exclude_cards (*, *) char (8);
dcl	match_exclude_args	fixed bin;
dcl	arg_no		fixed bin;
dcl	code		fixed bin (35);
dcl	end_arg		bit (1);
dcl	(j, k)		fixed bin;

	match_exclude_args = match_exclude_args + 1;
	if match_exclude_args > hbound (match_exclude_cards, 1)
	then do;
		code = error_table_$too_many_args;
		call error_routine_ (code, cname, "^/Only ^d ^a arguments allowed.", hbound (match_exclude_cards, 1),
		     match_exclude_name);
		return;
	     end;
	else if arg_no >= nargs
	then do;
		code = error_table_$noarg;
		call error_routine_ (code, cname, "^/Field specifiers must follow ^a argument.", match_exclude_name);
		return;
	     end;
	else ;
	end_arg = "0"b;
	k = 0;
	do j = arg_no + 1 to nargs by 1 while (^end_arg);
	     k = k + 1;
	     call cu_$arg_ptr (j, argp, argl, code);
	     if code ^= 0
	     then do;
		     call error_routine_ (code, cname, "^/Error processing argument ^d; following ^a.", j,
			match_exclude_name);
		     return;
		end;
	     else arg_no = arg_no + 1;
	     if arg = "-match" | arg = "-exclude" | arg = "-ex"
	     then do;
		     end_arg = "1"b;
		     arg_no = arg_no - 1;
		     if k = 1			/* check if anything followed -match */
		     then do;
			     code = error_table_$noarg;
			     call error_routine_ (code, cname, "^/Field specifiers must follow ^a argument.",
				match_exclude_name);
			     return;
			end;
		     else ;
		end;
	     else if substr (arg, 1, 1) = "-"
	     then arg_no = arg_no - 1;		/* assume a control arg, skip */
	     else do;
		     if k > hbound (match_exclude_cards, 2)
		     then do;
			     code = error_table_$too_many_args;
			     call error_routine_ (code, cname, "^/Too many fields specified following ^a.",
				match_exclude_name);
			     return;
			end;
		     else if verify (arg, "01234567") = 0
		     then call ioa_$rsnnl ("^d.", match_exclude_cards (match_exclude_args, k), (0), cv_oct_ (arg));
		     else if char (arg, 1) ^= "*"
		     then match_exclude_cards (match_exclude_args, k) = arg;
		     else do;
			     code = error_table_$badcall;
			     call error_routine_ (code, cname, "^/Illegal field specifier ^a.", arg);
			     return;
			end;
		end;
	end;
     end pick_up_match_exclude;

     end print_configuration_deck;




		    print_tuning_parameters.pl1     11/15/82  1908.1rew 11/15/82  1453.7       55593



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


print_tuning_parameters:
print_tuning_parameter:
ptp:
	procedure () options (variable);

/* Completely rewritten, for hc_tune, 27 June 1981, W. Olin Sibert */
/* Modified September 1981 by J. Bongiovanni for linkage_error condition */

dcl  argno fixed bin;
dcl  nargs fixed bin;
dcl  al fixed bin (21);
dcl  ap pointer;
dcl  arg char (al) based (ap);
dcl  code fixed bin (35);
dcl  idx fixed bin;

dcl  tp_type fixed bin;
dcl  tp_value bit (36) aligned;
dcl  tp_ptr pointer;
dcl  tp_name char (32);
dcl  tp_short_name char (32);

dcl  special_sw bit (1) aligned;
dcl  long_sw bit (1) aligned;
dcl  have_names bit (1) aligned;

dcl 1 tp_list (tp_list_size) aligned like tp_info based (tp_list_ptr);
dcl  tp_list_ptr pointer;
dcl  tp_list_size fixed bin;
dcl  tp_list_area_ptr pointer;

dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, pointer, fixed bin (21), fixed bin (35));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  ioa_ entry options (variable);
dcl  metering_gate_$get_tuning_parameter entry
    (char (*), fixed bin, bit (36) aligned, pointer, char (*), char (*), fixed bin (35));
dcl  metering_gate_$list_tuning_parameters entry
    (pointer, bit (1) aligned, fixed bin, pointer);

dcl  error_table_$badopt fixed bin (35) external static;

dcl  WHOAMI char (32) internal static options (constant) init ("print_tuning_parameters");

dcl  (cleanup, linkage_error) condition;

dcl (addr, char, null) builtin;

/*  */

	call cu_$arg_count (nargs, code);
	if code ^= 0 then do;
	     call com_err_ (code, WHOAMI);
	     return;
	     end;

	special_sw = "0"b;				/* Initialize flags */
	long_sw = "0"b;
	have_names = "0"b;
	tp_list_ptr = null ();

	do argno = 1 to nargs;
	     call cu_$arg_ptr (argno, ap, al, (0));

	     if (arg = "-short") | (arg = "-sh") then long_sw = "0"b;
	     if (arg = "-long") | (arg = "-lg") then long_sw = "1"b;
	     else if (arg = "-special") | (arg = "-all") | (arg = "-a") then special_sw = "1"b;
	     else if (char (arg, 1) = "-") then do;
		call com_err_ (error_table_$badopt, WHOAMI, "^a", arg);
		return;
		end;
	     else have_names = "1"b;
	     end;

	on condition (cleanup) begin;
	     if tp_list_ptr ^= null () then free tp_list;
	     end;

	on condition (linkage_error) begin;
	     call com_err_ (0, WHOAMI, "This routine requires access to metering_gate_");
	     goto main_return;
	end;
	

/*  */

	if ^have_names then do;			/* Must list them all */
	     tp_list_area_ptr = get_system_free_area_ ();
	     call metering_gate_$list_tuning_parameters (tp_list_area_ptr, special_sw, tp_list_size, tp_list_ptr);

	     call ioa_ ("Current system tuning parameters:^/");

	     do idx = 1 to tp_list_size;
		tp_name = tp_list (idx).long_name;
		tp_short_name = tp_list (idx).short_name;
		tp_value = tp_list (idx).value;
		tp_ptr = tp_list (idx).ptr;
		tp_type = tp_list (idx).type;

		call print ();			/* Print this one */
		end;

	     call ioa_ ("");
	     end;

	else do;					/* List individual values */
	     do argno = 1 to nargs;
		call cu_$arg_ptr (argno, ap, al, (0));
		if (char (arg, 1) ^= "-") then do;
		     tp_name = arg;
		     call metering_gate_$get_tuning_parameter
			(tp_name, tp_type, tp_value, tp_ptr, tp_name, tp_short_name, code);
		     if code = 0 then
			call print ();
		     else call com_err_ (code, WHOAMI, "^a", tp_name);
		     end;
		end;
	     end;

main_return:   
	if tp_list_ptr ^= null () then free tp_list;

	return;

/*  */

print: proc ();

/* This procedure prints the value for a single tuning parameter. */

dcl  char_value char (4) aligned;
dcl  scaled_value fixed bin (35, 18);
dcl  binary_value fixed bin (35);
dcl  float_value float bin (27);

	unspec (char_value) = tp_value;
	unspec (scaled_value) = tp_value;
	unspec (binary_value) = tp_value;
	unspec (float_value) = tp_value;

	if ^long_sw then do;
	     if tp_type = TP_CHAR then
		call ioa_ ("^a^28t""^a""", tp_name, char_value);

	     else if tp_type = TP_INTEGER then
		call ioa_ ("^a^28t^d", tp_name, binary_value);

	     else if tp_type = TP_SCALED_INTEGER then
		call ioa_ ("^a^28t^f", tp_name, round (decimal (scaled_value), 4));

	     else if tp_type = TP_MICROSECONDS then
		call ioa_ ("^a^28t^f seconds", tp_name, (float (binary_value) / 1.0e6));

	     else if tp_type = TP_ON_OFF then
		call ioa_ ("^a^28t^[on^;off^]", tp_name, (binary_value ^= 0));

	     else if tp_type = TP_FLOAT then
		call ioa_ ("^a^28t^f", tp_name, float_value);

	     else call ioa_ ("^a^28t^w", tp_name, tp_value);
	     end;

	else do;
	     if tp_type = TP_CHAR then
		call ioa_ ("^a^28t^a^40t""^a""^52t(^p)",
		     tp_name, tp_short_name, char_value, tp_ptr);

	     else if tp_type = TP_INTEGER then
		call ioa_ ("^a^28t^a^40t^d^52t(^p)",
		     tp_name, tp_short_name, binary_value, tp_ptr);

	     else if tp_type = TP_SCALED_INTEGER then
		call ioa_ ("^a^28t^a^40t^f^52t(^p)",
		     tp_name, tp_short_name, round (decimal (scaled_value), 4), tp_ptr);

	     else if tp_type = TP_MICROSECONDS then
		call ioa_ ("^a^28t^a^40t^f seconds^52t(^p)",
		     tp_name, tp_short_name, (float (binary_value) / 1.0e6), tp_ptr);

	     else if tp_type = TP_ON_OFF then
		call ioa_ ("^a^28t^a^40t^[on^;off^]^52t(^p)",
		     tp_name, tp_short_name, (binary_value ^= 0), tp_ptr);

	     else if tp_type = TP_FLOAT then
		call ioa_ ("^a^28t^a^40t^f^52t(^p)",
		     tp_name, tp_short_name, float_value, tp_ptr);
					     

	     else call ioa_ ("^a^28t^a^40t^w^52t(^p)",
		     tp_name, tp_short_name, tp_value, tp_ptr);
	     end;

	return;
	end print;

%page; %include tuning_parameter_info;

	end print_tuning_parameters;




		    set_mos_polling_time.pl1        11/15/82  1908.1rew 11/15/82  1526.8       16398



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


/* SET_MOS_POLLING_TIME: Command which sets or prints the mos memory polling interval for EDAC errors. */

/* Written May 1976 by Larry Johnson */

set_mos_polling_time: proc;

dcl  time fixed bin;
dcl  i fixed bin;
dcl  arg_ptr ptr;
dcl  arg_len fixed bin;
dcl  arg char (arg_len) based (arg_ptr);
dcl  code fixed bin (35);
dcl  name char (20) int static options (constant) init ("set_mos_polling_time");
dcl  readsw bit (1);

dcl  ioa_ entry options (variable);
dcl  com_err_ entry options (variable);
dcl  hphcs_$set_mos_polling_time entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin) returns (fixed bin (35));

	call cu_$arg_ptr (1, arg_ptr, arg_len, code);
	if code ^= 0 then time = -1;			/* this asks to return time */
	else do;
	     time = cv_dec_check_ (arg, i);
	     if i ^= 0 then do;
		call com_err_ (0, name, "Invalid time: ^a", arg);
		return;
	     end;
	     if time < 0 then time = -1;
	end;
	readsw = (time = -1);			/* set if doing read */

	call hphcs_$set_mos_polling_time (time);
	if readsw then do;
	     if time = 0 then call ioa_ ("MOS polling is disabled.");
	     else call ioa_ ("MOS polling time interval is ^d minute^v(s^).", time, bin (time ^= 1, 1));
	end;
	return;

     end set_mos_polling_time;




		    set_proc_required.pl1           08/18/87  1518.3rew 08/18/87  1500.0       72450



/****^  ***********************************************************
        *                                                         *
        * 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(81-10-01,Bongiovanni), approve(), audit(), install():
     Pre-hcom comments.
     Written October 1981 by J. Bongiovanni.
  2) change(87-01-14,Lippard), approve(87-02-09,MCR7616),
     audit(87-06-03,Farley), install(87-08-06,MR12.1-1064):
     Modified to use hcs_$set_procs_required.
  3) change(87-08-08,Lippard), approve(87-02-09,PBF7616),
     audit(87-08-11,Farley), install(87-08-18,MR12.1-1090):
     Modified to use hcs_$get_procs_required and
     phcs_$get_system_procs_required.
                                                   END HISTORY COMMENTS */


/* format: style3 */
set_proc_required:
sprq:
     proc;

/*     set_proc_required, list_proc_required

       Program to set and list either the set of CPUs on which this process may
       run, or the system default set of CPUs.
       
       Usage:
       
       set_proc_required {tag1} ... {tagN} {-control_args}
       
            If no CPU tags are specified, the current system default is used.
            
	  -priv sets the system default
       
       list_proc_required {-control_args}
       
            -priv lists the current system default
            
            May be invoked as an active function
*/

/* Automatic */

dcl	af_entry		bit (1);			/* ON => called as active function */
dcl	af_ret_maxl	fixed bin (21);		/* max length of active function return arg */
dcl	af_ret_ptr	ptr;			/* pointer to active function return arg */
dcl	arg_no		fixed bin;		/* current argument number */
dcl	argc		fixed bin (21);		/* character index into current arg */
dcl	argl		fixed bin (21);		/* current argument length */
dcl	argp		ptr;			/* current argument pointer */
dcl	code		fixed bin (35);		/* standard error code */
dcl	gate_entry	entry (bit (8) aligned, fixed bin (35)) variable;
						/* gate to call for set */
dcl	my_name		char (32);		/* name of this command */
dcl	n_args		fixed bin;		/* number of arguments */
dcl	new_cpu_string	bit (8) aligned;		/* bit string for set */
dcl	new_is_default	bit (1) aligned;		/* ON => process CPUs required is system default after set */
dcl	old_cpu_string	bit (8) aligned;		/* former (or current) bit string */
dcl	old_is_default	bit (1) aligned;		/* ON => process CPUs required is system default before set */
dcl	priv_sw		bit (1);			/* ON => -priv given */
dcl	set_entry		bit (1);			/* ON => set_proc_required */

/* Static */

dcl	CPU_TAGS		char (16) int static options (constant) init ("ABCDEFGHabcdefgh");

/* Based */

dcl	af_ret		char (af_ret_maxl) varying based (af_ret_ptr);
dcl	arg		char (argl) based (argp);

/* Entry */

dcl	check_gate_access_	entry (char (*), ptr, fixed bin (35));
dcl	com_err_		entry options (variable);
dcl	cu_$af_return_arg	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl	hcs_$get_procs_required
			entry (bit (8) aligned, bit (1) aligned, fixed bin (35));
dcl	hcs_$set_procs_required
			entry (bit (8) aligned, fixed bin (35));
dcl	hphcs_$set_system_procs_required
			entry (bit (8) aligned, fixed bin (35));
dcl	ioa_		entry options (variable);
dcl	phcs_$get_system_procs_required
			entry (bit (8) aligned);

/* External */

dcl	error_table_$active_function
			fixed bin (35) external;
dcl	error_table_$badopt fixed bin (35) external;
dcl	error_table_$noarg	fixed bin (35) external;

/* Builtin */

dcl	char		builtin;
dcl	codeptr		builtin;
dcl	index		builtin;
dcl	length		builtin;
dcl	mod		builtin;
dcl	substr		builtin;
dcl	verify		builtin;
%page;
	set_entry = "1"b;
	my_name = "set_proc_required";
	goto COMMON;

list_proc_required:
     entry;

	set_entry = "0"b;
	my_name = "list_proc_required";

COMMON:
	af_entry = "0"b;

	call cu_$af_return_arg (n_args, af_ret_ptr, af_ret_maxl, code);
						/* find out if we're an active function */
	if code = 0
	then /* active function */
	     if set_entry
	     then do;				/* not allowed for set_proc_required */
		     call com_err_ (error_table_$active_function, my_name);
		     return;
		end;
	     else af_entry = "1"b;

	new_cpu_string = "0"b;
	new_is_default = "0"b;
	old_is_default = "0"b;
	priv_sw = "0"b;

	do arg_no = 1 to n_args;
	     call cu_$arg_ptr (arg_no, argp, argl, code);
	     if char (arg, 1) = "-"
	     then do;
		     if arg = "-priv"
		     then priv_sw = "1"b;
		     else do;
BAD_OPT:
			     call com_err_ (error_table_$badopt, my_name, arg);
			     return;
			end;
		end;
	     else do;				/* Probably CPU tag */
		     if ^set_entry
		     then goto BAD_OPT;		/* list_proc_required doesn't take CPU tag */
		     if verify (arg, CPU_TAGS) ^= 0
		     then do;
			     call com_err_ (0, my_name, "Invalid CPU Tag(s) ^a", arg);
			     return;
			end;
		     do argc = 1 to argl;
			substr (new_cpu_string, mod (index (CPU_TAGS, substr (arg, argc, 1)) - 1, 8) + 1, 1) = "1"b;
		     end;
		end;
	end;


	if set_entry & priv_sw & (new_cpu_string = "0"b)
	then do;					/* CPU tags must be supplied with -priv */
		call com_err_ (error_table_$noarg, my_name, "CPU tag(s)");
		return;
	     end;

	if priv_sw
	then do;
		call check_gate_access_ ("phcs_", codeptr (set_proc_required), code);
		if code ^= 0
		then do;
			call com_err_ (code, my_name, "phcs_");
			return;
		     end;

		if set_entry
		then do;
			call check_gate_access_ ("hphcs_", codeptr (set_proc_required), code);
			if code ^= 0
			then do;
				call com_err_ (code, my_name, "hphcs_");
				return;
			     end;
		     end;

		call phcs_$get_system_procs_required (old_cpu_string);
	     end;
	else do;
		call hcs_$get_procs_required (old_cpu_string, old_is_default, code);

		if code ^= 0
		then do;
			call com_err_ (code, my_name, "set_proc_required.acs");
			return;
		     end;
	     end;

	if set_entry
	then do;					/* set_proc_required */
		if priv_sw
		then gate_entry = hphcs_$set_system_procs_required;
		else gate_entry = hcs_$set_procs_required;

		call gate_entry (new_cpu_string, code);
		if code ^= 0
		then do;
			call com_err_ (code, my_name);
			return;
		     end;

		if priv_sw
		then call phcs_$get_system_procs_required (new_cpu_string);
		else do;
			call hcs_$get_procs_required (new_cpu_string, new_is_default, code);

			if code ^= 0
			then do;
				call com_err_ (code, my_name, "set_proc_required.acs");
				return;
			     end;
		     end;

		call ioa_ ("^a: ^[System ^;^]CPUs required changed from ^a^[ (default)^;^] to ^a^[ (default)^;^]",
		     my_name, priv_sw, cpu_tags (old_cpu_string), (old_is_default), cpu_tags (new_cpu_string),
		     (new_is_default));
	     end;
	else do;					/* list_proc_required */
		if af_entry
		then /* active function */
		     af_ret = cpu_tags (old_cpu_string);
		else call ioa_ ("^a: ^[System ^;^]CPUs Required: ^a^[ (default)^;^]", my_name, priv_sw,
			cpu_tags (old_cpu_string), (old_is_default));
	     end;

	return;
%page;
/*     Internal procedure to convert a bit string to a character string
       of CPU tags */

cpu_tags:
     proc (cpu_string) returns (char (*));

dcl	cpu_string	bit (8) aligned;		/* cpu string */

dcl	cpu_ix		fixed bin;
dcl	cpu_tag_string	char (8) varying;

	cpu_tag_string = "";
	do cpu_ix = 1 to length (cpu_string);
	     if substr (cpu_string, cpu_ix, 1)
	     then cpu_tag_string = cpu_tag_string || substr (CPU_TAGS, cpu_ix, 1);
	end;

	return (cpu_tag_string);


     end cpu_tags;
%page;
%include apte;

     end set_proc_required;




		    set_work_class.pl1              07/13/88  1141.3r w 07/13/88  0938.5       73575



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

/* Coded by RE Mullen, Spring 1975, for priority scheduler */
/* Modified by E. N. Kittlitz. March 1982, for user_table conversion, code cleanup. */


/****^  HISTORY COMMENTS:
  1) change(87-04-26,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-27,Hartogs), install(87-08-04,MR12.1-1055):
      A) Upgraded for change to answer_table.incl.pl1 and
         user_table_entry.incl.pl1.
      B) Support newly-added instance tags.
                                                   END HISTORY COMMENTS */


dcl  Person char (32);
dcl  Project char (32);
dcl  Tag char (32);
dcl  ac fixed bin;
dcl  al fixed bin (21);
dcl  ap ptr;
dcl  code fixed bin (35);
dcl  found fixed bin;
dcl  i fixed bin;
dcl  oldwcnum fixed bin;
dcl  pid bit (36) aligned;
dcl  wcnum fixed bin;

dcl  arg char (al) based (ap);

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 (21), fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  get_process_id_ entry returns (bit (36) aligned);
dcl  hphcs_$set_process_work_class entry (bit (36) aligned, fixed bin, fixed bin, fixed bin (35));
dcl  pathname_ entry (char (*), char (*)) returns (char (168));

dcl  error_table_$bad_conversion ext static fixed bin (35);
dcl  error_table_$bad_work_class ext static fixed bin (35);
dcl  error_table_$zero_length_seg ext static fixed bin (35);

dcl  ME char (14) internal static options (constant) init ("set_work_class");
dcl  sysdir char (168) int static init (">system_control_1");

dcl  (addr, after, before, bin, bit, index, length, null, rtrim) builtin;

dcl  cleanup condition;
dcl  linkage_error condition;


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

/* Usage: swc wc_num id
   where id identifies the proccess to be move to work_class [wc_num]

   if id is not given only the process executing the command will be moved.
   else if id is an octal number then the process with that processid will be moved.
   else if id is of form [pers.proj.tag] then processes with matching names will be moved.
   else error.

   The Initializer is never moved unless the user of this command is
   clever enough to specify the Initializer's processid, or is Izzy hisself.

   Because this command does not modify the MGT, the move will
   will last only until the next shift change or new_proc or  .. */


	ansp, autp, dutp = null ();			/* initialize */
	found = 0;
	call cu_$arg_count (ac, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME);
	     return;
	end;

/* Establish handler for noaccess on hphcs_ */

	on linkage_error
	     begin;
		call com_err_ (0, ME, "This command requires access to hphcs_.");
		go to MAIN_RETURN;
	     end;
	on cleanup call CLEANUP;

/* Set work class of self | octal_processid | Per.Proj.tag */

	if (ac = 0) | (ac > 2) then do;
	     call com_err_$suppress_name (0, ME, "Usage: set_work_class wc_number pers.proj.tag");
	     return;
	end;

	call cu_$arg_ptr (1, ap, al, (0));
	wcnum = cv_dec_check_ (arg, code);
	if code ^= 0 then do;
	     call com_err_ (error_table_$bad_conversion, ME, "The first argument must be a workclass number, not ""^a"".", arg);
	     return;
	end;

	if ac = 1 then do;				/* means to set own */
	     pid = get_process_id_ ();
	     call SET_IT;
	     go to MAIN_RETURN;
	end;					/* done setting own */
	else do;
	     call cu_$arg_ptr (2, ap, al, (0));
	     pid = bit (bin (cv_oct_check_ (arg, code), 36), 36);
	     if code = 0 then do;			/* must be octal processid */
		call SET_IT;
		go to MAIN_RETURN;
	     end;
	     else do;				/* must be Person.Project.Tag */
		Person = before (arg, ".");
		Project = before (after (arg, "."), ".");
		Tag = after (after (arg, "."), ".");
		if (index (Tag, ".") > 0) |
		     (Person = "") |
		     (Project = "") |
		     al > length (Person) |
		     index ("ampz*", rtrim (Tag)) = 0 then do;
		     call com_err_ (0, ME, "Illegal syntax in process identifier ^a.", arg);
		     return;
		end;

/* Loop over all the user tables that may contain such a user. */

		call INIT ("answer_table", ansp);	/* need ansp no matter what */
		if Tag = "*" | Tag = "a" |		/* interactive   */
		     Tag = "f" then do;		/* DSA file xfer */
		     do i = 1 to anstbl.current_size;
			utep = addr (anstbl.entry (i));
			call CHECK_IT;
		     end;
		end;

		if Tag = "*" | Tag = "z" then do;
		     call INIT ("daemon_user_table", dutp);
		     do i = 1 to dutbl.current_size;
			utep = addr (dutbl.entry (i));
			call CHECK_IT;
		     end;
		end;

		if Tag = "*" | Tag = "g" |		/* Gcos simulator*/
		     Tag = "m" |			/* absentee job  */
		     Tag = "n" |			/* Cray software */
		     Tag = "p" then do;		/* Proxy absentee*/
		     call INIT ("absentee_user_table", autp);
		     do i = 1 to autp -> autbl.current_size;
			utep = addr (autp -> autbl.entry (i));
			call CHECK_IT;
		     end;
		end;
		if found = 0 then call com_err_ (0, ME, "No users match ^a.^a.^a", Person, Project, Tag);
	     end;					/* for now */

	end;
MAIN_RETURN:
	call CLEANUP;
	return;


CLEANUP: proc;

do_one_seg: proc (a_segp);

dcl  a_segp ptr;
dcl  terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));

	     if a_segp = null () then return;
	     call terminate_file_ (a_segp, 0, TERM_FILE_TERM, (0));
	end do_one_seg;

	call do_one_seg (ansp);
	call do_one_seg (autp);
	call do_one_seg (dutp);
     end CLEANUP;


CHECK_IT:
     proc;					/* see if user table entry needs work class set */

	if ute.active < NOW_HAS_PROCESS then return;
	if ute.proc_id = anstbl.as_procid then return;	/* I will not be a party to this */
	if Person = "*" then ;			/* Star Person */
	else if Person = ute.person then ;		/* Person matches */
	else if Person ^= "anonymous" then return;	/* nomatch & not want anon */
	else if ute.anonymous ^= 0 then ;		/* found wanted anon */
	else return;

	if Project = "*" then ;			/* Star Project */
	else if Project = ute.project then ;		/* Project matches */
	else return;

	pid = ute.proc_id;				/* set pid for call */
	call SET_IT;

     end CHECK_IT;


SET_IT:
     proc;					/* set one processes work class */

	call hphcs_$set_process_work_class (pid, wcnum, oldwcnum, code);
	if code = 0 then do;
	     found = found + 1;
	end;
	else if code = error_table_$bad_work_class then do;
	     call com_err_ (code, ME, "^d", wcnum);
	     go to MAIN_RETURN;
	end;
	else call com_err_ (code, ME, "Process id ^12.3b", pid);
     end SET_IT;


INIT:
     proc (i_ename, i_segp);

dcl  i_ename char (32);
dcl  i_segp pointer;
dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));

	call initiate_file_ (sysdir, i_ename, R_ACCESS, i_segp, (0), code);
	if code ^= 0 & code ^= error_table_$zero_length_seg then do;
	     call com_err_ (code, ME, "^a", pathname_ (sysdir, i_ename));
	     go to MAIN_RETURN;
	end;
     end INIT;


init:
     entry;

	call cu_$arg_ptr (1, ap, al, code);
	if code = 0 then sysdir = arg;

	return;

 %include absentee_user_table;
 %include access_mode_values;
 %include answer_table;
 %include daemon_user_table;
 %include dialup_values;
 %include terminate_file;
 %include user_attributes;
 %include user_table_entry;
 %include user_table_header;

     end set_work_class;




		    tune_disk.pl1                   10/02/90  1420.2rew 10/02/90  1419.4       57663



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



/****^  HISTORY COMMENTS:
  1) change(90-08-07,Vu), approve(90-08-07,MCR8189),
     audit(90-09-24,WAAnderson), install(90-10-02,MR12.4-1036):
     Error message from tune_disk without arguments is malformed.
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
tune_disk:
td:
     proc;

/* User level procedure to control the tuning of the disk system. */

/* Created 84-05-23, by T. Oke */
/* Auditting changes by Chris Jones, August 1984 */

dcl	arg		   char (arg_len) based (arg_ptr);
dcl	arg_count		   fixed bin;
dcl	arg_index		   fixed bin;
dcl	arg_len		   fixed bin (21);
dcl	arg_list_ptr	   ptr;
dcl	arg_ptr		   ptr;

dcl	brief		   bit (1) initial ("1"b);
dcl	code		   fixed bin (35);
dcl	i		   fixed bin;
dcl	MYNAME		   char (9) static options (constant) initial ("tune_disk");
dcl	prev_arg		   char (256) varying;
dcl	reason		   char (64) varying;
dcl	stagnate		   fixed bin (35);
dcl	time		   float bin (27);


dcl	1 o		   like opt_info_tune;
dcl	1 s		   like sys_info_tune;

dcl	error_table_$bad_arg   fixed bin (35) ext;
dcl	error_table_$noarg	   fixed bin (35) ext;

dcl	cu_$arg_count_rel	   entry (fixed bin, ptr, 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	com_err_		   entry () options (variable);
dcl	hphcs_$disk_tune	   entry (char (*), ptr, char (*) varying, fixed bin (35));
dcl	ioa_		   entry () options (variable);

dcl       (addr, after, before, bin, float, null, substr) builtin;

dcl	conversion	   condition;

/* Get arguments. */

	on conversion goto bad_arg;

	call cu_$arg_list_ptr (arg_list_ptr);
	call init_args;

	if ^get_next_arg () then do;
	     call ioa_ (
		"Usage:^a drive_name io_type -load n -response m -or-^/^a reset_max -or-^/^a reset_sys -or-^/^a stagnate seconds -or-^/^a system io_type -max n -map io_type"
		, MYNAME, MYNAME, MYNAME, MYNAME, MYNAME);

	     call ioa_ ("     io_type is one of: ^(^a ^)", io_name);
	     return;
	end;

	else if arg = "reset_max" | arg = "reset_sys" then do;
	     call hphcs_$disk_tune (arg, null (), reason, code);
	     if code ^= 0 then
		goto print_code;
	     return;
	end;
	else if arg = "stagnate" then do;
	     if ^get_next_arg () then
		goto no_arg;
	     time = float (arg);
	     stagnate = time * 1000000.0;
	     if stagnate < 0 | stagnate > 360000000 then do;
		call com_err_ (error_table_$bad_arg, MYNAME, "0 <= stagnate time <= 6 minutes.");
		return;
	     end;

	     call hphcs_$disk_tune (STAGNATE_TIME, addr (stagnate), reason, code);
	     if code ^= 0 then
		goto print_code;
	     return;
	end;

	else if arg = "system" then do;
	     s.type = get_io_type ();
	     s.max_depth, s.map = -1;
sys_arg_loop:
	     if ^get_next_arg () then
		goto sys_arg_done;
	     if arg = "-max" then do;			/* sys max_load */
		if ^get_next_arg () then
		     goto no_arg;
		s.max_depth = bin (arg, 35);
		goto sys_arg_loop;
	     end;
	     else if arg = "-map" then do;		/* sys depth map */
		s.map = get_io_type ();
		goto sys_arg_loop;
	     end;
	     goto bad_arg;

sys_arg_done:
	     if s.map < 0 & s.max_depth < 1 then
		return;				/* nothing modified */

	     call hphcs_$disk_tune (SYS_TUNE, addr (s), reason, code);
	     if code ^= 0 then
		goto print_code;
	     return;
	end;

	else if arg_len > 5 then
	     if substr (arg, 1, 3) = "dsk" & substr (arg, 5, 1) = "_" then do;
						/* sub-system */
		o.sub_sys = before (arg, "_");	/* sub_sys name */
		o.dev = bin (after (arg, "_"), 17);	/* device number */
		o.type = get_io_type ();		/* io type to tune */
		o.load, o.response = -1;

opt_arg_loop:
		if ^get_next_arg () then
		     goto opt_arg_done;
		if arg = "-load" | arg = "-ld" then do; /* load limit */
		     if ^get_next_arg () then
			goto no_arg;
		     o.load = bin (arg, 17);
		     goto opt_arg_loop;
		end;
		else if arg = "-response" | arg = "-rsp" then do;
						/* response */
		     if ^get_next_arg () then
			goto no_arg;
		     o.response = bin (arg, 35);
		     goto opt_arg_loop;
		end;
		goto bad_arg;

opt_arg_done:
		if o.load < 1 then do;
		     call com_err_ (error_table_$noarg, MYNAME, "-load must be specified and >1.");
		end;

		if o.response < 1 then do;
		     call com_err_ (error_table_$noarg, MYNAME, "-response must be specified and >1.");
		end;
		if o.response < 1 | o.load < 1 then
		     return;

		call hphcs_$disk_tune (OPT_TUNE, addr (o), reason, code);
		if code ^= 0 then
		     goto print_code;
		return;
	     end;
	goto bad_arg;

exit:
	return;

no_arg:
	call com_err_ (error_table_$noarg, MYNAME, "after " || prev_arg);
	return;

bad_arg:
	call com_err_ (error_table_$bad_arg, MYNAME, arg);
	return;

print_code:
	call com_err_ (code, MYNAME, "Reason given is ""^a"".", reason);
	return;

/* initialize argument processing. */

init_args:
     proc;

dcl	code		   fixed bin (35);

	arg_index = 1;
	call cu_$arg_count_rel (arg_count, arg_list_ptr, code);
	if code ^= 0 then
	     arg_count = 0;
	return;

/* Get next arguments.  Returns "0"b if failure. */

get_next_arg:
     entry returns (bit (1));

	if arg_index <= 1 then
	     prev_arg = "";
	else prev_arg = arg;

	if arg_index <= arg_count then do;
	     call cu_$arg_ptr_rel (arg_index, arg_ptr, arg_len, code, arg_list_ptr);
	     if code = 0 then do;
		arg_index = arg_index + 1;
		return ("1"b);			/* success */
	     end;
	end;
	return ("0"b);				/* no argument */


get_io_type:
     entry returns (fixed bin);

	if ^get_next_arg () then
	     goto no_arg;

	if arg = "test" then do;
	     call com_err_ (error_table_$bad_arg, MYNAME, "Cannot set TEST parms.");
	     goto exit;
	end;

	do i = 0 to MAX_IO_NAME;
	     if arg = io_name (i) then
		return (i);
	end;
	call com_err_ (error_table_$bad_arg, MYNAME, "Unknown IO type " || arg || ".");
	goto exit;

     end init_args;

%include disk_tune;
     end tune_disk;




		    tune_work_class.pl1             11/15/82  1908.1rew 11/15/82  1453.7       50877



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


tune_work_class: twc: proc;

/* Coded by RE Mullen Winter '76 */
/* Recoded  RE Mullen Autumn '76 */
/* Modified by M.Pierret 29 October '80 to accept -pin_weight */
/* Modified by J. Bongiovanni June 1981 for governed */
/* Modified by J. Bongiovanni May 1982 for int_queue */

dcl  linkage_error condition;

dcl 1 wctu aligned like work_class_tune_info;

dcl  onf bit (1) aligned;
dcl  f float bin;
dcl  d fixed bin;
dcl  i fixed bin;

dcl  me char (16) aligned internal static options (constant) init ("tune_work_class");

dcl  nargs fixed bin;
dcl  arg char (al) based (ap);
dcl  ap ptr;
dcl  al fixed bin;
dcl  ca char (16) aligned;				/* control arg copied here */

dcl  hphcs_$tune_work_class entry (ptr, fixed bin (35));
dcl  cu_$arg_count entry returns (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cv_float_ entry (char (*), fixed bin (35)) returns (float bin);
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl (com_err_, ioa_) entry options (variable);
dcl  error_table_$noarg ext static fixed bin (35);

dcl  code fixed bin (35);

dcl  (addr, substr, unspec) builtin;
		  


	unspec (wctu) = ""b;
	wctu.wc_number = -1;			/* If unchanged, user has blundered */
	wctu.version = WCTI_version_3;		/* tell hardcore our vintage */

	nargs = cu_$arg_count ();
	if nargs = 0 then do;			/* the hint convention */

	     call ioa_ ("Usage: tune_work_class -work_class NN param_1 value_1 ..");
	     call ioa_ ("   value in seconds: int_response int_quantum response quantum");
	     call ioa_ ("   value on/off: realtime post_purge io_priority int_queue");
	     call ioa_ ("   integer value: wc_max_eligible pin_weight");
	     call ioa_ ("   governed: off or percent");
	     return;
	end;

	do i = 1 by 2 while (i <= nargs);
						/* pick up parameter name */
	     call cu_$arg_ptr (i, ap, al, code);
	     if code ^= 0 then do;
ERR:
		call com_err_ (code, me, " ");
		return;
	     end;

	     if al = 0 then go to BAD_PARM;
	     if substr (arg, 1, 1) = "-" then do;
		ca = substr (arg, 2, al-1);
	     end;
	     else ca = arg;


/* pick up parameter value */
	     call cu_$arg_ptr (i+1, ap, al, code);
	     if code ^= 0 then go to NOARG;

	     if ca = "wc" | ca = "work_class" then do;
		call fix;
		wctu.wc_number = d;
	     end;
	     else if ca = "ir" | ca = "int_response" then do;
		wctu.set.resp1 = "1"b;
		call flo;
		wctu.resp1 = 1e6 * f;
	     end;
	     else if ca = "r" | ca = "response" then do;
		wctu.set.resp2 = "1"b;
		call flo;
		wctu.resp2 = 1e6 * f;
	     end;
	     else if ca = "iq" | ca = "int_quantum" then do;
		wctu.set.quantum1 = "1"b;
		call flo;
		wctu.quantum1 = 1e6 * f;
	     end;
	     else if ca = "q" | ca = "quantum" then do;
		wctu.set.quantum2 = "1"b;
		call flo;
		wctu.quantum2 = 1e6 * f;
	     end;
	     else if ca = "post_purge" | ca = "pp" then do;
		wctu.set.purging = "1"b;
		call chr;
		wctu.flags.purging = onf;
	     end;
	     else if ca = "wc_maxe" | ca = "wc_max_eligible" then do;
		wctu.set.maxel = "1"b;
		call fix;
		wctu.maxel = d;
	     end;
	     else if ca = "realtime" | ca = "rt" | ca = "realt" then do;
		wctu.set.realtime = "1"b;
		call chr;
		wctu.flags.realtime = onf;
	     end;
	     else if ca = "pin_weight" | ca = "pw" then do;
		wctu.set.pin_weight = "1"b;
		call fix;
		wctu.pin_weight = d;
	     end;
	     else if ca = "io_priority" | ca = "iop" then do;
		wctu.set.io_priority = "1"b;
		call chr;
		wctu.flags.io_priority = onf;
               end;
	     else if ca = "governed" | ca = "gv" then do;
		wctu.set.governed = "1"b;
		if arg = "off" then
		     wctu.max_percent = 0;
		else do;
		     call fix;
		     if d <= 0 | d > 100 then
			goto BAD_PERCENT;
		     wctu.max_percent = d;
		end;
	     end;
	     else if ca = "int_queue" then do;
	          wctu.set.interactive_q = "1"b;
		call chr;
		wctu.flags.interactive_q = onf;
	     end;
	     else go to BAD_PARM;

	end;

	if wctu.wc_number = -1 then do;
	     ca = "work_class";
NOARG:	     call com_err_ (error_table_$noarg, me, "^a", ca);
	     return;
	end;


	on linkage_error begin;
	     call ioa_ ("tune_work_class: This command requires access to hphcs_.");
	     go to MAIN_RETURN;
	end;

	call hphcs_$tune_work_class (addr (wctu), code);
	if code ^= 0 then go to ERR;
MAIN_RETURN: return;				/* come here to bust out */

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


flo:	proc;

	     f = cv_float_ (arg, code);
	     if code ^= 0 then go to BAD_NUM;
	end flo;



fix:	proc;
	     d = cv_dec_check_ (arg, code);
	     if code ^= 0 then go to BAD_NUM;
	end fix;



chr:	proc;

	     if arg = "on" then onf = "1"b;
	     else if arg = "off" then onf = "0"b;
	     else go to BAD_ONF;
	end chr;


BAD_ONF:	call com_err_ (0, me, "Value for ^a must be ""on"" or ""off""", ca);
	return;

BAD_NUM:	call com_err_ (0, me, "Value for ^a is non-numeric: ^a",
	     ca, arg);
	return;


BAD_PARM:	call com_err_ (0, me, "Unrecognized parameter: ^a", ca);
	return;

BAD_PERCENT:
	call com_err_ (0, me, "^a not percent between 1 and 100", arg);
	return;
	

/*  */
%include work_class_info;
     end tune_work_class;






		    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
