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