decode_entryname_.pl1 11/04/82 2003.4rew 11/04/82 1630.7 15525 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ decode_entryname_: procedure (cname, rname, ename); /* This procedure, given an entryname of the form "a$b" will return the refname and entry portions separately, i.e. "a" and "b". If no "$" is found in the input string, "a$a" is assumed. If the input string is of the form "a$", "a" and "" are returned. P. Bos, May 1972 */ dcl cname char(*), /* entryname, "a$b" */ rname char(32), /* refname "a" */ ename char(32); /* entry "b" */ dcl (index, length, substr) builtin; dcl (i, l) fixed bin; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ l = length (cname); /* get length of input string */ i = index (cname, "$"); /* scan for delimiter */ if i = 0 then do; /* no "$", assume "a$a" */ rname, ename = cname; /* set return values */ return; /* and exit */ end; rname = substr (cname, 1, i-1); /* extract "a" portion */ if i < l then /* if "$" was not last char */ ename = substr (cname, i+1, l-i); /* then extract "b" */ else /* input was "a$" */ ename = ""; /* give null string for entry */ return; /* exit */ end decode_entryname_;  do.pl1 10/15/86 1429.4rew 10/15/86 1407.9 362331 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ DO/EXECUTE_STRING/SUBSTITUTE_ARGUMENTS Command/requests to expand specified string by substituting arguments, and optionally executing the expansion. Created: 30 October 1973 by BLW. Modified: 31 December 1974 by Steve Herbst to remove string parameter. Modified: 16 December 1975 by Steve Herbst to add &f and &n. Modified: 3 March 1976 by Steve Herbst to add &qf and &rf. Modified: 3 August 1976 by Steve Herbst to accept any number of mode-changing control arguments. Modified: 15 October 1976 by Steve Herbst to fix bug with &f. Modified: 16 February 1982 by G. Palter to add ssu_do_request_ and convert to use a standalone subsystem invocation. Modified: 28 April 1982 by G. Dixon to allow AF first arg to begin with minus. Modified: 8 September 1982 by G. Palter to propagate subsystem/request line aborts. */ /****^ HISTORY COMMENTS: 1) change(86-08-11,JSLove), approve(86-08-12,MCR7520), audit(86-08-14,FCSmith), install(86-10-01,MR12.0-1170): Changed to permit control arguments and the control string in the same invocation. Added -control_string (-cs) option to permit control string to begin with a hyphen. Added -inhibit_error and -no_inhibit_error as synonyms of -absentee and -interactive, respectively. Added -abort_line (-abl) mode for subsystem execution. Improved expansion error diagnostics. Changed handling of &r1&r2 to eliminate spurious quote. Added &control_string construct and handling of "zeroth" argument. 2) change(86-08-11,JSLove), approve(86-08-12,MCR7519), audit(86-08-14,FCSmith), install(86-10-01,MR12.0-1170): Added execute_string and substitute_arguments entries. At this time, substantial changes were required to permit the expansion of the execute_string AF's -error_value. Other changes were made for clarity, coding standards, performance, robustness and minimizing the stack frame size. The complete set of changes amount to a substantial rewrite, including: Removed standalone subsystem invocation. Changed to allocate expanded buffer rather than growing stack frame. Changed to use PL/I "on" statement to set handlers rather than the condition_ subroutine. 3) change(86-10-09,JSLove), approve(86-10-13,MCR7519), audit(86-10-13,Parisek), install(86-10-15,MR12.0-1186): Post-installation Bug Fix: changed error message associated with request line aborts to not report ssu_et_$request_line_aborted in brief mode. END HISTORY COMMENTS */ /* format: style3,ifthenstmt,indcomtxt,indproc,idind30 */ do: procedure () options (variable); declare P_info_ptr ptr parameter, /* subsystem request -> subsystem's internal data */ P_sci_ptr ptr parameter; /* subsystem request -> SCI of subsystem */ declare (addcharno, addr, addwordno, binary, copy, divide, hbound, index, lbound, length, ltrim, maxlength, min, mod, null, rtrim, substr, verify) builtin; declare (active_function_error, any_other, area, cleanup) condition; declare abort_line bit (1) aligned, allocated_buffer_max_len fixed bin (21), allocated_buffer_ptr ptr, arg_count fixed bin (17), arg_list_ptr ptr, arg_offset fixed bin (17), entrypoint fixed bin (2), error_value_len fixed bin (21), error_value_ptr ptr, execute bit (1) aligned, expansion_buffer char (256) varying, expansion_max_len fixed bin (21), expansion_ptr ptr, inhibit_error bit (1) aligned, rescan_type fixed bin (17), return_value_max_len fixed bin (21), return_value_ptr ptr, sci_ptr ptr, status fixed bin (35), trace bit (1) aligned, unique char (15) aligned; declare allocated_buffer char (allocated_buffer_max_len) varying based (allocated_buffer_ptr), command char (length (expansion)) based (addwordno (addr (expansion), 1)), expansion char (expansion_max_len) varying based (expansion_ptr), return_value char (return_value_max_len) varying based (return_value_ptr), system_area area based (get_system_free_area_ ()); declare abort_line_mode (2) bit (1) aligned static initial ((2) ("1"b)), execute_mode (2) bit (1) aligned static initial ((2) ("1"b)), inhibit_error_mode (2) bit (1) aligned static initial ((2) ("0"b)), trace_mode (3) bit (1) aligned static initial ((3) ("0"b)); declare AMPERSAND char (1) static options (constant) initial ("&"), BLANK char (1) static options (constant) initial (" "), QUOTE char (1) static options (constant) initial (""""), WHITE char (5) static options (constant) initial (" "); /* FF VT NL HT SPACE */ declare ( DO_ENTRY initial (1), EXECUTE_ENTRY initial (2), SUBSTITUTE_ENTRY initial (3) ) fixed bin (2) static options (constant); declare ( ILLEGAL_CHARACTER initial (1), ILLEGAL_END_CONTROL_STRING initial (2), ILLEGAL_END_ERROR_VALUE initial (3), ILLEGAL_INTEGER initial (4), ILLEGAL_KEYWORD initial (5), ILLEGAL_UNCLOSED initial (6) ) fixed bin (3) static options (constant); declare ( NO_QUOTE_MODIFIER initial (1), PROTECT_QUOTES_MODIFIER initial (2), REQUOTE_MODIFIER initial (3) ) fixed bin (2) static options (constant); declare MY_NAME (3) char (20) static options (constant) initial ("do", "execute_string", "substitute_arguments"), MY_SHORT_NAME (3) char (4) varying static options (constant) initial ("do", "exs", "sbag"); declare ( PARSER_EXPLICIT_CONTROL_STRING initial (1), PARSER_FOUND_CONTROL_STRING initial (2), PARSER_WANTS_CONTROL_STRING initial (3), PARSER_WANTS_ERROR_VALUE initial (4) ) fixed bin (3) static options (constant); declare REASONS (6) char (85) varying static options (constant) initial ("An invalid character terminates substitution construct ^a.", "Substitution construct ^a is incomplete at the end of the control string.", "Substitution construct ^a is incomplete at the end of the error value.", "The parenthesized part of substitution construct ^a must be an unsigned integer.", "^a is not a valid substitution construct.", "There is no "")"" terminating substitution construct ^a."); declare SPECIAL_CONDITIONS (5) char (24) varying static options (constant) initial ("alrm", "cput", "quit", "program_interrupt", "record_quota_overflow"); declare ( COMMAND_USAGE char (39) initial ("{-control_args} {control_string {args}}"), EXS_AF_USAGE char (37) initial ("{-control_args} control_string {args}"), SBAG_AF_USAGE char (21) initial ("control_string {args}") char (21) ) static options (constant); declare NO_FROM_WARNING char (95) static options (constant) initial ("""&^[q^;r^]f&n"" must be used instead of argument designator ^a.^[ Type ""start"" to continue.^]"); declare TRUNCATION_WARNING char (127) static options (constant) initial (" Only the first ^d characters of the expanded ^[error value^;control string^] can be returned.^[ Type ""start"" to continue.^]"); declare ( error_table_$badopt, error_table_$command_line_overflow, error_table_$inconsistent, error_table_$noarg, error_table_$not_act_fnc, ssu_et_$null_request_line, ssu_et_$request_line_aborted, ssu_et_$subsystem_aborted ) fixed bin (35) external; declare iox_$error_output ptr external; declare active_fnc_err_ entry () options (variable), active_fnc_err_$suppress_name entry () options (variable), com_err_ entry () options (variable), com_err_$suppress_name entry () options (variable), condition_interpreter_ entry (ptr, ptr, fixed bin (17), fixed bin (17), ptr, char (*), ptr, ptr), continue_to_signal_ entry (fixed bin (35)), cu_$af_return_arg_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr), cu_$arg_list_ptr entry () returns (ptr), cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr), cu_$cp entry (ptr, fixed bin (21), fixed bin (35)), cu_$evaluate_active_string entry (ptr, char (*), fixed bin, char (*) var, fixed bin (35)), find_condition_info_ entry (ptr, ptr, fixed bin (35)), get_system_free_area_ entry () returns (ptr), ioa_ entry () options (variable), ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned, bit (1) aligned), ioa_$ioa_switch entry () options (variable), requote_string_ entry (char (*)) returns (char (*)), ssu_$abort_line entry () options (variable), ssu_$abort_subsystem entry () options (variable), ssu_$arg_ptr entry (ptr, fixed bin (17), ptr, fixed bin (21)), ssu_$evaluate_active_string entry (ptr, ptr, char (*), fixed bin (17), char (*) var, fixed bin (35)), ssu_$execute_line entry (ptr, ptr, fixed bin (21), fixed bin (35)), ssu_$get_subsystem_and_request_name entry (ptr) returns (char (72) varying), ssu_$get_request_name entry (ptr) returns (char (32)), ssu_$print_message entry () options (variable), ssu_$return_arg entry (ptr, fixed bin (17), bit (1) aligned, ptr, fixed bin (21)), unique_chars_ entry (bit (*) aligned) returns (char (15) aligned); %page; %include condition_info; %page; %include cp_active_string_types; %page; /* do: entry () options (variable); */ entrypoint = DO_ENTRY; /* Execute as command, Substitute as AF */ go to STANDALONE; exs: execute_string: entry () options (variable); entrypoint = EXECUTE_ENTRY; go to STANDALONE; sbag: substitute_args: substitute_arguments: entry () options (variable); entrypoint = SUBSTITUTE_ENTRY; STANDALONE: sci_ptr = null (); go to COMMON; ssu_do_request_: entry (P_sci_ptr, P_info_ptr); entrypoint = DO_ENTRY; go to SUBSYSTEM; ssu_execute_string_request_: entry (P_sci_ptr, P_info_ptr); entrypoint = EXECUTE_ENTRY; go to SUBSYSTEM; ssu_substitute_args_request_: entry (P_sci_ptr, P_info_ptr); entrypoint = SUBSTITUTE_ENTRY; SUBSYSTEM: sci_ptr = P_sci_ptr; go to COMMON; %page; /* Actual work starts here */ COMMON: allocated_buffer_max_len, error_value_len = 0; allocated_buffer_ptr, arg_list_ptr, error_value_ptr = null (); expansion_max_len = maxlength (expansion_buffer); expansion_ptr = addr (expansion_buffer); trace = trace_mode (entrypoint); unique = ""; on cleanup begin; if allocated_buffer_ptr ^= null () then free allocated_buffer in (system_area); end; if sci_ptr = null () then call check_arguments (cu_$arg_list_ptr ()); else call ssu_$return_arg (sci_ptr, arg_count, ("0"b), return_value_ptr, return_value_max_len); if return_value_ptr = null () then go to COMMAND (entrypoint); else go to FUNCTION (entrypoint); COMMAND (1): /* "do" */ COMMAND (2): /* "execute_string" */ call execute_string_command (); if ^execute then go to EGRESS; if inhibit_error then on any_other call any_other_handler (); if sci_ptr = null () then call cu_$cp (addr (command), length (command), status); else call ssu_$execute_line (sci_ptr, addr (command), length (command), status); revert any_other; if status ^= 0 then call execute_string_command_error (); go to EGRESS; COMMAND (3): /* "substitute_arguments" */ call substitute_args_command (); EGRESS: /* Common exit and error abort point */ revert active_function_error, any_other; if allocated_buffer_ptr ^= null () then free allocated_buffer in (system_area); return; %page; FUNCTION (1): /* "do" */ FUNCTION (3): /* "substitute_arguments" */ call substitute_args_function (); go to EGRESS; FUNCTION (2): /* "execute_string" */ call execute_string_function (); if error_value_ptr ^= null () then do; if sci_ptr = null () then on active_function_error call active_function_error_handler (); if inhibit_error then on any_other call any_other_handler (); end; if sci_ptr = null () then call cu_$evaluate_active_string (null (), command, rescan_type, return_value, status); else call ssu_$evaluate_active_string (sci_ptr, null (), command, rescan_type, return_value, status); revert active_function_error, any_other; if status ^= 0 then call execute_string_function_error (); go to EGRESS; SUBSTITUTE_ERROR_VALUE: revert active_function_error, any_other; call expand_error_value (); go to EGRESS; %page; /**** Handler for errors during execution of an active function. Only errors reported by the active function are caught by this handler, as opposed to faults which might occur during its execution. */ active_function_error_handler: procedure (); declare 1 CI aligned like condition_info; if trace then do; CI.version = condition_info_version_1; call find_condition_info_ (null (), addr (CI), (0)); call condition_interpreter_ (null (), null (), 0, 0, CI.mc_ptr, (CI.condition_name), CI.wc_ptr, CI.info_ptr); end; go to SUBSTITUTE_ERROR_VALUE; end active_function_error_handler; %page; /**** Handler for unexpected conditions during execution of the command, active function or request line. Certain conditions are ignored (i.e., passed on to other handlers). */ any_other_handler: procedure (); declare conditionx fixed bin (17); declare 1 CI aligned like condition_info; CI.version = condition_info_version_1; call find_condition_info_ (null (), addr (CI), (0)); if length (CI.condition_name) > length ("command_") then if substr (CI.condition_name, 1, length ("command_")) = "command_" then go to CONTINUE; do conditionx = lbound (SPECIAL_CONDITIONS, 1) to hbound (SPECIAL_CONDITIONS, 1); if CI.condition_name = SPECIAL_CONDITIONS (conditionx) then go to CONTINUE; end; if return_value_ptr = null () | trace then call condition_interpreter_ (null (), null (), 0, 0, CI.mc_ptr, (CI.condition_name), CI.wc_ptr, CI.info_ptr); if error_value_ptr ^= null () then go to SUBSTITUTE_ERROR_VALUE; else go to EGRESS; CONTINUE: call continue_to_signal_ ((0)); return; end any_other_handler; %page; /**** Get argument count and active function return value for non-SSU case. */ check_arguments: procedure (P_arg_list_ptr) options (non_quick); declare P_arg_list_ptr ptr parameter; arg_list_ptr = P_arg_list_ptr; call cu_$af_return_arg_rel (arg_count, return_value_ptr, return_value_max_len, status, arg_list_ptr); if status = 0 then return; if status = error_table_$not_act_fnc then return; call com_err_ (status, MY_NAME (entrypoint), "Can't get argument count."); go to EGRESS; end check_arguments; %page; execute_string_command: procedure () options (non_quick); declare arg_len fixed bin (21), arg_ptr ptr, argx fixed bin (17), control_string_len fixed bin (21), control_string_ptr ptr, parser fixed bin (3), saved_parser fixed bin (3); declare arg char (arg_len) based (arg_ptr), control_string char (control_string_len) based (control_string_ptr); if arg_count = 0 then call usage (COMMAND_USAGE); abort_line = abort_line_mode (entrypoint); execute = execute_mode (entrypoint); inhibit_error = inhibit_error_mode (entrypoint); parser = PARSER_WANTS_CONTROL_STRING; do argx = 1 to arg_count while (parser ^= PARSER_FOUND_CONTROL_STRING); call get_argument (argx); if parser = PARSER_EXPLICIT_CONTROL_STRING then parser = PARSER_FOUND_CONTROL_STRING; else if substr (arg, 1, min (1, length (arg))) = "-" then if arg = "-abort_line" | arg = "-abl" then abort_line = "1"b; else if arg = "-brief" | arg = "-bf" then trace = "0"b; else if arg = "-control_string" | arg = "-cs" then parser = PARSER_EXPLICIT_CONTROL_STRING; else if arg = "-go" then execute = "1"b; else if arg = "-inhibit_error" | arg = "-ihe" | arg = "-absentee" | arg = "-abs" then inhibit_error = "1"b; else if arg = "-long" | arg = "-lg" then trace = "1"b; else if arg = "-no_abort_line" | arg = "-nabl" then abort_line = "0"b; else if arg = "-no_go" | arg = "-nogo" then execute = "0"b; else if arg = "-no_inhibit_error" | arg = "-nihe" | arg = "-interactive" | arg = "-ia" then inhibit_error = "0"b; else go to BADOPT; else parser = PARSER_FOUND_CONTROL_STRING; end; if parser = PARSER_WANTS_CONTROL_STRING then do; abort_line_mode (entrypoint) = abort_line; execute_mode (entrypoint) = execute; inhibit_error_mode (entrypoint) = inhibit_error; trace_mode (entrypoint) = trace; go to EGRESS; end; if parser ^= PARSER_FOUND_CONTROL_STRING then go to NOARG; arg_offset = argx - 1; call expand (); return; %page; execute_string_function: entry (); inhibit_error = "0"b; parser = PARSER_WANTS_CONTROL_STRING; rescan_type = ATOMIC_ACTIVE_STRING; do argx = 1 to arg_count while (parser ^= PARSER_FOUND_CONTROL_STRING); call get_argument (argx); if parser = PARSER_EXPLICIT_CONTROL_STRING then parser = PARSER_FOUND_CONTROL_STRING; else if parser = PARSER_WANTS_ERROR_VALUE then do; error_value_len = arg_len; error_value_ptr = arg_ptr; parser = saved_parser; end; else if substr (arg, 1, min (1, length (arg))) = "-" then if arg = "-brief" | arg = "-bf" then trace = "0"b; else if arg = "-control_string" | arg = "-cs" then parser = PARSER_EXPLICIT_CONTROL_STRING; else if arg = "-error_value" | arg = "-erv" then do; saved_parser = parser; parser = PARSER_WANTS_ERROR_VALUE; end; else if arg = "-inhibit_error" | arg = "-ihe" then inhibit_error = "1"b; else if arg = "-long" | arg = "-lg" then trace = "1"b; else if arg = "-no_inhibit_error" | arg = "-nihe" then inhibit_error = "0"b; else if arg = "-no_rescan" | arg = "-nrsc" then rescan_type = ATOMIC_ACTIVE_STRING; else if arg = "-rescan" | arg = "-rsc" then rescan_type = NORMAL_ACTIVE_STRING; else if arg = "-rescan_tokens" | arg = "-rsct" then rescan_type = TOKENS_ONLY_ACTIVE_STRING; else go to BADOPT; else parser = PARSER_FOUND_CONTROL_STRING; end; if parser = PARSER_WANTS_CONTROL_STRING then call usage (EXS_AF_USAGE); if parser ^= PARSER_FOUND_CONTROL_STRING then go to NOARG; if error_value_ptr = null () & inhibit_error then call error (error_table_$inconsistent, "-inhibit_error without -error_value"); if error_value_ptr ^= null () then inhibit_error = inhibit_error | inhibit_error_mode (entrypoint); arg_offset = argx - 1; call expand (); return; %page; execute_string_command_error: entry (); if sci_ptr = null () then do; if status = 100 | ^trace then return; end; else if status = ssu_et_$null_request_line then return; else if status = ssu_et_$subsystem_aborted then call ssu_$abort_subsystem (sci_ptr); else if status = ssu_et_$request_line_aborted & ^trace then if abort_line then call ssu_$abort_line (sci_ptr); else return; if abort_line then call error (status, "Executing ^a.", requote_string_ (command)); call warn (status, "Executing ^a.", requote_string_ (command)); return; execute_string_function_error: entry (); if error_value_ptr = null () then do; if status = error_table_$command_line_overflow then do; call warn (status, "Result truncated to ^d characters^[ evaluating ^a^].", return_value_max_len, trace, requote_string_ (command)); return; end; if sci_ptr ^= null () then if status = ssu_et_$subsystem_aborted then call ssu_$abort_subsystem (sci_ptr); else if status = ssu_et_$request_line_aborted & ^trace then call ssu_$abort_line (sci_ptr); if trace then call error (status, "Evaluating ^a.", requote_string_ (command)); return; end; expand_error_value: entry (); arg_len = error_value_len; arg_ptr = error_value_ptr; expansion_max_len = return_value_max_len; expansion_ptr = return_value_ptr; call expand (); return; %page; /**** This case is used only by the substitute_arguments command, and accepts fewer control arguments than the execute_string cases. The substitute_arguments command and active function have only the long/brief mode, since the other modes relate to execution of the expansion. */ substitute_args_command: entry (); if arg_count = 0 then call usage (COMMAND_USAGE); parser = PARSER_WANTS_CONTROL_STRING; do argx = 1 to arg_count while (parser ^= PARSER_FOUND_CONTROL_STRING); call get_argument (argx); if parser = PARSER_EXPLICIT_CONTROL_STRING then parser = PARSER_FOUND_CONTROL_STRING; else if substr (arg, 1, min (1, length (arg))) = "-" then if arg = "-brief" | arg = "-bf" then trace = "0"b; else if arg = "-control_string" | arg = "-cs" then parser = PARSER_EXPLICIT_CONTROL_STRING; else if arg = "-long" | arg = "-lg" then trace = "1"b; else go to BADOPT; else parser = PARSER_FOUND_CONTROL_STRING; end; if parser = PARSER_WANTS_CONTROL_STRING then do; trace_mode (entrypoint) = trace; go to EGRESS; end; if parser ^= PARSER_FOUND_CONTROL_STRING then go to NOARG; arg_offset = argx - 1; call expand (); call ioa_ ("^a", expansion); return; %page; /**** This case is very simple. No control arguments are accepted. The command processor has already allocated a large but non-expandable buffer for the expanded string. We check that we have at least the one required argument, and if so, we set up the environment for expansion appropriately, do the expansion, and return. */ substitute_args_function: entry (); if arg_count = 0 then call usage (SBAG_AF_USAGE); arg_offset, argx = 1; call get_argument (argx); expansion_max_len = return_value_max_len; expansion_ptr = return_value_ptr; call expand (); return; BADOPT: call error (error_table_$badopt, "^a", requote_string_ (arg)); NOARG: call error (error_table_$noarg, "Following ^a.", requote_string_ (arg)); %page; error: procedure () options (variable); declare arg_list_ptr ptr, buffer char (256), buffer_used fixed bin (21), fatal bit (1) aligned, status_ptr ptr; declare buffer_overlay char (buffer_used) based (addr (buffer)), status fixed bin (35) based (status_ptr); fatal = "1"b; go to COMMON; warn: entry () options (variable); fatal = "0"b; COMMON: arg_list_ptr = cu_$arg_list_ptr (); call cu_$arg_ptr_rel (1, status_ptr, (0), (0), arg_list_ptr); call ioa_$general_rs (arg_list_ptr, 2, 3, buffer, buffer_used, "0"b, "0"b); if sci_ptr = null () then do; if return_value_ptr = null () then call com_err_ (status, MY_NAME (entrypoint), "^a", buffer_overlay); else call active_fnc_err_ (status, MY_NAME (entrypoint), "^a", buffer_overlay); if fatal then go to EGRESS; end; else if fatal then call ssu_$abort_line (sci_ptr, status, "^a", buffer_overlay); else call ssu_$print_message (sci_ptr, status, "^a", buffer_overlay); return; end error; %page; /**** Expand the control string into the expansion. For simplicity, expansion is a varying character string so that PL/I concatenation can be used. The substitution constructs are mostly recognized a character at a time by indexing into lists of the characters which are presently valid and dispatching on the position of the current character in the list. This is very efficient. */ expand: procedure (); declare buffer_overflow bit (1) aligned, command_name char (72) varying, construct_pos fixed bin (21), control_string_pos fixed bin (21), nstring picture "zzzz9", from_sw bit (1) aligned, parm_count fixed bin (17), quote_multiplier fixed bin (21), quote_scan_pos fixed bin (21), requote_last bit (1) aligned, requote_sw fixed bin (2), skip fixed bin (21), string_len fixed bin (21), string_ptr ptr; declare construct char (control_string_pos - construct_pos) based (addcharno (addr (control_string), construct_pos)), string char (string_len) based (string_ptr); buffer_overflow, from_sw = "0"b; control_string_len = arg_len; control_string_pos, quote_scan_pos = 0; control_string_ptr = arg_ptr; expansion = ""; parm_count = arg_count - arg_offset; quote_multiplier = 1; requote_last = "0"b; requote_sw = NO_QUOTE_MODIFIER; do while (control_string_pos < length (control_string)); string_len = index (substr (control_string, control_string_pos + 1), AMPERSAND) - 1; if string_len < 0 then string_len = length (control_string) - control_string_pos; if string_len > 0 then do; string_ptr = addcharno (control_string_ptr, control_string_pos); call add_string (); control_string_pos = control_string_pos + string_len; end; if control_string_pos >= length (control_string) then go to EXPANDED; construct_pos = control_string_pos; control_string_pos = control_string_pos + length (AMPERSAND) + 1; if control_string_pos > length (control_string) then go to END; argx = index ("0123456789!(&&cfnqr", substr (control_string, control_string_pos, 1)) - 1; go to DISPATCH (argx); DISPATCH (-1): /* illegal -- character not in dispatch string */ call illegal (ILLEGAL_CHARACTER); DISPATCH (0): /* A digit has been found. The number of the */ DISPATCH (1): /* parameter to be substituted is in argx. */ DISPATCH (2): /* Here we handle the from_sw processing, and */ DISPATCH (3): /* the requote_sw processing is handled in */ DISPATCH (4): /* expand_arg. */ DISPATCH (5): DISPATCH (6): DISPATCH (7): DISPATCH (8): DISPATCH (9): if from_sw then do; if argx = 0 then argx = 1; /* &f0 => &f1 */ from_sw = "0"b; /* Reset for next construct */ do argx = argx to parm_count; call expand_arg (); if argx < parm_count then do; string_len = length (BLANK); string_ptr = addr (BLANK); call add_string (); end; end; end; else if argx <= parm_count then call expand_arg (); requote_sw = NO_QUOTE_MODIFIER; /* Reset for next expansion */ go to SCAN_NEXT; DISPATCH (10): /* &! -- Substitute a unique string */ if unique = "" then unique = unique_chars_ (""b); string_len = length (unique); string_ptr = addr (unique); call add_string (); go to SCAN_NEXT; DISPATCH (11): /* &( -- Begin a parenthesized parameter index */ string_len = index (substr (control_string, control_string_pos + 1), ")") - 1; if string_len < 0 then call illegal (ILLEGAL_UNCLOSED); string_ptr = addcharno (control_string_ptr, control_string_pos); control_string_pos = control_string_pos + string_len + length (")"); string_len = length (rtrim (string, WHITE)); if string_len = 0 then call illegal (ILLEGAL_INTEGER); skip = verify (string, WHITE) - 1; string_len = string_len - skip; string_ptr = addcharno (string_ptr, skip); if verify (string, "0123456789") ^= 0 then call illegal (ILLEGAL_INTEGER); if length (ltrim (string, "0")) > 5 then argx = parm_count + 1; else argx = binary (string, 17, 0); go to DISPATCH (0); DISPATCH (12): /* && -- A literal ampersand */ string_len = length (AMPERSAND); string_ptr = addr (AMPERSAND); call add_string (); go to SCAN_NEXT; DISPATCH (13): /* &f&, &q&, &qf&, &r&, &rf& -- The last parameter */ if control_string_pos + length ("n") > length (control_string) then go to END; control_string_pos = control_string_pos + length ("n"); if substr (control_string, control_string_pos, length ("n")) ^= "n" then call illegal (ILLEGAL_CHARACTER); if ^from_sw then do; call warn (0, NO_FROM_WARNING, requote_sw = PROTECT_QUOTES_MODIFIER, requote_string_ (construct), return_value_ptr ^= null () & sci_ptr = null ()); from_sw = "1"b; end; argx = parm_count; go to DISPATCH (0); DISPATCH (14): /* &c -- begins &control_string */ control_string_pos = control_string_pos + length ("ontrol_string"); if control_string_pos > length (control_string) then call illegal (ILLEGAL_KEYWORD); if substr (control_string, construct_pos + 2, length ("control_string")) ^= "control_string" then call illegal (ILLEGAL_KEYWORD); argx = 0; requote_sw = PROTECT_QUOTES_MODIFIER; go to DISPATCH (0); DISPATCH (15): /* &f, &qf and &rf -- Substitute a range of parameters */ from_sw = "1"b; if control_string_pos >= length (control_string) then go to END; control_string_pos = control_string_pos + 1; argx = index ("01234567899((&", substr (control_string, control_string_pos, 1)) - 1; go to DISPATCH (argx); DISPATCH (16): /* &n -- Substitute the number of optional arguments */ nstring = parm_count; string_len = verify (nstring, BLANK) - 1; string_ptr = addcharno (addr (nstring), string_len); string_len = length (nstring) - string_len; call add_string (); go to SCAN_NEXT; DISPATCH (17): /* &q -- Protect quotes in the parameter */ requote_sw = PROTECT_QUOTES_MODIFIER; go to AFTER_QUOTE_MODIFIER; DISPATCH (18): /* &r -- Requote the parameter */ requote_sw = REQUOTE_MODIFIER; AFTER_QUOTE_MODIFIER: if control_string_pos >= length (control_string) then go to END; control_string_pos = control_string_pos + 1; argx = index ("01234567899((&&f", substr (control_string, control_string_pos, 1)) - 1; go to DISPATCH (argx); SCAN_NEXT: end; /**** Argument substitution is completed. */ EXPANDED: if trace then do; if sci_ptr = null () then command_name = MY_NAME (entrypoint); else command_name = ssu_$get_subsystem_and_request_name (sci_ptr); call ioa_$ioa_switch (iox_$error_output, "^[[^a^[ -error_value^]]^;^a^s^]: (^d) ^a", return_value_ptr ^= null (), command_name, return_value_ptr = expansion_ptr & entrypoint = EXECUTE_ENTRY, length (command), requote_string_ (command)); end; return; /**** The end of the string beging expanded was found after an ampersand was encountered but before a valid substitution construct was completed. */ END: if entrypoint = EXECUTE_ENTRY & expansion_ptr = return_value_ptr then call illegal (ILLEGAL_END_ERROR_VALUE); else call illegal (ILLEGAL_END_CONTROL_STRING); %page; /**** These operations are gathered in a subroutine to reduce code size in exchange for a very slight performance penalty. The overlay is used to add QUOTE characters to the string in order to avoid a stack extension. */ add_quotes: procedure (); declare old_len fixed bin (21); declare 1 expansion_overlay aligned based (expansion_ptr), 2 len fixed bin (21), 2 str char (0 refer (expansion_overlay.len)); call check_buffer (); old_len = expansion_overlay.len; expansion_overlay.len = expansion_overlay.len + string_len; substr (expansion_overlay.str, old_len + 1, string_len) = copy (QUOTE, string_len); if buffer_overflow then go to EXPANDED; return; add_string: entry (); call check_buffer (); expansion = expansion || string; if buffer_overflow then go to EXPANDED; return; end add_quotes; %page; /**** The expansion has become too large for the expansion buffer. Allocate a bigger buffer, and free the old one if it was allocated. The initial buffer is automatic, and must be not be freed. */ allocate_buffer: procedure (); declare new_buffer_ptr ptr, old_buffer_max_len fixed bin (21); new_buffer_ptr = null (); old_buffer_max_len = allocated_buffer_max_len; on cleanup begin; if new_buffer_ptr ^= null () & new_buffer_ptr ^= allocated_buffer_ptr then free new_buffer_ptr -> allocated_buffer in (system_area); end; on area go to AREA_HANDLER; allocated_buffer_max_len = maxlength (expansion) + string_len + length (control_string) + 8 * parm_count; allocate allocated_buffer in (system_area) set (new_buffer_ptr); new_buffer_ptr -> allocated_buffer = expansion; expansion_max_len = allocated_buffer_max_len; if allocated_buffer_ptr ^= null () then do; allocated_buffer_max_len = old_buffer_max_len; free allocated_buffer in (system_area); end; allocated_buffer_ptr, expansion_ptr = new_buffer_ptr; return; AREA_HANDLER: call error (0, "Can't allocate a buffer large enough to hold the expanded control string."); end allocate_buffer; %page; /**** Ensure that there is sufficient space in the expansion buffer to permit the addition of string_len characters to the buffer. If there is not, grow the buffer if possible. The case where we can't try to grow the buffer is when the buffer is the active function return value. Since the command processor can't accept a bigger value, we announce that the string was truncated and set string_len to what will actually fit. Setting buffer_overflow will cause termination of the expansion after the characters have been appended. Note that ssu_$print_message will only return for active functions after the user issues "start", but not for the subsystem active request case. The only cases where expansion is directlyt overlayed on the return value are the do/sbag active function and the -error_value for execute_string. */ check_buffer: procedure (); if length (string) ^= 0 then requote_last = "0"b; if length (expansion) + length (string) <= maxlength (expansion) then return; if expansion_ptr = return_value_ptr then do; buffer_overflow = "1"b; string_len = maxlength (expansion) - length (expansion); call warn (error_table_$command_line_overflow, TRUNCATION_WARNING, expansion_max_len, entrypoint = EXECUTE_ENTRY, return_value_ptr ^= null () & sci_ptr = null ()); return; end; call allocate_buffer (); /* Make it bigger */ return; end check_buffer; %page; /**** Get the substitution parameter which is argx after the control string, and append it to the expansion with appropriate quote processing. If no quote modifier was specified, then no special processing is required. Otherwise, the string up to this point must be scanned to determine the current quote level. Then the parameter is appended with optional requotinq and quotes doubled according to the quote level. */ expand_arg: procedure (); declare arg_pos fixed bin (21); call get_argument (argx + arg_offset); if requote_sw = NO_QUOTE_MODIFIER then do; string_len = arg_len; string_ptr = arg_ptr; call add_string (); return; end; do while (quote_scan_pos < length (expansion)); string_len = index (substr (expansion, quote_scan_pos + 1), QUOTE) - 1; if string_len < 0 then string_len = length (expansion) - quote_scan_pos; quote_scan_pos = quote_scan_pos + string_len; if quote_scan_pos < length (expansion) then do; string_len = verify (substr (expansion, quote_scan_pos + 1), QUOTE) - 1; if string_len < 0 then string_len = length (expansion) - quote_scan_pos; quote_scan_pos = quote_scan_pos + string_len; if mod (string_len, quote_multiplier) = 0 then do while (mod (string_len, 2 * quote_multiplier) ^= 0); string_len = string_len - quote_multiplier; quote_multiplier = 2 * quote_multiplier; end; else do while (string_len ^= 0); quote_multiplier = divide (quote_multiplier, 2, 21, 0); string_len = mod (string_len, quote_multiplier); end; end; end; if requote_sw = REQUOTE_MODIFIER then do; if requote_last then expansion = substr (expansion, 1, length (expansion) - quote_multiplier); else do; string_len = quote_multiplier; call add_quotes (); end; quote_multiplier = 2 * quote_multiplier; end; if quote_multiplier = 1 then do; string_len = arg_len; string_ptr = arg_ptr; call add_string (); end; else do; arg_pos = 0; do while (arg_pos < length (arg)); string_len = index (substr (arg, arg_pos + 1), QUOTE) - 1; if string_len < 0 then string_len = length (arg) - arg_pos; if string_len > 0 then do; string_ptr = addcharno (addr (arg), arg_pos); call add_string (); arg_pos = arg_pos + string_len; end; if arg_pos < length (arg) then do; string_len = verify (substr (arg, arg_pos + 1), QUOTE) - 1; if string_len < 0 then string_len = length (arg) - arg_pos; arg_pos = arg_pos + string_len; string_len = string_len * quote_multiplier; call add_quotes (); end; end; end; if requote_sw = REQUOTE_MODIFIER then do; string_len, quote_multiplier = divide (quote_multiplier, 2, 17, 0); call add_quotes (); requote_last = "1"b; /* Remember ending quotes in case of &r1&r2 */ end; quote_scan_pos = length (expansion); /* Don't let protected expansion affect quote depth */ return; end expand_arg; %page; /**** This routine is invoked if an illegal construct is found. To keep the stack frame from becoming unreasonably large, the various control strings are stored in an array so that they can be passed by reference. */ illegal: procedure (reason); declare reason fixed bin (3) parameter; if control_string_pos > length (control_string) then control_string_pos = length (control_string); expansion_buffer = requote_string_ (construct); call error (0, REASONS (reason), expansion_buffer); end illegal; end expand; %page; /**** Get an argument from the argument list. Note that SSU reserves the right to change the argument list format (the entry is replaceable), so we can't obtain a pointer to the SSU arglist and use the cu_ entrypoints. */ get_argument: procedure (P_argx); declare P_argx fixed bin (17) parameter; if sci_ptr = null () then do; call cu_$arg_ptr_rel (P_argx, arg_ptr, arg_len, status, arg_list_ptr); if status ^= 0 then call error (status, "Can't get argument #^d.", P_argx); end; else call ssu_$arg_ptr (sci_ptr, P_argx, arg_ptr, arg_len); return; end get_argument; %page; /**** An error in usage has been detected, probably a missing control string. This internal procedure replaces ssu_$abort_line for this purpose because the standard for usage messages for commands and active functions is to call the appropriate $suppress_name entrypoint. It also permits the short names to be used in the usage messages for the command and active function cases. For the subsystem cases, the standard action of ssu_$abort_line is used, because it is desirable to give the subsystem name. Unfortunately, at this writing there is no easy way to get the short name of the request for use in the error message. */ usage: procedure (usage_string); declare usage_string char (*) parameter; expansion_buffer = "Usage: "; if return_value_ptr ^= null () then expansion_buffer = expansion_buffer || "["; if sci_ptr = null () then expansion_buffer = expansion_buffer || MY_SHORT_NAME (entrypoint); else expansion_buffer = expansion_buffer || rtrim (ssu_$get_request_name (sci_ptr)); expansion_buffer = expansion_buffer || BLANK; expansion_buffer = expansion_buffer || usage_string; if return_value_ptr ^= null () then expansion_buffer = expansion_buffer || "]"; if sci_ptr = null () then if return_value_ptr = null () then call com_err_$suppress_name (0, MY_NAME (entrypoint), "^a", expansion_buffer); else call active_fnc_err_$suppress_name (0, MY_NAME (entrypoint), "^a", expansion_buffer); else call ssu_$abort_line (sci_ptr, 0, "^a", expansion_buffer); go to EGRESS; end usage; end execute_string_command; end do;  execute_epilogue_.pl1 11/05/86 1231.3r w 11/04/86 1033.6 30420 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ execute_epilogue_: proc (run_only); /* coded 9/77 by Steve Webber */ /* modified 1/78 by Melanie Weaver to clean up list of run handlers as it is processed and to mask quits */ /* modified 7/78 by Melanie Weaver to fix loop bug */ /* Parameters */ dcl a_entry entry; dcl run_only bit (1) aligned; /* ON if only want run-unit cleanup */ /* Automatic */ dcl i fixed bin; dcl code fixed bin (35); dcl iocb_ptr ptr; dcl mask bit (36) aligned; /* Static */ dcl num_handlers fixed bin static init (0); dcl epilogue_handlers (10) static entry variable; dcl num_run_handlers fixed bin static init (0); dcl run_epilogue_handlers (10) static entry variable; /* External */ dcl error_table_$action_not_performed fixed bin (35) ext; /* Builtins, etc */ dcl any_other condition; dcl cleanup condition; dcl (ptr, addr, hbound) builtin; /* entries */ dcl iox_$find_iocb_n entry (fixed bin, ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned); /* */ /* Don't let quits keep handlers from finishing */ mask = "0"b; on cleanup begin; if mask then call hcs_$reset_ips_mask (mask, mask); end; call hcs_$set_ips_mask ("0"b, mask); /* Always call the run handlers */ do i = num_run_handlers to 1 by -1; num_run_handlers = num_run_handlers - 1; /* don't want this handler to be remembered after run unit is gone */ on any_other goto next0; call run_epilogue_handlers (i) (); next0: end; if ^run_only then do; do i = 1 to num_handlers; on any_other goto next; call epilogue_handlers (i) (); next: end; /* Now close all files */ call iox_$find_iocb_n (1, iocb_ptr, code); do i = 2 to 2000 while (code = 0); /* avoid infinite loop */ on any_other goto nexti; call iox_$close (iocb_ptr, code); nexti: call iox_$find_iocb_n (i, iocb_ptr, code); end; end; call hcs_$reset_ips_mask (mask, mask); return; /* */ add_epilogue_handler_: entry (a_entry) returns (fixed bin (35)); if ptr (addr (i), 0) -> stack_header.run_unit_depth > 0 then do; if num_run_handlers = hbound (run_epilogue_handlers, 1) then return (error_table_$action_not_performed); do i = 1 to num_run_handlers; if run_epilogue_handlers (i) = a_entry then return (0); end; num_run_handlers = num_run_handlers + 1; run_epilogue_handlers (num_run_handlers) = a_entry; end; else do; if num_handlers = hbound (epilogue_handlers, 1) then return (error_table_$action_not_performed); do i = 1 to num_handlers; if epilogue_handlers (i) = a_entry then return (0); end; num_handlers = num_handlers + 1; epilogue_handlers (num_handlers) = a_entry; end; return (0); /* */ %include stack_header; end;  format_line.pl1 11/04/82 2003.4rew 11/04/82 1610.0 78237 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ fl: format_line: procedure options (variable); /* command/active function interface to ioa_ */ /* updated 03/08/82: change usage message to use */ /* the long name of the command by LAB. */ who_am_i = "format_line"; newline_sw = "1"b; go to COMMON; flnnl: format_line_nnl: entry options (variable); /* interface to ioa_$nnl */ who_am_i = "format_line_nnl"; newline_sw = "0"b; go to COMMON; %page; declare (addr, hbound, index, null, substr) builtin; declare cleanup condition; declare active_function bit (1), /* mode of operation (how were we called?) */ arg_count fixed bin, /* number of arguments we were passed. */ arg_list_ptr ptr, /* ptr to argument list */ idx fixed bin, /* an index temporary. */ newline_sw bit (1), /* are we fl or flnnl? */ overflow bit (1), /* for AF case: is return arg too short? */ return_max_len fixed bin, /* maximum length of our return value. */ return_ptr ptr, /* ptr to our return value. */ rs_idx fixed bin (21), /* index of first quote in return string */ seg_ptr ptr, /* ptr to temp for requoting if too big for stack */ status fixed bin (35), /* an error code variable. */ who_am_i char (32); /* name for error messages */ declare seg char (rs.len - rs_idx + 1) based (seg_ptr); declare 1 rs based (return_ptr) aligned, /* our return value. */ 2 len fixed bin (21), /* its current length. */ 2 first_quote char (1) unaligned, /* quote we put around it */ 2 value char (return_max_len refer (rs.len)) unal, /* its character-string value. */ 2 last_quote char (1) unaligned; /* other quote we put around it */ declare 1 arg_list aligned based (arg_list_ptr), 2 n_args fixed bin (17) unal, 2 code fixed bin (17) unal, 2 n_desc fixed bin (17) unal, 2 mbz fixed bin (17) unal, 2 arg_ptrs (arg_count) ptr, 2 desc_ptrs (arg_count) ptr; declare ( active_fnc_err_, active_fnc_err_$af_suppress_name, com_err_, com_err_$suppress_name ) entry options (variable), cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35)), cu_$arg_list_ptr entry () returns (ptr), cu_$generate_call entry (entry, ptr), get_temp_segment_ entry (char (*), ptr, fixed bin (35)), ioa_ entry options (variable), ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned, bit (1) aligned), ioa_$nnl entry options (variable), release_temp_segment_ entry (char (*), ptr, fixed bin (35)); declare ( error_table_$command_line_overflow, error_table_$not_act_fnc ) fixed bin (35) external; %page; /* find out how many args we were passed, and get ptr to and max length of return arg. */ COMMON: call cu_$af_return_arg (arg_count, return_ptr, return_max_len, status); if status = 0 then active_function = "1"b; else if status = error_table_$not_act_fnc then active_function = "0"b; else do; call com_err_ (status, who_am_i); /* error if called without arg descriptors. */ return; end; if arg_count = 0 then do; if active_function then call active_fnc_err_$af_suppress_name (0, who_am_i, "Usage: [format_line^[_nnl^] control_string {args}]", ^newline_sw); else call com_err_$suppress_name (0, who_am_i, "Usage: format_line^[_nnl^] control_string {args}", ^newline_sw); return; end; arg_list_ptr = cu_$arg_list_ptr (); if ^active_function then do; if newline_sw then call cu_$generate_call (ioa_, arg_list_ptr); else call cu_$generate_call (ioa_$nnl, arg_list_ptr); return; end; return_max_len = return_max_len - 2; /* leave room for our quotes */ rs.len = return_max_len + 1; /* be able to detect overlength line. */ %page; /* Now, a new param list for the call to ioa_$general_rs must be constructed. This is necessary because the argument list we were passed contains an extra argument for the active function returns string. This argument may confuse ioa_ */ begin; /* this is to allocate the list */ declare 1 auto_arg_list like arg_list aligned automatic; auto_arg_list.n_args = 2 * arg_count; auto_arg_list.n_desc = 2 * arg_count; auto_arg_list.code = 4; auto_arg_list.mbz = 0; if arg_list.code = 8 then arg_count = arg_count + 2; /* if extra pointer supplied */ else arg_count = arg_count + 1; /* else just skip return argument */ do idx = 1 to hbound (auto_arg_list.arg_ptrs, 1); auto_arg_list.arg_ptrs (idx) = arg_list.arg_ptrs (idx); auto_arg_list.desc_ptrs (idx) = arg_list.desc_ptrs (idx); end; call ioa_$general_rs (addr (auto_arg_list), 1, 2, rs.value, rs.len, "0"b, "0"b); end; overflow = "0"b; rs_idx = index (rs.value, """"); /* embedded quotes? */ if rs_idx > 0 then if rs.len - rs_idx > 4095 then do; /* If we take up more than a page don't use stack */ seg_ptr = null (); on cleanup call release_temp_segment_ (who_am_i, seg_ptr, (0)); call get_temp_segment_ (who_am_i, seg_ptr, status); if status ^= 0 then do; call active_fnc_err_ (status, who_am_i, "Getting temp segment."); return; end; seg = substr (rs.value, rs_idx); call double_quotes (seg); call release_temp_segment_ (who_am_i, seg_ptr, (0)); end; else call double_quotes (substr (rs.value, rs_idx)); else if rs.len > return_max_len then do; rs.len = return_max_len; overflow = "1"b; end; rs.first_quote, rs.last_quote = """"; /* put quotes around result */ rs.len = rs.len + 2; /* include room for the two quotes we're adding. */ if overflow then call active_fnc_err_ (error_table_$command_line_overflow, who_am_i, "Type ""start"" to continue with truncated string."); return; %page; double_quotes: procedure (copy); /* procedure to double any quotes appearing in */ /* the variable, arg. */ declare copy char (*); declare arg_len fixed bin, /* length of arg */ arg_ptr ptr, /* ptr to arg */ arg char (arg_len) based (arg_ptr), clen fixed bin (21), /* current string length. */ quote_idx fixed bin (21), /* another index temporary. */ slen fixed bin (21); /* a string length temporary. */ arg_ptr = addr (substr (rs.value, rs_idx)); /* set ptr to copy back into at first quote */ arg_len = rs.len - rs_idx + 1; /* adjust length accordingly */ return_max_len = return_max_len - rs_idx + 1; /* set max length down accordingly */ rs.len = rs_idx - 1; /* set current length down to point so far valid */ clen = 0; /* set index to start scanning copy for quotes */ do while ("1"b); return_max_len = return_max_len - 1; /* we're going to add a second quote after one */ /* we've found in copy. Exclude this quote from */ /* the length of arg. Instead shift ptr to */ /* arg 1 char to the right. Then, index values */ /* have the same meaning in arg and copy. */ if clen >= return_max_len then do; /* punt if there's no room left for two quotes */ overflow = "1"b; return; end; substr (arg, clen + 1, 2) = """"""; /* add double quote to end of arg. */ rs.len = rs.len + 2; /* update length of return value to reflect the */ /* double quote. */ arg_ptr = addr (substr (arg, 2)); /* move ptr to arg 1 char to the right */ clen = clen + 1; /* look at chars after the quote we've doubled. */ quote_idx = index (substr (copy, clen + 1), """") - 1; /* find next quote in these chars. */ if quote_idx < 0 then slen = arg_len - clen; /* No quotes, so get length of rest of string */ else slen = quote_idx; /* length of stuff before quote */ if clen + slen > return_max_len then do; /* if too long to fit, truncate it here */ slen = return_max_len - clen; quote_idx = -1; /* stop search and exit (fake "no more quotes") */ overflow = "1"b; /* report error */ end; if slen > 0 then substr (arg, clen + 1, slen) = substr (copy, clen + 1, slen); /* append this substr to end of arg. */ rs.len = rs.len + slen; /* add length of substr to length of ret value. */ if quote_idx < 0 then return; /* if we didn't find a quote, then all done. */ clen = clen + quote_idx; /* set index of quote we found, and loop. */ end; end double_quotes; end format_line;  general_ready.pl1 09/15/88 1346.3rew 09/15/88 1340.6 428463 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(69-01-01,Goldman), approve(), audit(), install(86-05-22,MR12.0-1057): Written by Jay Goldman. (Don't know when, the date in the change field is just to satisfy history_comment. -jjl) 2) change(83-08-09,Lippard), approve(), audit(), install(86-05-22,MR12.0-1057): Modified by Jim Lippard to remove reporting of bulk store reads and to use the clock builtin. 3) change(84-02-14,Lippard), approve(), audit(), install(86-05-22,MR12.0-1057): Modified by Jim Lippard to add -total_xxx and -inc_xxx for sf, bf, vr, vw, pft, rcpu and to add the short name -lev to -level. 4) change(84-04-11,Lippard), approve(), audit(), install(86-05-22,MR12.0-1057): Modified by Jim Lippard to turn off -call when certain conditions occur and to add -active_string (-astr). 5) change(84-07-31,Lippard), approve(), audit(), install(86-05-22,MR12.0-1057): Modified by Jim Lippard to add -time_format (-tfmt) and to use the user's default date/time, date, and time formats. 6) change(84-12-05,Lippard), approve(85-01-09,MCR7121), audit(85-10-22,Dupuis), install(85-12-16,MR12.0-1001): Modified by Jim Lippard to not disable -call or -astr when command_question is signalled. 7) change(85-08-01,Lippard), approve(85-08-26,MCR7262), audit(85-10-22,Dupuis), install(85-12-16,MR12.0-1001): Modified by Jim Lippard to not set time_format when the argument supplied to -tfmt is invalid. 8) change(86-03-06,Lippard), approve(86-04-21,MCR7385), audit(86-05-15,Dickson), install(86-05-22,MR12.0-1057): Modified to add short name -fr to -frame. 9) change(88-08-29, TLNguyen), approve(88-08-08, MCR7961), audit(88-09-13, Parisek): (a) "general_ready -reset" should work as documented. (b) "general_ready -set -astr program_interrupt" should ignore the program_interrupt condition. END HISTORY COMMENTS */ general_ready: gr: procedure options (variable); dcl whoami char (32) static initial ("general_ready") options (constant); dcl (level_flag, frame_flag, time_flag, date_flag, date_time_flag, time_format_flag, total_flag, temp_ready_flag, set_level_flag, af_flag, inc_flag) bit (1) aligned; dcl (static_arg_list_ptr static, cur_arg_list, arg_list_ptr, temp_argument_ptr, temp_argument_descr_ptr) pointer; dcl 1 arg_list_header aligned based (arg_list_ptr), 2 twice_arg_count fixed bin (17) unaligned, 2 code fixed bin (17) unaligned, 2 twice_desc_count fixed bin (17) unaligned, 2 pad fixed bin (17) unaligned; dcl 1 ioa_arg_list static aligned, 2 header fixed bin (71), 2 arg_list_ptrs (80) pointer; dcl 1 arg_list based (arg_list_ptr) aligned, 2 header fixed bin (71), 2 arg_ptrs (number_of_data) pointer, 2 descr_ptrs (number_of_data) pointer; dcl ( vcpu_rate, real_rate, online_rate, new_online_rate, process_hour_rate, milli_mu_rate, kmu_rate ) float bin internal static; dcl ( new_vcpu_rate, new_real_rate, new_process_hour_rate, new_kmu_rate, new_milli_mu_rate ) float bin automatic; dcl dollars_fudge float bin (20) int static initial (0e0); dcl login_time fixed bin (71); dcl first_time_flag bit (1) aligned int static init ("1"b); dcl old_cl char (132) aligned static initial (""); dcl old_cll fixed bin static initial (132); dcl old_cl_ptr ptr static init (null ()); dcl based_old_cl char (old_cll) based (old_cl_ptr); dcl cl_ptr ptr; dcl based_cl char (temp_cll) aligned based; dcl sys_area area based (area_ptr); dcl area_ptr ptr; dcl (old_cl_flag, old_level_flag, old_frame_flag, old_total_flag, old_time_flag, old_date_flag, old_date_time_flag, old_time_format_flag, old_inc_flag) bit (1) aligned static initial ("0"b); dcl get_system_free_area_ entry returns (ptr); dcl now fixed bin (71); dcl next_shift fixed bin (71); dcl (addr, addrel, after, bin, bit, clock, dim, fixed, float) builtin; dcl (hbound, length, lbound, max, min, null, substr) builtin; dcl (ioa_$nnl, ioa_$rsnpnnl) ext entry options (variable); dcl ioa_ptr pointer; dcl cu_$cp ext entry (ptr, fixed bin, fixed bin (35)); dcl cu_$gen_call ext entry (ptr, ptr); dcl cu_$af_return_arg ext entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$decode_entry_value ext entry (entry, ptr, ptr); dcl cu_$evaluate_active_string entry (ptr, char(*), fixed bin, char(*) var, fixed bin(35)); dcl max_length fixed bin; dcl return_ptr ptr; dcl user_info_$usage_data ext entry (fixed bin, fixed bin (71), fixed bin (71), fixed bin (71), fixed bin (71)); dcl gr_get_rates_ ext entry (float bin, float bin, float bin, float bin, fixed bin (71)); dcl cu_$set_ready_proc ext entry (pointer); dcl timer_manager_$alarm_call ext entry (fixed bin (71), bit (2) aligned, entry); dcl timer_manager_$reset_alarm_call ext entry (entry); dcl first_time fixed bin (71) int static init (0); dcl hcs_$get_process_usage ext entry (ptr, fixed bin (35)); dcl error_table_$badopt ext static fixed bin (35); dcl error_table_$noarg ext static fixed bin (35); dcl error_table_$inconsistent ext static fixed bin (35); dcl (any_other, sub_error_) condition; dcl find_condition_info_ entry (ptr, ptr, fixed bin(35)); dcl continue_to_signal_ entry (fixed bin(35)); dcl sub_err_ entry() options(variable); dcl 1 ci aligned like condition_info; dcl 1 ready_mode_flags aligned, 2 ready_sw bit (1) unaligned, 2 pad bit (35) unaligned; dcl 1 new aligned static like process_usage; dcl 1 old aligned static like new; dcl 1 last aligned static like new; dcl date_time_string char (250) aligned int static; /* for -date_time */ dcl date_string char (250) aligned int static; /* for -date */ dcl time_string char (250) aligned int static; /* for -time */ dcl time_format_string char (250) aligned int static; /* for -time_format */ dcl old_time_format char (60) int static; /* input string for -time_format */ dcl temp_time_format char (60); dcl time_format char (60); dcl dt char (24) int static aligned; /* mm/dd/yy__hhmm.m_zzz_www */ dcl dt_chars (0:23) char (1) unaligned based (addr (dt)); dcl 1 dt_descr (3) int static, 2 flag bit (1) initial ((3) (1) "1"b), 2 type bit (6) initial ((3) (1) "010101"b), /* character string */ 2 packed bit (1) initial ((3) (1) "1"b), 2 number_dims bit (4) initial ((3) (1) "0000"b), 2 size bit (24) initial ( "000000000000000000000010"b, /* minute, hour, month, day, year */ "000000000000000000000011"b, /* day_name or zone */ "000000000000000011111010"b); /* any time string from date_time_$format */ dcl (arg_index, dt_offset_index, idx) fixed bin; dcl dt_incr_string (10) char (4) varying static initial ( " ^a", " ^a", "^a", " ^a", " ^a", " ^a", " ^a", " ^a", "^a", "^a"); dcl dt_offset (10) fixed bin static initial ( 10, 10, 12, 0, 17, 21, 0, 0, 3, 6); dcl dt_descr_index (10) fixed bin static initial ( 3, 1, 1, 3, 2, 2, 3, 1, 1, 1); dcl real_index (30) fixed bin static initial /* one entry per format option */ (11, 1, 2, 7, 7, 13, 12, 16, /* values <= 10 are indices in dt arrays */ 6, 5, 1, 3, 15, 4, 8, 9, 10, 17, 16, 18, /* maps index in format_args into */ 19, 20, 21, 22, 23, 24, 24, 25, 25, 17); /* index in dt_* and temp_flag array */ dcl 1 temp_flag (1:25) aligned, 2 (inc, total) bit (1); dcl control_args (4) char (7) static aligned initial ("-set", "-revert", "-call", "-reset"); dcl prefix_args (2) char (8) static aligned initial ("-string", "-control"); dcl format_args (30) aligned static char (14) varying initial ("vcpu", "-time", "-hour", "-date", "-dt", "mem_units", "cost", "-level", "-day_name", "-zone", "-tm", "-minute", "pf", "-date_time", "-month", "-day", "-year", "-frame", "-lev", "pft", "sf", "bf", "vr", "vw", "rcpu", "-active_string", "-astr", "-time_format", "-tfmt", "-fr"); dcl format_sw (30) bit (1) static aligned initial ("0"b, "1"b, "1"b, "1"b, "1"b, "0"b, "0"b, "1"b, /* indicate if arg must match format_arg */ "1"b, "1"b, "1"b, "1"b, "0"b, "1"b, "1"b, "1"b, /* exactly or may have leading -inc_ or -total_ */ "1"b, "1"b, "1"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "1"b, "1"b, "1"b, "1"b, "1"b); dcl date_time_ ext entry (fixed bin (71), char (*)aligned); dcl date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) varying); dcl default_ioa_string char (32) varying int static initial ( "^a ^.3f ^d^a^2/"); dcl default_sw bit (1) static init ("0"b); dcl (level_no, frame_no) fixed bin; dcl level_string char (16) aligned static; dcl level_ioa_string char (34) static initial (" ^[level ^d^;frame ^s^]^[,^]^[^d^]"); dcl listen_$get_level ext entry (fixed bin, fixed bin); dcl ioa_$rsnnl ext entry options (variable); dcl 1 level_descr int static, 2 flag bit (1) init ("1"b), 2 type bit (6) init ("010101"b), 2 packed bit (1) init ("0"b), 2 number_dims bit (4) init ("0000"b), 2 size bit (24) init ("000000000000000000010000"b); dcl ioa_string char (132) aligned int static; dcl 1 ioa_string_descr int static, 2 flag bit (1) initial ("1"b), 2 type bit (6) initial ("010101"b), 2 packed bit (1) initial ("0"b), 2 number_dims bit (4) initial ("0000"b), 2 size bit (24) initial ("000000000000000000001100"b); dcl 1 float_descr int static, 2 flag bit (1) initial ("1"b), 2 type bit (6) initial ("000011"b), 2 packed bit (1) initial ("0"b), 2 number_dims bit (4) initial ("0000"b), 2 scale bit (12) initial ("000000000000"b), 2 precision bit (12) initial ("000000010100"b); dcl 1 integer_descr int static, 2 flag bit (1) initial ("1"b), 2 type bit (6) initial ("000001"b), 2 packed bit (1) initial ("0"b), 2 number_dims bit (4) initial ("0000"b), 2 scale bit (12) initial ("000000000000"b), 2 precision bit (12) initial ("000000100011"b); dcl (total_dollars, inc_dollars, new_dollars, old_dollars, last_dollars, total_mem_units, inc_mem_units, total_vcpu_time, inc_vcpu_time, total_rcpu_time, inc_rcpu_time) float bin (20) int static; dcl (total_pd_faults, total_page_faults, total_seg_faults, total_bounds_faults, total_vtoc_reads, total_vtoc_writes, inc_pd_faults, inc_page_faults, inc_seg_faults, inc_bounds_faults, inc_vtoc_reads, inc_vtoc_writes) fixed bin (35) int static; dcl ZERO_BS fixed bin (35) int static options (constant) init (0); dcl arg char (arglen) unal based (arg_ptr); dcl (arglen, temp_cll) fixed bin; dcl (arg_ptr, temp_clp) ptr; dcl temp_cl char (temp_cll) based (temp_clp); dcl temp_ioa_string char (132) aligned varying; dcl bvs_ptr pointer; dcl 1 temp_ioa_bvss aligned based, 2 length fixed bin, 2 string char (132); dcl 1 based_descr based like temp_ioa_string_descr; dcl 1 af_return_descr like temp_ioa_string_descr unaligned; dcl vs_type bit (6) static initial ("010110"b); dcl 1 temp_ioa_string_descr unaligned, 2 flag bit (1), 2 type bit (6), 2 packed bit (1), 2 number_dims bit (4), 2 size bit (24); dcl 1 temp_ioa_arg_list aligned like ioa_arg_list; dcl (argument_ptr (24), argument_descr_ptr (24)) pointer; dcl (argnumber, af_offset, string_length, number_of_data) fixed bin; dcl old_number_of_data fixed bin internal static; dcl (first_args_flag, total_format_flag, values_set_flag, temp_total_flag, temp_inc_flag, temp_level_flag, temp_frame_flag, temp_set_flag, temp_revert_flag, temp_reset_flag, temp_date_flag, temp_time_flag, temp_date_time_flag, temp_time_format_flag, doing_dollars, incr_string_flag) bit (1) aligned; dcl incr_string char (32) varying; dcl 1 active_string based, 2 next_active_string_ptr ptr, 2 descriptor like active_string_descr_const, 2 num_of_data fixed bin, 2 input_string_len fixed bin, 2 input_string char (input_string_length refer (active_string.input_string_len)); dcl input_string_length fixed bin(21); dcl old_active_string_ptr ptr int static; dcl (active_string_ptr, temp_active_string_ptr) ptr; dcl old_last_active_string_ptr ptr int static; dcl temp_last_active_string_ptr ptr; dcl (n_active_strings, temp_n_active_strings) fixed bin (21); dcl old_n_active_strings fixed bin (21) int static; dcl 1 active_string_descr_const, 2 flag bit (1) initial ("1"b), 2 type bit (6) initial ("010101"b), 2 packed bit (1) initial ("0"b), 2 number_dims bit (4) initial ("0000"b), 2 size bit (24) initial ((24) "0"b); dcl (cu_$arg_ptr, cu_$af_arg_ptr) ext entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl get_arg_ptr_ entry (fixed bin, ptr, fixed bin, fixed bin (35)) variable; dcl code fixed bin (35) static; dcl (com_err_, active_fnc_err_) ext entry options (variable); dcl err_ entry options (variable) variable; %page; %include process_usage; %page; %include cp_active_string_types; %page; %include condition_info; %page; %include condition_info_header; %page; %include sub_err_flags; %page; %include sub_error_info; %page; /* */ new.number_wanted = 9; go to decode_arg_list; /* the code for the message and change_shift entry points is put at the beginning of the program to insure that the code for these entries lies on a single page of the object segment */ message: entry (ready_mode_flags); if old_cl_flag then do; if old_cl_ptr = null then old_cl_ptr = addr (old_cl); begin; dcl cl_copy char (length (based_old_cl)) aligned; cl_copy = based_old_cl; on any_other begin; /* Handle nasty conditions and turn off -call */ on sub_error_ system; /* avoid those loops */ ci.version = condition_info_version_1; call find_condition_info_ (null(), addr (ci), code); if code ^= 0 then do; /* no condition frame */ call sub_err_ (code, whoami, ACTION_DEFAULT_RESTART, null (), (0), "-call disabled."); old_cl_flag = "0"b; return; end; if ci.condition_name = "alrm" | ci.condition_name = "command_question" | ci.condition_name = "cput" | ci.condition_name = "finish" | ci.condition_name = "quit" | ci.condition_name = "sus_" | ci.condition_name = "trm_" then; else do; if old_cl_flag then /* avoid complaining twice */ call sub_err_ ((0), whoami, ACTION_DEFAULT_RESTART, null (), (0), "Condition ^a signalled, -call disabled.", ci.condition_name); old_cl_flag = "0"b; end; call continue_to_signal_ ((0)); end; call cu_$cp (addr (cl_copy), (old_cll), code); revert any_other; end; end; if ^ready_mode_flags.ready_sw then return; temp_ready_flag = "0"b; /* this is from static arg list */ if first_time_flag then do; call setup_ready; if code ^= 0 then return; end; do_ready: if temp_ready_flag then do; /* if general_ready invoked only once */ if temp_clp ^= null () then begin; /* and -call was specified */ dcl temp_cl_copy char (temp_cll) init (temp_cl); call cu_$cp (addr (temp_cl_copy), length (temp_cl_copy), code); end; if af_flag then ioa_ptr = addr (ioa_$rsnpnnl); else ioa_ptr = addr (ioa_$nnl); total_flag = temp_total_flag; inc_flag = temp_inc_flag; cur_arg_list = arg_list_ptr; level_flag = temp_level_flag; frame_flag = temp_frame_flag; time_flag = temp_time_flag; date_flag = temp_date_flag; date_time_flag = temp_date_time_flag; time_format_flag = temp_time_format_flag; time_format = temp_time_format; n_active_strings = temp_n_active_strings; active_string_ptr = temp_active_string_ptr; end; else do; ioa_ptr = addr (ioa_$nnl); total_flag = old_total_flag; inc_flag = old_inc_flag; level_flag = old_level_flag; frame_flag = old_frame_flag; time_flag = old_time_flag; date_flag = old_date_flag; date_time_flag = old_date_time_flag; time_format_flag = old_time_format_flag; time_format = old_time_format; cur_arg_list, arg_list_ptr = static_arg_list_ptr; n_active_strings = old_n_active_strings; active_string_ptr = old_active_string_ptr; number_of_data = old_number_of_data; temp_n_active_strings = 0; af_flag = "0"b; end; now = clock (); call hcs_$get_process_usage (addr (new), code); if code ^= 0 then do; got_pu_err: call err_ (code, whoami, "error in hcs_$get_process_usage."); return; end; new_dollars = float (new.virtual_cpu_time, 20)*vcpu_rate + float (now-first_time, 20)*online_rate + float (new.paging_measure*milli_mu_rate, 20) - dollars_fudge; new.virtual_cpu_time = new.virtual_cpu_time + old.virtual_cpu_time; /* add cpu from previous processes */ new.paging_measure = new.paging_measure + old.paging_measure; call date_time_ (now, dt); if time_flag then time_string = date_time_$format ("time", now, "", ""); if date_flag then date_string = date_time_$format ("date", now, "", ""); if date_time_flag then date_time_string = date_time_$format ("date_time", now, "", ""); if time_format_flag then time_format_string = date_time_$format (time_format, now, "", ""); if total_flag then do; total_dollars = new_dollars; total_pd_faults = new.pd_faults; total_page_faults = new.page_faults; total_seg_faults = new.segment_faults; total_bounds_faults = new.bounds_faults; total_vtoc_reads = new.vtoc_reads; total_vtoc_writes = new.vtoc_writes; total_vcpu_time = float (new.virtual_cpu_time, 20)/1e6; total_mem_units = float (new.paging_measure, 20)/1e3; total_rcpu_time = float (new.cpu_time, 20)/1e6; end; if inc_flag then do; inc_dollars = new_dollars - last_dollars; inc_vcpu_time = float (new.virtual_cpu_time-last.virtual_cpu_time, 20)/1e6; inc_rcpu_time = float (new.cpu_time-last.cpu_time, 20)/1e6; inc_mem_units = float (new.paging_measure-last.paging_measure, 20)/1e3; inc_pd_faults = new.pd_faults - last.pd_faults; inc_page_faults = new.page_faults - last.page_faults; inc_seg_faults = new.segment_faults - last.segment_faults; inc_bounds_faults = new.bounds_faults - last.bounds_faults; inc_vtoc_reads = new.vtoc_reads - last.vtoc_reads; inc_vtoc_writes = new.vtoc_writes - last.vtoc_writes; end; last_dollars = new_dollars; last.paging_measure = new.paging_measure; last.virtual_cpu_time = new.virtual_cpu_time; last.cpu_time = new.cpu_time; last.pd_faults = new.pd_faults; last.page_faults = new.page_faults; last.segment_faults = new.segment_faults; last.bounds_faults = new.bounds_faults; last.vtoc_reads = new.vtoc_reads; last.vtoc_writes = new.vtoc_writes; if default_sw then time_string = date_time_$format ("time", clock (), "", ""); /* if ready message is to contain listener level info, then get it */ if level_flag | frame_flag then do; call listen_$get_level (level_no, frame_no); if level_no = 1 then level_string = ""; else call ioa_$rsnnl (level_ioa_string, level_string, length (level_string), level_flag, level_no, (level_flag & frame_flag), frame_flag, frame_no); set_level_flag = "0"b; end; else level_string = ""; begin; /* begin block for active strings */ dcl active_string_output (n_active_strings) char (256) varying; if ^af_flag then af_offset = 0; else af_offset = 2; do idx = 1 to n_active_strings; active_string_output (idx) = ""; if ^temp_ready_flag then on any_other begin; /* Handle nasty conditions and turn off active string */ on sub_error_ system; /* avoid those loops */ ci.version = condition_info_version_1; call find_condition_info_ (null(), addr (ci), code); if code ^= 0 then do; /* no condition frame */ call sub_err_ (code, whoami, ACTION_DEFAULT_RESTART, null (), (0), "Active string ""^a"" disabled.", active_string_ptr -> active_string.input_string); active_string_ptr -> active_string.input_string = ""; return; end; if ci.condition_name = "alrm" | ci.condition_name = "command_question" | ci.condition_name = "cput" | ci.condition_name = "finish" | ci.condition_name = "program_interrupt" | ci.condition_name = "quit" | ci.condition_name = "sus_" | ci.condition_name = "trm_" then; else do; if active_string_ptr -> active_string.input_string ^= "" then /* avoid complaining twice */ call sub_err_ ((0), whoami, ACTION_DEFAULT_RESTART, null (), (0), "Condition ^a signalled, active string ""^a"" disabled.", ci.condition_name, active_string_ptr -> active_string.input_string); active_string_ptr -> active_string.input_string = ""; end; call continue_to_signal_ ((0)); end; if active_string_ptr -> active_string.input_string ^= "" then call cu_$evaluate_active_string (null(), active_string_ptr -> active_string.input_string, DEFAULT_ACTIVE_STRING, active_string_output (idx), code); revert any_other; if code ^= 0 then do; call sub_err_ (code, whoami, ACTION_DEFAULT_RESTART, null (), (0), "Error evaluating active string ""^a"", active string evaluation disabled.", active_string_ptr -> active_string.input_string); active_string_ptr -> active_string.input_string = ""; end; arg_list.arg_ptrs (active_string_ptr -> active_string.num_of_data + af_offset) = addr (substr (active_string_output (idx), 1)); arg_list.descr_ptrs (active_string_ptr -> active_string.num_of_data + af_offset) = addr (active_string_ptr -> active_string.descriptor); active_string_ptr -> active_string.size = bit (length (active_string_output (idx))); active_string_ptr = active_string_ptr -> active_string.next_active_string_ptr; end; call cu_$gen_call (ioa_ptr, cur_arg_list); /* free temp active strings */ do idx = 1 to temp_n_active_strings; active_string_ptr = temp_active_string_ptr; temp_active_string_ptr = active_string_ptr -> active_string.next_active_string_ptr; free active_string_ptr -> active_string; end; end; return; /* end of message code */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ change_shift: entry; call hcs_$get_process_usage (addr (new), code); if code ^= 0 then go to got_pu_err; now = clock (); call gr_get_rates_ (new_vcpu_rate, new_real_rate, new_process_hour_rate, new_kmu_rate, next_shift); new_vcpu_rate = new_vcpu_rate/3.6e9; new_real_rate = new_real_rate/3.6e9; new_process_hour_rate = new_process_hour_rate/3.6e9; new_online_rate = new_real_rate + new_process_hour_rate; new_milli_mu_rate = new_kmu_rate/1e6; dollars_fudge = new.virtual_cpu_time * (new_vcpu_rate-vcpu_rate) + new.paging_measure * (new_milli_mu_rate-milli_mu_rate) + (now-first_time) * (new_online_rate-online_rate) + dollars_fudge; vcpu_rate = new_vcpu_rate; real_rate = new_real_rate; process_hour_rate = new_process_hour_rate; online_rate = real_rate + process_hour_rate; milli_mu_rate = new_milli_mu_rate; if next_shift > now then call timer_manager_$alarm_call (next_shift, "00"b, change_shift); return; /* end of message and change_shift code */ decode_arg_list: /* general_ready entrypoint gets here */ if first_time_flag then call setup_ready; call cu_$af_return_arg (argnumber, return_ptr, max_length, code); if code = 0 then do; af_flag = "1"b; err_ = active_fnc_err_; get_arg_ptr_ = cu_$af_arg_ptr; end; else do; af_flag = "0"b; err_ = com_err_; get_arg_ptr_ = cu_$arg_ptr; end; temp_ioa_string = "r"; argnumber = 0; number_of_data = 1; /* first arg to ioa is ioa control string */ temp_n_active_strings = 0; temp_active_string_ptr, temp_last_active_string_ptr = null (); set_level_flag = "0"b; first_args_flag = "1"b; do arg_index = lbound (temp_flag, 1) to hbound (temp_flag, 1); temp_flag.inc (arg_index) = "0"b; temp_flag.total (arg_index) = "0"b; end; values_set_flag, temp_total_flag, temp_inc_flag, temp_revert_flag, temp_reset_flag, temp_set_flag = "0"b; doing_dollars = "0"b; incr_string_flag = "1"b; temp_clp = null (); temp_level_flag, temp_frame_flag = "0"b; temp_time_flag, temp_date_flag, temp_date_time_flag, temp_time_format_flag = "0"b; go to read_loop; repeated_option: call err_ (0, whoami, "repeated control arg ^a.", arg); return; read_loop: argnumber = argnumber +1; call get_arg_ptr_ (argnumber, arg_ptr, arglen, code); if code ^= 0 then do; /* done with arg list, now to setup arglist */ end_of_read_loop: if incr_string_flag then temp_ioa_string = temp_ioa_string||"^/"; temp_ioa_string_descr.type = "010101"b; temp_ioa_string_descr.packed = "0"b; temp_ioa_string_descr.number_dims = "0000"b; temp_ioa_string_descr.flag = "1"b; string_length = length (temp_ioa_string); temp_ioa_string_descr.size = bit (bin (string_length, 24), 24); /* set size field */ if ^values_set_flag & ^first_args_flag then do; /* i.e., we got only a non-keyword */ call err_ (error_table_$noarg, whoami, "No values specified for other than default ready message."); return; end; if temp_revert_flag then do; /* process -revert */ if temp_set_flag then do; /* -set and -revert are incompatible */ call err_ (error_table_$inconsistent, whoami, "-set and -revert"); return; end; if old_cl_ptr ^= null & old_cl_ptr ^= addr (old_cl) then free based_old_cl in (sys_area); call cu_$set_ready_proc (null ()); call timer_manager_$reset_alarm_call (change_shift); /* free active strings */ do idx = 1 to old_n_active_strings; active_string_ptr = old_active_string_ptr; old_active_string_ptr = active_string_ptr -> active_string.next_active_string_ptr; free active_string_ptr -> active_string; end; if ^values_set_flag & ^temp_reset_flag then return; /* if no values, just revert */ /* will allow both -revert and -reset */ end; if temp_reset_flag then do; /* reset incremental if -reset */ now = clock (); call hcs_$get_process_usage (addr (new), code); if code ^= 0 then go to got_pu_err; last_dollars = float (new.virtual_cpu_time, 20)*vcpu_rate + float (now - first_time, 20)*online_rate + float (new.paging_measure*milli_mu_rate, 20) - dollars_fudge; last.virtual_cpu_time = new.virtual_cpu_time + old.virtual_cpu_time; last.cpu_time = new.cpu_time + old.cpu_time; last.paging_measure = new.paging_measure + old.paging_measure; last.pd_faults = new.pd_faults; last.page_faults = new.page_faults; last.segment_faults = new.segment_faults; last.bounds_faults = new.bounds_faults; last.vtoc_reads = new.vtoc_reads; last.vtoc_writes = new.vtoc_writes; date_flag = temp_date_flag; time_flag = temp_time_flag; date_time_flag = temp_date_time_flag; time_format_flag = temp_time_format_flag; call date_time_ (now, dt); if date_flag then date_string = date_time_$format ("date", now, "", ""); if time_flag then time_string = date_time_$format ("time", now, "", ""); if date_time_flag then date_time_string = date_time_$format ("date_time", now, "", ""); if time_format_flag then time_format_string = date_time_$format (time_format, now, "", ""); if ^values_set_flag then return; /* if only -reset (or -revert -reset) just return w/o msg */ end; if ^temp_set_flag /* one time only */ then do; arg_list_ptr = addr (temp_ioa_arg_list); bvs_ptr = addr (temp_ioa_string); argument_ptr (1) = addr (bvs_ptr -> temp_ioa_bvss.string); argument_descr_ptr (1) = addr (temp_ioa_string_descr); end; else do; argument_ptr (1) = addr (ioa_string); argument_descr_ptr (1) = addr (ioa_string_descr); ioa_string_descr = temp_ioa_string_descr; ioa_string = temp_ioa_string; if temp_clp ^= null () then do; if old_cl_ptr = null () then string_length = length (old_cl); else string_length = length (based_old_cl); if temp_cll > string_length then do; /* we need more space */ if old_cl_ptr ^= null () & old_cl_ptr ^= addr (old_cl) then free based_old_cl in (sys_area); else area_ptr = get_system_free_area_ (); allocate based_cl in (sys_area) set (cl_ptr); end; else if old_cl_ptr = null then cl_ptr = addr (old_cl); else cl_ptr = old_cl_ptr; old_cll = max (string_length, temp_cll); old_cl_flag = "1"b; old_cl_ptr = cl_ptr; based_old_cl = temp_cl; end; else old_cl_flag = "0"b; old_inc_flag = temp_inc_flag; old_total_flag = temp_total_flag; old_level_flag = temp_level_flag; old_frame_flag = temp_frame_flag; old_time_flag = temp_time_flag; old_date_flag = temp_date_flag; old_date_time_flag = temp_date_time_flag; old_time_format_flag = temp_time_format_flag; old_time_format = temp_time_format; static_arg_list_ptr, arg_list_ptr = addr (ioa_arg_list); /* free old active strings */ do idx = 1 to old_n_active_strings; active_string_ptr = old_active_string_ptr; old_active_string_ptr = active_string_ptr -> active_string.next_active_string_ptr; free active_string_ptr -> active_string; end; old_n_active_strings = temp_n_active_strings; old_active_string_ptr = temp_active_string_ptr; old_number_of_data = number_of_data; end; if incr_string_flag & temp_ioa_string = "r^/" then do; /* Wants default ready message */ default_sw = "1"b; temp_ioa_string = "r^x" || default_ioa_string; call set_default_arg_list; end; else do; default_sw = "0"b; af_offset = 0; do argnumber = 1 to number_of_data; if argnumber = 1 then if af_flag then number_of_data = number_of_data+2; arg_list.arg_ptrs (argnumber+af_offset) = argument_ptr (argnumber); arg_list.descr_ptrs (argnumber+af_offset) = argument_descr_ptr (argnumber); if argnumber = 1 then if af_flag then af_offset = 2; end; arg_list_header.twice_desc_count, arg_list_header.twice_arg_count = 2 * number_of_data; arg_list_header.code = 4; arg_list_header.pad = 0; end; temp_ready_flag = "1"b; /* if we wind up going to do_ready the temp vbls should be used */ if af_flag then do; /* fill in af return arguments */ arg_list.arg_ptrs (2) = addrel (return_ptr, 1); /* ptr to af return arg */ arg_list.arg_ptrs (3) = return_ptr; /* ptr to length word of return arg */ arg_list.descr_ptrs (3) = addr (integer_descr); arg_list.descr_ptrs (2) = addr (af_return_descr); af_return_descr.flag = "1"b; af_return_descr.type = vs_type; af_return_descr.packed = ""b; af_return_descr.number_dims = ""b; af_return_descr.size = bit (bin (max_length, 17), 24); goto do_ready; /* do a ready msg */ end; else if temp_set_flag then do; /* process -set */ call cu_$decode_entry_value (message, return_ptr, null ()); call cu_$set_ready_proc (return_ptr); end; else goto do_ready; /* no -set */ return; /* ready message is set up or printed */ end; /* first_args: */ if first_args_flag then do; do arg_index = 1 to dim (prefix_args, 1); if arg = prefix_args (arg_index) then go to do_prefix (arg_index); end; end; /* end of processing for first args */ else do; check_format: /* check for a format option */ do arg_index = 1 to dim (format_args, 1); if format_sw (arg_index) then if format_args (arg_index) = arg then do; arg_index = real_index (arg_index); if temp_flag.inc (arg_index) then go to repeated_option; temp_flag.inc (arg_index) = "1"b; end; else go to next_format_arg; else do; if (substr (arg, 1, min (arglen, 7)) = "-total_") & (after (arg, "-total_") = format_args (arg_index)) then do; total_format_flag = "1"b; arg_ptr = addr (substr (arg, 8, 1)); arglen = max (arglen-7, 0); end; else if (substr (arg, 1, min (arglen, 5)) = "-inc_") & (after (arg, "-inc_") = format_args (arg_index)) then do; total_format_flag = "0"b; arg_ptr = addr (substr (arg, 6, 1)); arglen = max (arglen-5, 0); end; else go to next_format_arg; arg_index = real_index (arg_index); /* consolidate multiply named options */ if total_format_flag then if temp_flag.total (arg_index) then go to repeated_option; else do; temp_flag.total (arg_index) = "1"b; temp_total_flag = "1"b; end; else if temp_flag.inc (arg_index) then go to repeated_option; else do; temp_flag.inc (arg_index) = "1"b; temp_inc_flag = "1"b; end; end; go to do_format (arg_index); next_format_arg: end; end; /* check for control args */ do arg_index = 1 to dim (control_args, 1); if arg = control_args (arg_index) then if af_flag then do; call err_ (error_table_$badopt, whoami, "^a not allowed when active function", arg); return; end; else goto do_control_arg (arg_index); end; if incr_string_flag then do; if arglen = 0 then go to read_loop; if substr (arg, 1, 1) ^= "-" then do; first_args_flag = "0"b; temp_ioa_string = temp_ioa_string || arg; go to read_loop; end; end; if first_args_flag then do; /* if we haven't checked if arg is a format arg go do it now */ first_args_flag = "0"b; go to check_format; end; call err_ (error_table_$badopt, whoami, "^a.", arg); EXIT_RETURN: return; /* code to execute each format option */ do_format (11): /* -vcpu */ if total_format_flag then temp_argument_ptr = addr (total_vcpu_time); else temp_argument_ptr = addr (inc_vcpu_time); call add_floating_arg; go to read_loop; do_format (13): /* mem_units */ if total_format_flag then temp_argument_ptr = addr (total_mem_units); else temp_argument_ptr = addr (inc_mem_units); call add_floating_arg; go to read_loop; do_format (16): /* -level */ temp_level_flag = "1"b; if ^set_level_flag then do; incr_string = "^a"; temp_argument_ptr = addr (level_string); temp_argument_descr_ptr = addr (level_descr); call add_data_arg; set_level_flag = "1"b; end; go to read_loop; do_format (17): /* -frame */ temp_frame_flag = "1"b; if ^set_level_flag then do; incr_string = "^a"; temp_argument_ptr = addr (level_string); temp_argument_descr_ptr = addr (level_descr); call add_data_arg; set_level_flag = "1"b; end; go to read_loop; do_format (15): /* pf (page faults) */ temp_argument_descr_ptr = addr (integer_descr); incr_string = " ^d"; if total_format_flag then do; temp_argument_ptr = addr (ZERO_BS); call add_data_arg; temp_argument_ptr = addr (total_page_faults); end; else do; temp_argument_ptr = addr (ZERO_BS); call add_data_arg; temp_argument_ptr = addr (inc_page_faults); end; incr_string = "+^d"; call add_data_arg; go to read_loop; do_format (18): /* pft (page faults) */ temp_argument_descr_ptr = addr (integer_descr); if total_format_flag then do; temp_argument_ptr = addr (total_page_faults); end; else do; temp_argument_ptr = addr (inc_page_faults); end; incr_string = " ^d"; call add_data_arg; go to read_loop; do_format (19): /* sf (segment faults) */ temp_argument_descr_ptr = addr (integer_descr); incr_string = " ^d"; if total_format_flag then temp_argument_ptr = addr (total_seg_faults); else temp_argument_ptr = addr (inc_seg_faults); call add_data_arg; go to read_loop; do_format (20): /* bf (bounds faults) */ temp_argument_descr_ptr = addr (integer_descr); incr_string = " ^d"; if total_format_flag then temp_argument_ptr = addr (total_bounds_faults); else temp_argument_ptr = addr (inc_bounds_faults); call add_data_arg; go to read_loop; do_format (21): /* vr (vtoc reads) */ temp_argument_descr_ptr = addr (integer_descr); incr_string = " ^d"; if total_format_flag then temp_argument_ptr = addr (total_vtoc_reads); else temp_argument_ptr = addr (inc_vtoc_reads); call add_data_arg; go to read_loop; do_format (22): /* vw (vtoc writes) */ temp_argument_descr_ptr = addr (integer_descr); incr_string = " ^d"; if total_format_flag then temp_argument_ptr = addr (total_vtoc_writes); else temp_argument_ptr = addr (inc_vtoc_writes); call add_data_arg; go to read_loop; do_format (23): /* rcpu (real cpu) */ if total_format_flag then temp_argument_ptr = addr (total_rcpu_time); else temp_argument_ptr = addr (inc_rcpu_time); call add_floating_arg; go to read_loop; do_format (24): /* -active_string */ incr_string = " ^a"; temp_flag.inc (24) = "0"b; /* may be repeated */ temp_n_active_strings = temp_n_active_strings + 1; argnumber = argnumber + 1; call get_arg_ptr_ (argnumber, arg_ptr, arglen, code); if code ^= 0 then do; call err_ (code, whoami, "An active string must be specified following -active_string."); return; end; call add_active_string; go to read_loop; do_format (12): /* -dollars */ if total_format_flag then temp_argument_ptr = addr (total_dollars); else temp_argument_ptr = addr (inc_dollars); doing_dollars = "1"b; call add_floating_arg; doing_dollars = "0"b; go to read_loop; do_format (4): /* -date_time */ temp_date_time_flag = "1"b; temp_argument_ptr = addr (date_time_string); go to ADD_DATE; do_format (7): /* -date, -dt */ temp_date_flag = "1"b; temp_argument_ptr = addr (date_string); go to ADD_DATE; do_format (1): /* -time, -tm */ temp_time_flag = "1"b; temp_argument_ptr = addr (time_string); go to ADD_DATE; do_format (2): /* -hour */ do_format (3): /* -minute */ do_format (5): /* -zone */ do_format (6): /* -day_name */ do_format (8): /* -month */ do_format (9): /* -day */ do_format (10): /* -year */ temp_argument_ptr = addr (dt_chars (dt_offset (arg_index))); ADD_DATE: dt_offset_index = dt_descr_index (arg_index); temp_argument_descr_ptr = addr (dt_descr (dt_offset_index)); incr_string = dt_incr_string (arg_index); call add_data_arg; go to read_loop; do_format (25): /* -time_format */ argnumber = argnumber + 1; call get_arg_ptr_ (argnumber, arg_ptr, arglen, code); if code ^= 0 then do; call err_ (code, whoami, "A time format string must be specified following -time_format."); return; end; if arglen > length (time_format) then do; call err_ ((0), whoami, "Time format strings must be ^d characters or fewer in length. ^a", length (time_format), arg); return; end; temp_time_format = arg; on sub_error_ begin; call find_condition_info_ (null (), addr (ci), code); if code ^= 0 then call err_ ((0), whoami, "Invalid time format string. ^a", temp_time_format); else do; sub_error_info_ptr = ci.info_ptr; call com_err_ (sub_error_info.status_code, whoami, "^a", sub_error_info.info_string); end; go to EXIT_RETURN; end; time_format_string = date_time_$format (temp_time_format, clock (), "", ""); revert sub_error_; temp_time_format_flag = "1"b; temp_argument_ptr = addr (time_format_string); temp_argument_descr_ptr = addr (dt_descr (3)); incr_string = " ^a"; call add_data_arg; go to read_loop; /* control arg stuff, not allowed if invoked as active function */ do_control_arg (1): /* set */ temp_set_flag = "1"b; go to read_loop; do_control_arg (2): /* -revert */ temp_revert_flag = "1"b; go to read_loop; do_control_arg (3): /* -call */ argnumber = argnumber +1; call get_arg_ptr_ (argnumber, arg_ptr, arglen, code); if code ^= 0 then go to no_sub_arg; temp_clp = arg_ptr; temp_cll = arglen; /* save ptr and length */ values_set_flag = "1"b; go to read_loop; do_control_arg (4): /* -reset */ temp_reset_flag = "1"b; go to read_loop; /* end of control args */ /* prefix args */ do_prefix (2): /* -control */ incr_string_flag = "0"b; do_prefix (1): /* -string */ argnumber = argnumber + 1; call get_arg_ptr_ (argnumber, arg_ptr, arglen, code); if code ^= 0 then do; no_sub_arg: call err_ (code, whoami, "no argument to ^a", arg); return; end; temp_ioa_string = arg; values_set_flag = "1"b; go to read_loop; /* end of control arg code */ /* **************************************** */ add_data_arg: proc; /* internal procedure to add ptrs to argument_ptr(number_of_data) and argument_descr_ptr(number_of_data) and update num data when temp_argument_descr has been set to proper descr. */ number_of_data = number_of_data +1; values_set_flag = "1"b; argument_ptr (number_of_data) = temp_argument_ptr; argument_descr_ptr (number_of_data) = temp_argument_descr_ptr; if incr_string_flag then temp_ioa_string = temp_ioa_string || incr_string; end add_data_arg; /* **************************** */ add_floating_arg: proc; temp_argument_descr_ptr = addr (float_descr); incr_string = " ^.3f"; /* assume default precision for now */ argnumber = argnumber +1; call get_arg_ptr_ (argnumber, arg_ptr, arglen, code); if code = 0 then if (arglen = 1 & arg >= "1" & arg <= "9") | arglen = 0 then incr_string = " ^." || arg || "f"; else go to no_precision; else do; no_precision: if doing_dollars then substr (incr_string, 4, 1) = "2"; argnumber = argnumber - 1; /* arg is keyword */ end; if doing_dollars then do; incr_string = " $" || substr (incr_string, 2); end; call add_data_arg; end add_floating_arg; /* ********************************** */ add_active_string: procedure; /* this procedure sets up an active string */ number_of_data = number_of_data + 1; argument_ptr (number_of_data) = null (); argument_descr_ptr (number_of_data) = null (); values_set_flag = "1"b; if incr_string_flag then temp_ioa_string = temp_ioa_string || incr_string; input_string_length = arglen; if temp_last_active_string_ptr = null () then do; allocate active_string set (temp_last_active_string_ptr); temp_active_string_ptr = temp_last_active_string_ptr; end; else do; allocate active_string set (temp_last_active_string_ptr -> active_string.next_active_string_ptr); temp_last_active_string_ptr = temp_last_active_string_ptr -> active_string.next_active_string_ptr; end; temp_last_active_string_ptr -> active_string.descriptor = active_string_descr_const; temp_last_active_string_ptr -> active_string.num_of_data = number_of_data; temp_last_active_string_ptr -> active_string.input_string_len = input_string_length; temp_last_active_string_ptr -> active_string.input_string = arg; temp_last_active_string_ptr -> active_string.next_active_string_ptr = null (); end add_active_string; /* ********************************** */ /* these internal subroutines should be called with arguments and via decode_descriptor or directly copying manage to encode descriptors for upwards compatibility with desc change. */ setup_ready: proc; old.virtual_cpu_time, last.page_faults, last.pd_faults, old.paging_measure, old.page_faults, old.pd_faults, old.cpu_time, old.segment_faults, old.bounds_faults, old.vtoc_reads, old.vtoc_writes = 0; last_dollars, dollars_fudge = 0e0; call user_info_$usage_data ((0), old.virtual_cpu_time, login_time, first_time, old.paging_measure); call gr_get_rates_ (vcpu_rate, real_rate, process_hour_rate, kmu_rate, next_shift); vcpu_rate = vcpu_rate/3.6e9; real_rate = real_rate/3.6e9; process_hour_rate = process_hour_rate/3.6e9;; milli_mu_rate = kmu_rate/1e6; online_rate = real_rate + process_hour_rate; last.virtual_cpu_time = old.virtual_cpu_time; /* make incremental work first time */ last.paging_measure = old.paging_measure; old_dollars = float (last.virtual_cpu_time, 20)*vcpu_rate+ float (last.paging_measure, 20)*milli_mu_rate + float (first_time-login_time, 20)*online_rate; last_dollars = old_dollars; dollars_fudge = -old_dollars; /* at present there is no way to obtain the value of demand pages for a previous process during same login. Thus these values are zeroed. Eventually Multics will provide this information and this program can be updated. */ old_n_active_strings = 0; old_active_string_ptr, old_last_active_string_ptr = null (); static_arg_list_ptr, arg_list_ptr = addr (ioa_arg_list); temp_set_flag = "1"b; /* want to set static values */ af_flag = "0"b; temp_ioa_string = "r^x" || default_ioa_string; call set_default_arg_list; first_time_flag = "0"b; if next_shift > 0 then call timer_manager_$alarm_call (next_shift, "00"b, change_shift); return; end setup_ready; /* **************************** */ set_default_arg_list: proc; af_offset = 2*fixed (af_flag, 17, 0); number_of_data = 5+af_offset; arg_list_header.twice_arg_count, arg_list_header.twice_desc_count = 2*number_of_data; arg_list_header.code = 4; arg_list_header.pad = 0; if temp_set_flag then do; ioa_string = temp_ioa_string; arg_ptrs (1) = addr (ioa_string); descr_ptrs (1) = addr (ioa_string_descr); descr_ptrs (1) -> based_descr.size = bit (bin (length (temp_ioa_string), 24), 24); old_inc_flag = "1"b; old_level_flag = "1"b; old_time_flag = "1"b; end; else do; arg_ptrs (1) = addr (addr (temp_ioa_string) -> temp_ioa_bvss.string); descr_ptrs (1) = addr (temp_ioa_string_descr); temp_ioa_string_descr.type = "010101"b; temp_ioa_string_descr.packed = "0"b; temp_ioa_string_descr.number_dims = "0000"b; temp_ioa_string_descr.flag = "1"b; string_length = length (temp_ioa_string); temp_ioa_string_descr.size = bit (bin (string_length, 24), 24); temp_inc_flag = "1"b; temp_level_flag = "1"b; temp_time_flag = "1"b; end; arg_ptrs (2+af_offset) = addr (time_string); descr_ptrs (2+af_offset) = addr (dt_descr (3)); arg_ptrs (3+af_offset) = addr (inc_vcpu_time); descr_ptrs (3+af_offset) = addr (float_descr); arg_ptrs (4+af_offset) = addr (inc_page_faults); descr_ptrs (4+af_offset) = addr (integer_descr); arg_ptrs (5+af_offset) = addr (level_string); descr_ptrs (5+af_offset) = addr (level_descr); end set_default_arg_list; end general_ready;  get_shortest_path_.pl1 03/29/84 1510.0r 03/15/84 0819.2 97236 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */ get_shortest_path_: proc (P_path) returns (char (168)); /* DESCRIPTION: Replaces every directory component it has access to with the shortest name on the directory. If for any component multiple shortest names are found, three steps are taken to give what is hopefully the optimum name for the user. First, try to get rid of any names with upper case characters in them and reduce the list of candidate names to this set. If multiple names still exist, take the first char. of the primary name and take the first short name whose first char. matches it case independently. If this fails, return the first shortest name found. */ /* HISTORY: Written by S. Herbst, 10/01/81. Modified: 11/16/82 by S. Herbst: Added cleanup handler and made it replace names of links to dirs. 09/13/83 by Lee A. Newcomb: made to give precidence to names without upper case chars, then names matching 1st char of primary name. Also made status_branch an automatic structure, and fixed bug where status_entry_names structure was never freed. 01/30/84 by L. A. Newcomb: fixed bug in freeing the status_entry_names structure if the pathname supplied is a link (i.e., the last pathname component is a link, but we don't care about the other directory components of the pathname). */ %page; /* START OF DECLARATIONS */ /* Parameter */ dcl P_path char (*) /* path to get shortest_path of */ parameter; /* Automatic */ dcl ( code fixed bin (35), /* status/error code */ ename char (32), /* used in hcs_$status_ to get all enames */ entry_names_p ptr, /* for getting to (status_)entry_names faster */ i fixed bin (21), /* used in indexing into orginal_path */ input_path char (528) varying, /* 528 max. for paths */ original_path char (528), /* after being pased through absolute_pathname_ */ output_path char (528) varying, /* we build it as we go */ start fixed bin (21) /* for walking through the given name */ ) automatic; /* Automatic Structures */ dcl 1 local_status_branch like status_branch aligned automatic; /* CONSTANTS */ dcl ( LOWER_CHARS char (26) init ("abcdefghijklmnopqrstuvwxyz"), NO_CHASE fixed bin (1) init (0), UPPER_CHARS char (26) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ") ) internal static options (constant); /* Based */ dcl entry_names aligned char (32) /* like status_entry_names */ dim (status_branch.nnames) based (entry_names_p), status_area area based (status_area_ptr); /* Entries */ dcl absolute_pathname_ entry (char (*), char (*), fixed (35)), get_system_free_area_ entry returns (ptr), hcs_$status_ entry (char (*), char (*), fixed (1), ptr, ptr, fixed (35)); /* Builtins & Conditions */ dcl (addr, index, length, null, pointer, rtrim, search, substr, translate) builtin, cleanup condition; /* END OF DECLARATIONS */ %page; call absolute_pathname_ (P_path, original_path, code); /* get the complete pathname string */ if code ^= 0 then /* failure, can only return input data */ return (P_path); if original_path = ">" then /* the ROOT is kind of short to start with */ return (">"); input_path = rtrim (original_path); /* copy to varying string */ output_path = ">"; /* always start at the ROOT */ start = 2; /* ignore first ">" in path */ status_area_ptr = get_system_free_area_ (); /* where to allocate status_names */ status_ptr = addr (local_status_branch); /* use auto storage for the basic structure */ status_branch.names_relp = ""b; /* for cleanup */ entry_names_p = null (); /* for safety in cleanup */ on cleanup begin; if status_branch.names_relp ^= ""b then if entry_names_p ^= null () then /* take care of window between setting names_relp and ptr */ free entry_names in (status_area); /* so we don't free twice */ end; do while (start <= length (input_path)); /* main loop, go until nothing left */ /* get next ename to shorten */ i = index (substr (input_path, start), ">"); if i ^= 0 then ename = substr (input_path, start, i - 1); else do; ename = substr (input_path, start); i = length (input_path) + 1; /* to stop loop */ end; call hcs_$status_ ((output_path), ename, NO_CHASE, status_ptr, status_area_ptr, code); if code = 0 then /* make freeing work */ entry_names_p = pointer (status_area_ptr, status_branch.names_relp); if code = 0 & (status_branch.type = Directory | /* replace only directory names */ (status_branch.type = Link & i <= length (input_path))) then /* and names of links to dirs */ ename = select_shortest_entry_name (); /* possibly replace original name */ if code = 0 then do; /* must free names struct. */ status_branch.names_relp = ""b; /* to prevent multiple frees by cleanup handler */ free entry_names in (status_area); /* and use our version of the structure for freeing */ entry_names_p = null (); /* so ptr is null between relp setting and ptr calculation */ end; /* ename still holds name to use */ if length (output_path) > 1 then /* most common case */ output_path = output_path || ">" || rtrim (ename); else output_path = ">" || rtrim (ename); /* don't double up the first ">" */ start = start + i; /* update loop control */ end; return ((output_path)); /* end get_shortest_path_; */ %page; select_shortest_entry_name: proc () returns (char (32)); /* This procedure selects the shortest name in the currently available */ /* status_entry_names array. For efficiency and ease of programming, */ /* the entry_names array has been declared and given an explicit ptr. */ /* The necessity for this procedure is to allocate the name index */ /* as we have no idea at the time get_shortest_path_'s stack frame is */ /* laid down what the max size required will be. */ /* START OF DECLARATIONS */ /* Automatic */ dcl ( curr_shortest_length fixed bin (21), /* shortest entryname length at any point in selection */ name_idx fixed bin, /* for walking throught status_names struct. */ n_lower_names fixed bin, /* # of entrynames of the same length with no upper */ /* case chars; must be <= n_shortest_names */ n_shortest_names fixed bin, /* # of shortest entrynames of same length */ primary_ename_fchar char (1) aligned, /* 1st char. of primary entryname for selecting */ /* between multiple shortest names of same length */ shortest_name_idxs fixed bin dim (status_branch.nnames) /* for getting the SHORTEST entrynames */ /* dcl'd this way to not have to program */ /* for a staticly dcl'd array overflow */ ) automatic; /* END OF DECLARATIONS */ n_shortest_names = 1; /* to start */ shortest_name_idxs (1) = 1; curr_shortest_length = length (rtrim (entry_names (1))); do name_idx = 2 to status_branch.nnames; if length (rtrim (entry_names (name_idx))) < curr_shortest_length then do; /* new shortest length */ curr_shortest_length = length (rtrim (entry_names (name_idx))); n_shortest_names = 1; /* must restart list */ shortest_name_idxs (1) = name_idx; end; else if length (rtrim (entry_names (name_idx))) = curr_shortest_length then do; /* add to current list */ n_shortest_names = n_shortest_names + 1; shortest_name_idxs (n_shortest_names) = name_idx; end; else ; /* name too long ==> uninteresting */ end; /* if only one name is left, we have our answer */ if n_shortest_names = 1 then /* done */ return (entry_names (shortest_name_idxs (1))); %page; /* More work needed: all names we have saved indices of are of the same */ /* length see if any are all lower case or valid non-alpha chars. We */ /* will share the current index array if any names show up not containing */ /* any upper case characters. */ n_lower_names = 0; /* we share the current index array */ do name_idx = 1 to n_shortest_names; if search (entry_names (shortest_name_idxs (name_idx)), UPPER_CHARS) = 0 then do; n_lower_names = n_lower_names + 1; /* no upper case chars */ shortest_name_idxs (n_lower_names) = shortest_name_idxs (name_idx); end; end; /* If one non-upper name was found, we return it */ if n_lower_names = 1 then /* done */ return (entry_names (shortest_name_idxs (1))); /* We know we need to do compare with first char of primary name case */ /* independently. First, we make sure we have that char in lower */ /* if it is upper case. */ primary_ename_fchar = translate (substr (entry_names (1), 1, 1), LOWER_CHARS, UPPER_CHARS); /* If we know only non-upper case names are around, do small optimization */ if n_lower_names > 1 then do; do name_idx = 1 to n_lower_names; /* will break out of loop on a match */ if primary_ename_fchar = substr (entry_names (shortest_name_idxs (name_idx)), 1, 1) then return (entry_names (shortest_name_idxs (name_idx))); /* done */ end; /* no match, return 1st non-upper name */ return (entry_names (shortest_name_idxs (1))); /* done */ end; /* If there were no non-upper case names, we must do a translation for */ /* the fchar compare. This is the only effective difference between the */ /* previous compare loop and the following one. */ do name_idx = 1 to n_shortest_names; if primary_ename_fchar = translate (substr (entry_names ( shortest_name_idxs (name_idx)), 1, 1), LOWER_CHARS, UPPER_CHARS) then return (entry_names (shortest_name_idxs (name_idx))); /* done */ end; /* no first char match on multiple names of same shortest length. */ /* We just return the first shortest name found */ return (entry_names (shortest_name_idxs (1))); /* done */ end select_shortest_entry_name; %page;%include status_structures; end get_shortest_path_;  gr_get_rates_.pl1 11/04/82 2003.4rew 11/04/82 1630.8 28215 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ gr_get_rates_: proc (cpu_rate, real_rate, io_ops_rate, kmu_rate, next_shift); dcl next_shift fixed bin (71); dcl (dv_index, number_of_devices) fixed bin; dcl tty_charge_type char (8); dcl (cpu_rate, real_rate, io_ops_rate, kmu_rate) float bin; dcl ip ptr; dcl ec fixed bin; dcl shift_index fixed bin; dcl abs_queue fixed bin; dcl part_of_week fixed bin (71); dcl time fixed bin (71); dcl s fixed bin; dcl shift fixed bin; dcl shift_tab (336) fixed bin; dcl (cpu (0:7), log (0:7), io_ops (0:7), cor (0:7), dsk, reg, abs_cpu_rate (4), abs_kmu_rate (4)) float bin; dcl user_info_$terminal_data ext entry (char(*), char(*), char(*), fixed bin, char(*)); dcl system_info_$device_prices ext entry options (variable); dcl user_info_$absentee_queue ext entry (fixed bin); dcl system_info_$shift_table ext entry ((336) fixed bin); dcl system_info_$next_shift_change ext entry (fixed, fixed bin (71)); dcl system_info_$prices ext entry ((0:7) float bin, (0:7) float bin, (0:7) float bin, (0:7) float bin, float bin, float bin); dcl system_info_$abs_prices ext entry ((4) float bin, (4) float bin); dcl sys_info$time_delta fixed bin (35) ext static; dcl (fixed, divide, mod) builtin; call user_info_$absentee_queue (abs_queue); /* are we executing in an absentee process and if so, what queue are we in? */ if abs_queue > 0 then do; call system_info_$abs_prices (abs_cpu_rate, abs_kmu_rate); cpu_rate = abs_cpu_rate (abs_queue); kmu_rate = abs_kmu_rate (abs_queue); real_rate, io_ops_rate = 0.; next_shift = 0; end; else do; call system_info_$prices (cpu, log, io_ops, cor, dsk, reg); /* get prices for various things for each shift */ call system_info_$next_shift_change (s, next_shift); /* this may differ from static system data */ /* return prices */ cpu_rate = cpu (s); io_ops_rate = io_ops (s); kmu_rate = cor (s); real_rate = log (s); /* get connect time base price */ /* now determine surcharge on login rate */ call user_info_$terminal_data ("", "", "", 0, tty_charge_type); call system_info_$device_prices (number_of_devices); begin; dcl 1 dvt (number_of_devices) aligned, 2 id char (8), 2 prices (0:7) float bin (27); call system_info_$device_prices ((0), addr (dvt)); do dv_index = 1 to number_of_devices; if tty_charge_type = dvt.id (dv_index) then do; real_rate = real_rate + dvt.prices (dv_index, s); /* add in surcharge */ dv_index = number_of_devices; end; end; end; end; end;  hex.pl1 11/04/82 2003.4rew 11/04/82 1630.8 41571 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ hexadecimal: hex: proc; /* Implements the hexadecimal, decimal, octal and binary commands/afs. Written 03/09/81 S. Herbst */ /* Based */ dcl arg char (arg_len) based (arg_ptr); dcl return_arg char (return_len) varying based (return_ptr); /* Automatic */ dcl ME char (32); dcl val_str char (72) varying; dcl af_sw bit (1) aligned; dcl (arg_ptr, return_ptr) ptr; dcl char8 char (8); dcl float59 float dec (59); dcl fixed71 fixed bin (71); dcl (arg_len, return_len) fixed bin (21); dcl (digit_val, input_base) fixed bin (5); dcl (arg_count, arg_index, base, i, point_count) fixed bin; dcl code fixed bin (35); dcl error_table_$bad_conversion fixed bin (35) ext; dcl error_table_$not_act_fnc fixed bin (35) ext; dcl complain entry variable options (variable); dcl (active_fnc_err_, active_fnc_err_$af_suppress_name) entry options (variable); dcl (com_err_, com_err_$suppress_name) 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 (ioa_, ioa_$nnl) entry options (variable); dcl numeric_to_ascii_base_ entry (float dec (59), fixed bin, fixed bin) returns (char (72) varying); dcl (convert, decimal, index, low, substr, unspec) builtin; dcl (conversion, overflow, underflow) condition; %page; ME = "hexadecimal"; base = 16; go to START; decimal: dec: entry; ME = "decimal"; base = 10; go to START; octal: oct: entry; ME = "octal"; base = 8; go to START; binary: bin: entry; ME = "binary"; base = 2; go to START; START: call cu_$af_return_arg (arg_count, return_ptr, return_len, code); if code = error_table_$not_act_fnc then do; if arg_count = 0 then do; call com_err_$suppress_name (0, ME, "Usage: ^a num_args", ME); return; end; af_sw = "0"b; complain = com_err_; end; else if code = 0 then do; if arg_count = 0 then do; call active_fnc_err_$af_suppress_name (0, ME, "Usage: [^a num_args]", ME); return; end; af_sw = "1"b; complain = active_fnc_err_; return_arg = ""; end; else do; call active_fnc_err_ (code, ME); return; end; on conversion, overflow, underflow go to BAD_NUM; do arg_index = 1 to arg_count; call cu_$arg_ptr (arg_index, arg_ptr, arg_len, code); if arg_len = 0 then float59 = 0; else do; i = index ("bqox", substr (arg, arg_len, 1)); if i ^= 0 then do; input_base = 2 ** i; float59 = 0; point_count = -1; /* scanning for decimal point */ do i = 1 to arg_len - 1; if substr (arg, i, 1) = "." then do; if point_count >= 0 then do; BAD_NUM: call complain (error_table_$bad_conversion, ME, "^a", arg); return; end; point_count = 0; end; else do; digit_val = index ("0123456789ABCDEFabcdef", substr (arg, i, 1)) - 1; if digit_val < 0 then go to BAD_NUM; if digit_val > 15 then digit_val = digit_val - 6; /* lowercase abcdef */ if digit_val >= input_base then go to BAD_NUM; if point_count >= 0 then point_count = point_count + 1; /* after the decimal point */ float59 = float59 * decimal (input_base, 2) + decimal (digit_val, 2); end; end; if point_count > 0 then /* decimal point in the input */ float59 = float59 / decimal (input_base ** point_count); end; else if substr (arg, arg_len, 1) = "u" then do; /* unspec */ arg_len = arg_len - 1; if arg_len > 8 then do; call complain (0, ME, """u"" conversion only allows 8 characters. ^au", arg); return; end; char8 = low (8 - arg_len) || arg; unspec (fixed71) = unspec (char8); float59 = fixed71; end; else float59 = convert (float59, arg); end; val_str = numeric_to_ascii_base_ (float59, 0, base); APPEND: if af_sw then do; if return_arg ^= "" then return_arg = return_arg || " "; return_arg = return_arg || val_str; end; else call ioa_$nnl ("^a ", val_str); end; if ^af_sw then call ioa_ (""); end hexadecimal;  if.pl1 11/04/82 2003.4rew 11/04/82 1610.0 126864 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Conditionally executes one of two command/request lines; as an active function/request, conditionally returns one of two strings */ /* Created: September 1970 by THVV */ /* Modified: 27 April 1976 by Steve Herbst to accept keys "true" and "false" */ /* Modified: 17 February 1982 by G. Palter to add ssu_if_request_ and convert to use a standalone subsystem invocation */ /* Modified: 8 September 1982 by G. Palter to propogate subsystem/request line aborts */ /* format: style4,delnl,insnl,ifthenstmt,ifthen */ if: procedure () options (variable); dcl P_sci_ptr pointer parameter; /* ssu_if_request_: -> SCI of subsystem */ dcl P_info_ptr pointer parameter; /* ssu_if_request_: -> subsystem's internal data */ dcl sci_ptr pointer; dcl standalone_invocation bit (1) aligned; dcl active_function bit (1) aligned; dcl nargs fixed binary; dcl return_string char (rl) varying based (rp); dcl rl fixed binary (21); dcl rp pointer; dcl argument character (al) based (ap); dcl al fixed binary (21); dcl ap pointer; dcl second_argument character (cl) based (cp); dcl cl fixed binary (21); dcl cp pointer; dcl key character (8); dcl an fixed binary; dcl notsw bit (1) aligned; dcl thenloc fixed binary; dcl elseloc fixed binary; dcl ec fixed binary (35); dcl i fixed binary; dcl (first_number, second_number) fixed binary (35); dcl chase fixed binary (1); dcl type fixed binary (2); dcl bc fixed binary (24); dcl dn character (168); dcl en character (32); dcl timestr character (24); dcl yes_no_sw bit (1); dcl error_table_$bad_conversion fixed binary (35) external; dcl error_table_$noarg fixed binary (35) external; dcl ssu_et_$null_request_line fixed binary (35) external; dcl ssu_et_$subsystem_aborted fixed binary (35) external; dcl active_fnc_err_ entry () options (variable); dcl com_err_ entry () options (variable); dcl command_query_$yes_no entry () options (variable); dcl cu_$af_return_arg entry (fixed binary, pointer, fixed binary (21)) returns (fixed binary (35)); dcl cu_$arg_list_ptr entry () returns (pointer); dcl cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35)); dcl date_time_ entry (fixed binary (71), character (*)); dcl expand_pathname_ entry (character (*), character (*), character (*), fixed binary (35)); dcl hcs_$status_minf entry (character (*), character (*), fixed binary (1), fixed binary (2), fixed binary (24), fixed binary (35)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$abort_subsystem entry () options (variable); dcl ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21)); dcl ssu_$destroy_invocation entry (pointer); dcl ssu_$execute_line entry (pointer, pointer, fixed binary (21), fixed binary (35)); dcl ssu_$get_subsystem_and_request_name entry (pointer) returns (character (72) varying); dcl ssu_$get_request_name entry (pointer) returns (character (32)); dcl ssu_$return_arg entry (pointer, fixed binary, bit (1) aligned, pointer, fixed binary (21)); dcl ssu_$standalone_invocation entry (pointer, character (*), character (*), pointer, entry, fixed binary (35)); dcl cleanup condition; dcl (clock, null, substr) builtin; /* */ /* Multics if command/active-function */ /* if: entry () options (variable); */ standalone_invocation = "1"b; /* must create a standalone subsystem to do this */ call ssu_$standalone_invocation (sci_ptr, "if", "1.0", cu_$arg_list_ptr (), abort_if_command, ec); if ec ^= 0 then do; /* please forgive the following, but ... */ if cu_$af_return_arg (0, (null ()), (0)) = 0 then call active_fnc_err_ (ec, "if", "Can not establish standalone subsystem invocation."); else call com_err_ (ec, "if", "Can not establish standalone subsystem invocation."); return; end; go to COMMON; /* Standard subsystem if request */ ssu_if_request_: entry (P_sci_ptr, P_info_ptr); standalone_invocation = "0"b; /* caller supplied the subsystem */ sci_ptr = P_sci_ptr; go to COMMON; /* Actual work starts here */ COMMON: on condition (cleanup) begin; if standalone_invocation then call ssu_$destroy_invocation (sci_ptr); end; call ssu_$return_arg (sci_ptr, nargs, active_function, rp, rl); if nargs = 0 then /* abort_line never returns */ PRINT_USAGE_MESSAGE: if active_function then call ssu_$abort_line (sci_ptr, 0, "Usage: [^a key -then {value1} {-else value2}]", ssu_$get_request_name (sci_ptr)); else call ssu_$abort_line (sci_ptr, 0, "Usage: ^a key -then {^[command^;request^]1} {-else ^[command^;request^]2}", ssu_$get_request_name (sci_ptr), standalone_invocation, standalone_invocation); an = 2; /* index of first argument after the key */ notsw = "0"b; /* do not invert the test */ thenloc, elseloc = 0; /* no -then or -else yet */ chase = 1; /* chase links by default */ /* Get the keyword */ call ssu_$arg_ptr (sci_ptr, 1, ap, al); key = argument; if key = "-not" then do; /* users wishes to invert the test */ notsw = "1"b; an = an + 1; /* next argument is the keyword */ call ssu_$arg_ptr (sci_ptr, 2, ap, al); key = argument; end; else if substr (key, 1, 1) = "^" then do; /* users wises to invert the test */ key = substr (key, 2, 7); notsw = "1"b; end; /* Locate then and else clauses (if any) and validate command/request syntax */ do i = an to nargs; call ssu_$arg_ptr (sci_ptr, i, ap, al); if argument = "-then" then do; if thenloc ^= 0 then go to PRINT_USAGE_MESSAGE; thenloc = i; /* remember location of "-then" */ end; else if argument = "-else" then do; if elseloc ^= 0 then go to PRINT_USAGE_MESSAGE; elseloc = i; /* remember location of "-else" */ end; end; if thenloc = 0 then go to PRINT_USAGE_MESSAGE; /* -then must be supplied */ if elseloc > 0 then do; /* -else must follow -then with, at most, one ... */ if elseloc < thenloc then go to PRINT_USAGE_MESSAGE; if elseloc > (thenloc + 2) then go to PRINT_USAGE_MESSAGE; if (elseloc + 1) ^= nargs then go to PRINT_USAGE_MESSAGE; end; /* ... intervening argument and must be followed by one */ else do; /* -then alone: it may be followed by no more than one arg */ if nargs > (thenloc + 1) then go to PRINT_USAGE_MESSAGE; end; /* Determine results of the key (execution/no-execution) */ if key = "true" then go to RESULT_IS_TRUE; /* key was an active string */ if key = "false" then go to RESULT_IS_FALSE; /* key was an active string */ if key = "is" then do; /* check that a branch (seg/MSF/dir) exists */ CHECK_ENTRY_EXISTENCE: if an = thenloc then /* no pathname was supplied */ call ssu_$abort_line (sci_ptr, error_table_$noarg, "Pathname after ""^a"".", key); call ssu_$arg_ptr (sci_ptr, an, ap, al); call expand_pathname_ (argument, dn, en, ec); if ec ^= 0 then go to STATUS_MINF_CALL_FAILS;/* bad pathname: same as no entry */ if key = "islink" then chase = 0; /* look for a link */ if key = "isfile" then chase = 0; /* look for a segment */ if key = "isdir" then chase = 0; /* look for a directory */ call hcs_$status_minf (dn, en, chase, type, bc, ec); if ec ^= 0 then STATUS_MINF_CALL_FAILS: /* entry does not exist */ if key = "isnt" then go to RESULT_IS_TRUE; else go to RESULT_IS_FALSE; if key = "is" then go to RESULT_IS_TRUE; /* entry is there */ if key = "isnt" then go to RESULT_IS_FALSE; /* entry is there: asked if it wasn't */ if key = "isdir" then /* looking for a directory */ if type = 2 then go to RESULT_IS_TRUE; if key = "islink" then /* looking for a link */ if type = 0 then go to RESULT_IS_TRUE; if key = "isfile" then /* looking for a segment */ if type = 1 then go to RESULT_IS_TRUE; if key = "isnzf" then /* looking for a non-zero length segment */ if (type = 1) & (bc > 0) then go to RESULT_IS_TRUE; go to RESULT_IS_FALSE; /* here iff test failed */ end; else if key = "isnt" then go to CHECK_ENTRY_EXISTENCE; /* check for non-existence of a branch */ else if key = "isfile" then go to CHECK_ENTRY_EXISTENCE; /* check for existence of a segment */ else if key = "isdir" then go to CHECK_ENTRY_EXISTENCE; /* check for existence of a directory */ else if key = "islink" then go to CHECK_ENTRY_EXISTENCE; /* check for existence of a link */ else if key = "isnzf" then go to CHECK_ENTRY_EXISTENCE; /* check for existence of a non-zero length segment */ else if key = "arg" then /* check for an argument after the key and before -then */ if an = thenloc then go to RESULT_IS_FALSE; else go to RESULT_IS_TRUE; else if key = "noarg" then /* check that no argument follows key */ if an = thenloc then go to RESULT_IS_TRUE; else go to RESULT_IS_FALSE; else if key = "day" then do; /* check the date: arg after key is day name or day of month */ if an = thenloc then go to RESULT_IS_FALSE; call ssu_$arg_ptr (sci_ptr, an, ap, al); call date_time_ (clock (), timestr); /* read the clock */ if substr (argument, 1, 1) > "A" then /* alphabetic: check day of week */ if substr (argument, 1, 3) = substr (timestr, 22, 3) then go to RESULT_IS_TRUE; else go to RESULT_IS_FALSE; else if argument = substr (timestr, 4, 2) then go to RESULT_IS_TRUE; else go to RESULT_IS_FALSE; end; else if key = "argeq" then do; /* check two arguments after key for equality */ if an = thenloc then go to RESULT_IS_TRUE; /* ... neither given */ if an = (thenloc - 1) then go to RESULT_IS_FALSE; /* ... only one is given: can't be equal */ call ssu_$arg_ptr (sci_ptr, an, ap, al); call ssu_$arg_ptr (sci_ptr, (an + 1), cp, cl); if argument = second_argument then go to RESULT_IS_TRUE; else go to RESULT_IS_FALSE; end; else if key = "ask" then do; /* ask a question */ if an = thenloc then /* ... question was already typed */ call command_query_$yes_no (yes_no_sw, 0, ssu_$get_subsystem_and_request_name (sci_ptr), "", "?"); else do; /* ... pickup question after the key */ call ssu_$arg_ptr (sci_ptr, an, ap, al); call command_query_$yes_no (yes_no_sw, 0, ssu_$get_subsystem_and_request_name (sci_ptr), "", argument) ; end; if yes_no_sw then go to RESULT_IS_TRUE; else go to RESULT_IS_FALSE; end; else if key = "less" then do; /* numerical checks */ NUMERICAL_COMPARISONS: if an = thenloc then go to RESULT_IS_FALSE; /* both arguments must be there */ if an = (thenloc - 1) then go to RESULT_IS_FALSE; call ssu_$arg_ptr (sci_ptr, an, ap, al); first_number = cv_dec_check_ (argument, ec); if ec ^= 0 then NON_NUMERIC_ARGUMENT: call ssu_$abort_line (sci_ptr, error_table_$bad_conversion, "^a", argument); call ssu_$arg_ptr (sci_ptr, (an + 1), ap, al); second_number = cv_dec_check_ (argument, ec); if ec ^= 0 then go to NON_NUMERIC_ARGUMENT; if first_number < second_number then if key = "less" then go to RESULT_IS_TRUE; else go to RESULT_IS_FALSE; else if first_number > second_number then if key = "less" then go to RESULT_IS_FALSE; else go to RESULT_IS_TRUE; else go to RESULT_IS_FALSE; /* no check for equality on numbers */ end; else if (key = "greater") | (key = "grt") then go to NUMERICAL_COMPARISONS; else if key = "number" then do; /* check that argument after key is a number */ if an = thenloc then go to RESULT_IS_FALSE; /* ... not there */ call ssu_$arg_ptr (sci_ptr, an, ap, al); first_number = cv_dec_check_ (argument, ec); if ec = 0 then go to RESULT_IS_TRUE; else go to RESULT_IS_FALSE; end; else call ssu_$abort_line (sci_ptr, 0, "Unknown keyword ""^a"".", key); /* Result of the test was false */ RESULT_IS_FALSE: if notsw then go to RESULT_IS_REALLY_TRUE; /* sense of test was reversed */ RESULT_IS_REALLY_FALSE: if elseloc = 0 then go to RETURN_FROM_IF; /* no else clause */ an = elseloc + 1; /* find where else clause is */ go to EXECUTE_OR_RETURN_STRING; /* Result of the test was true */ RESULT_IS_TRUE: if notsw then go to RESULT_IS_REALLY_FALSE; /* sense of the test was reversed */ RESULT_IS_REALLY_TRUE: an = thenloc + 1; /* argument index of then clause (if present) */ if an = elseloc then go to RETURN_FROM_IF; /* a null then clause */ /* Execute/return the selected string */ EXECUTE_OR_RETURN_STRING: if an > nargs then go to RETURN_FROM_IF; /* clause is not present */ call ssu_$arg_ptr (sci_ptr, an, ap, al); if active_function then /* active function/request: return the string */ return_string = argument; else do; /* command/request: execute it */ if al > 0 then call ssu_$execute_line (sci_ptr, ap, al, ec); if ^standalone_invocation & (ec ^= 0) & (ec ^= ssu_et_$null_request_line) then if ec = ssu_et_$subsystem_aborted then call ssu_$abort_subsystem (sci_ptr); else call ssu_$abort_line (sci_ptr); end; /* Clean up */ RETURN_FROM_IF: if standalone_invocation then /* we created the invocation */ call ssu_$destroy_invocation (sci_ptr); return; /* Internal procedure invoked by ssu_$abort_line when if was invoked as a Multics command/active function */ abort_if_command: procedure (); go to RETURN_FROM_IF; /* message has been printed: now we can punt */ end abort_if_command; end if;  index_set.pl1 03/01/89 1410.1rew 03/01/89 1357.1 178722 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-01-16,TLNguyen), approve(89-01-27,MCR8053), audit(89-02-23,RBarstad), install(89-03-01,MR12.3-1018): 1. Modify "Syntax" portion in comment lines stated at the beginning of the source program to provide more information for usage. 2. Fix stringrange condition raised at the run time during testing period. 3. Fix the bug occured when given L <= U and -I. For examples: index_set 1 1 -1; index_set -7 -5 -2 END HISTORY COMMENTS */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* index_set active function & command */ /* */ /* Function: returns/prints one or more sets of numbers. Numbers are separated from */ /* one another by a space. Each set contains numbers in the sequence: */ /* */ /* L, L+I, L+2I, L+3I, ... L+kI */ /* */ /* where k is the largest integer such that L+kI<=U. L, U, and I are integers (either */ /* positive or negative) representing the lowest number of each set, an upper bound */ /* on set elements, and an increment between numbers of the set. */ /* */ /* Syntax: */ /* case 1: [index_set U] is equivalent to [index_set 1 U 1] */ /* */ /* case 2: [index_set L U] */ /* is equivalent to [index_set L U 1] if L <= U */ /* is equivalent to [index_set L U -1] if L > U */ /* */ /* case 3: [index_set L U -I] */ /* is treated as [index_set L U I] if L <= U */ /* */ /* case 4: [index_set L U I] */ /* is treated as [index_set L U -I] if L > U */ /* */ /* case 5: [index_set L1 U1 I1 ... Ln Un In] */ /* */ /* Status: */ /* 0) Recoded by Gary Dixon, June 1978. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Fixed to handle "index_set 0 0" and reject increments of 0 - 07/07/81 S. Herbst */ index_set: procedure; /* This active function returns a string of no. */ dcl (Larg, Lret, Ls) fixed bin(21), (Nargs, Ngroups) fixed bin, (Parg, Parg_list, Pret) ptr, Scommand bit(1) aligned, code fixed bin(35), (conversion, size) condition, err entry options(variable) variable, get_arg entry (fixed bin, ptr, fixed bin(21), fixed bin(35), ptr) variable, (i, j, k) fixed bin, Npic pic "---------9"; dcl arg char(Larg) based(Parg), ret char(Lret) varying based(Pret); dcl (abs, addr, convert, divide, length, log10, ltrim, maxlength, mod, substr) builtin; dcl (active_fnc_err_, com_err_) entry options(variable), (cu_$af_arg_ptr_rel, cu_$arg_ptr_rel) entry (fixed bin, ptr, fixed bin(21), fixed bin(35), ptr), cu_$af_return_arg entry (fixed bin, ptr, fixed bin(21), fixed bin(35)), cu_$arg_list_ptr entry returns(ptr), iox_$put_chars entry (ptr, ptr, fixed bin(21), fixed bin(35)); dcl (FALSE init("0"b), TRUE init("1"b)) bit(1) aligned int static options(constant), NL char(1) aligned int static options(constant) init(" "), (error_table_$bad_conversion, error_table_$not_act_fnc, error_table_$out_of_bounds, error_table_$wrong_no_of_args) fixed bin(35) ext static, iox_$user_output ptr ext static; call cu_$af_return_arg (Nargs, Pret, Lret, code); /* See if invoked as command of af. Get af ret. */ if code = error_table_$not_act_fnc then do; /* Invoked as a command. */ err = com_err_; get_arg = cu_$arg_ptr_rel; /* Report errors/get args accordingly. */ Scommand = TRUE; Lret = 100000; /* Limit printed output to 100000 chars. */ end; /* per invocation of the command. */ else if code = 0 then do; /* Invoked as an active function. */ err = active_fnc_err_; get_arg = cu_$af_arg_ptr_rel; Scommand = FALSE; end; else go to BAD_INVOKE; /* Invoked without argument descriptors. */ if Nargs = 0 then go to WNOA; /* Must be called with 1, 2, or 3 args, or */ else if Nargs < 3 then; /* with a multiple of three args. */ else if mod(Nargs,3) ^= 0 then go to WNOA; if Nargs < 3 then /* When called with 3 or less args, output only */ Ngroups = 1; /* one set of numbers. */ else Ngroups = divide(Nargs,3,17,0); /* Otherwise output one set or group per triplet */ Parg_list = cu_$arg_list_ptr(); /* of input args. Remember args before entering */ /* begin block to get space for set boundaries. */ begin; /* Start of BEGIN BLOCK for group boundary store */ dcl 1 group (Ngroups), /* space for set boundaries. */ 2 (lb, ub, incr) fixed bin(34), /* lower bound, upper bound, increment. */ vector (3 * Ngroups) fixed bin(34) based(addr(group)); on conversion, size go to BAD_BOUND; if Nargs = 1 then do; /* If only 1 arg, fake a lower bound of 1. */ group(1).lb = 1; group(1).incr = 1; i = 2; /* 1st arg is the upper bound. */ call get_arg (1, Parg, Larg, 0, Parg_list); /* get 1st arg and store it. */ group(1).ub = convert(group(1).ub, arg); if abs(group(1).ub) > 1000000000 then /* All lower/upper bounds <= one billion. */ go to BAD_BOUND; end; else do; /* More than 1 arg. Process in triplets. */ if Nargs = 2 then /* If only 2 args, fake third arg of 1 for incr. */ group(1).incr = 1; j = 0; /* Initialize triplet counter. */ do i = 1 to Nargs; /* 1st args of triplet is L; 2nd is U; 3rd is I. */ call get_arg (i, Parg, Larg, 0, Parg_list); vector(i) = convert(vector(i), arg); if abs(vector(i)) > 1000000000 then /* All lower/upper bounds <= one billion. */ go to BAD_BOUND; j = j + 1; if j = 3 then do; /* Triplet complete? */ if vector (i) = 0 then do; /* increment value cannot be zero. */ call err (error_table_$bad_conversion, "index_set", "Increment cannot be zero (Argument ^d)", i); return; end; else if vector(i) > 1000000 then /* Increments <= one million. */ go to BAD_BOUND; else; /* otherwise, either negative or position increment value is ok */ j = 0; /* reset triplet counter; prepare for next triple.*/ end; end; end; revert conversion; Ls = 0; /* Compute length of string needed to return all */ do i = 1 to Ngroups; /* sets of numbers. */ Ls = Ls + s_length(group(i)); end; if Ls > Lret then do; /* Complain if return string is too long. */ call err (error_table_$out_of_bounds, "index_set", "Return string of ^d chars is longer than ^d.", Ls, Lret); go to RETURN; end; if ^Scommand then Ls = 0; /* If invoked as active function, use af return */ /* arg to hold string; as command, allocate */ /* storage via begin block (below) to hold string.*/ begin; /* Start of BEGIN BLOCK for result string storage.*/ dcl s char (Ls) varying; /* the returned integers are hold in an automatic character string */ if Scommand then do; Pret = addr (s); Lret = maxlength (s); end; ret = ""; do i = 1 to Ngroups; /* For each set (group) of numbers to be returned,*/ if group(i).lb <= group(i).ub then do; /* if L < = U and I is negative, then I is assumed to be positive */ if group (i).incr < 0 then group (i).incr = abs (group (i).incr); end; else do; /* if L > U and I is positive, then I is assumed to be negative */ if group (i).incr > 0 then group (i).incr = - (group (i).incr); end; do j = group(i).lb to group(i).ub by group(i).incr; Npic = j; /* compute group elements; store in result str. */ if (i = 1) & (j = group (i).lb) then /* if this is the first time in both loops */ ret = ltrim (Npic); /* then get the returned integer */ else ret = ret || ltrim(Npic); /* append the returned integer to the already string of returned integers */ ret = ret || " "; /* each returned integer is separated by a white space */ end; end; if Scommand then do; /* Print result string when invoked as a command */ substr(ret, length (ret), 1) = NL; /* add the Newline character in place of a white space at the end */ call iox_$put_chars (iox_$user_output, addr (substr (ret, 1)), length (ret), code); end; else ret = substr (ret, 1, length (ret) - 1); /* Return af result (except for extra space */ /* at end of string). */ end; /* End of BEGIN BLOCK for result string storage. */ s_length: procedure (g) returns (fixed bin(21)); /* This internal proc computes APPROXIMATE length */ /* of result string needed for 1 group (set) of */ /* numbers. The guess is always guaranteed to be */ /* >= the storage actually required. */ dcl 1 g, 2 (l, u, i) fixed bin(34), (lb, ub) fixed bin(34), (i, j) fixed bin, len fixed bin(71); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* A set of numbers is defined by a triplet (L U I) where L is lower bound, U is upper */ /* bound, I is increment between numbers. */ /* */ /* s_length(L U I) can be found by the following procedure: */ /* 1) Start out by assuming an increment of 1 (L U 1). */ /* 2) Break apart (L U 1) into one or more intervals, each of whose L is 1, -1, or 0. */ /* For example, */ /* (1 10 1) ==> stays unbroken */ /* (5 10 1) ==> (1 10 1) - (1 4 1) (ie, {1 2 3 4 5 6 7 8 9 10} - {1 2 3 4} */ /* (-7 -1 1)==> (-1 -7 1) */ /* (-4 5 1) ==> (-1 -4 1) + (0 0 1) + (1 5 1) */ /* 3) s_length(0 0 1) is 2. */ /* 4) s_length(-|L| -|U| 1) = s_length(|L| |U| 1) + n_elements(|L| |U| 1) */ /* For example, s_length(-1 -7 1) = s_length(1 7 1) + 7, because a - sign precedes */ /* each element of (-1 -7 1). */ /* 5) At this point, any s_length(L U 1) can be computed as sum or difference of some */ /* s_length(1 Ui 1). */ /* */ /* To compute s_length(1 U 1), do the following. */ /* 6) Determine how many chars required to output U followed by a space. */ /* n_chars(U) = log10(U)+2 */ /* In all uses of log10(U) in this algorithm, we are interested only in the integer */ /* part of the value. For example, log10(250) = 2 and 4 chars are req'd to output 250.*/ /* These are the longest numbers of the set. */ /* 7) Determine how many of these longest numbers there are. */ /* n_longest(U) = U - (10**log10(U) - 1) */ /* For example, n_longest(110) = 110 - (10**log10(110) - 1) */ /* = 110 - (10**2 - 1) = 110 - 99 = 11 */ /* The table subtrahend(0:8) contains the values of (10**log10(U) - 1) for values of */ /* log10(U) from 0 to 8. */ /* 8) From (6) and (7) we have: */ /* s_length( 10**log10(U) U 1) = n_chars(U) * n_longest(U) */ /* For example, s_length(100 110 1) = n_chars(110) * n_longest(110) */ /* = (log10(110)+2) * (110 - 99) */ /* = 4 * 11 = 44 */ /* 9) Since s_length(1 U 1) = s_length(1 10**log10(U)-1 1) + */ /* s_length(10**log10(U) U 1) */ /* we can compute s_length(1 U 1) from (8) above and s_length(1 10**log10(U)-1 1). */ /* s_length(1 10**log10(U)-1 1) is stored in the addend(0:8) table below for */ /* values of log10(U) from 0 to 8. Values of s_length(-1 -(10**log10(U)-1) 1) are */ /* stored in neg_addend(0:8) below. */ /* Thus, we have from the above: */ /* s_length(1 U 1) = s_length(10**log10(U) U 1) + s_length(1 10**log10(U)-1 1) */ /* = n_chars(U) * n_longest(U) + addend(log10(U)) */ /* = log10(U)+2 * (U - subtrahend(log10(U))) + addend(log10(U)) */ /* and s_length(-1 -|U| 1) = */ /* = log10(|U|)+3 * (|U| - subtrahend(log10(|U|))) + */ /* neg_addend(log10(|U|)) */ /* */ /* At this point, we can compute s_length(L U 1) for any integer L and U. */ /* The value computed by the above formula is exact! We provide the following */ /* approximation for handling integer increments > 1. */ /* s_length(1 U I) = */ /* log10(U) */ /* ________ */ /* \ */ /* \ */ /* s_length(1 U 1) \ */ /* --------------- + > (k+2) */ /* I / */ /* / */ /* /________ */ /* k = 0 */ /* The rational is that only every Ith number of the set will be output, so the */ /* result string need be only 1/I as long, approximately. The approximation comes from */ /* the fact that I probably does not evenly divide the number of elements of any given */ /* length in the set of numbers. To compensate, we add room for one number of each length*/ /* to the result string (the summation does this). If for shorthand we write the */ /* summation above as sum(k+2, k=0 to log10(U)), then we have */ /* s_length(-1 -|U| |I|) = s_length(-1 -|U| 1) / I + sum(k+3, k = 0 to log10(|U|)) */ /* */ /* By the rules of algebra, we have */ /* sum(k+2, k = 0 to log10(U)) = sum(k, k = 0 to log10(U)) + 2*(log10(U)+1) */ /* = (log10(U)*(log10(U)+1)) / 2 + 2*(log10(U)+1) */ /* This result is used in the equations below. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl addend (0:8) fixed bin(71) int static options(constant) init( 0, 18, 288, 3888, 48888, 588888, 6888888, 78888888, 888888888), neg_addend (0:8) fixed bin(71) int static options(constant) init( 0, 27, 387, 4887, 58887, 688887, 7888887, 88888887, 988888887), subtrahend (0:8) fixed bin(71) int static options(constant) init( 0, 9, 99, 999, 9999, 99999, 999999, 9999999, 99999999); if g.l > g.u then do; /* Treat (12 5 1) as (5 12 1), etc. */ lb = g.u; /* Swap upper and lower bounds. */ ub = g.l; end; else do; /* Copy upper and lower bounds without swap. */ lb = g.l; ub = g.u; end; if (lb>=0) & (ub>=0) then do; /* All numbers in set are nonnegative. */ if ub = 0 then i = 0; else i = log10(ub); /* This number is used everywhere. */ len = addend(i) + (i+2)*(ub-subtrahend(i)); /* compute s_length(1 U 1). */ if lb = 1 then; else if lb = 0 then /* add 2 to handle "0 " if present. */ len = len + 2; else do; /* s_length(L U 1) = s_length(1 U 1) - */ lb = lb - 1; /* s_length(1 L-1 1) */ if lb = 0 then j = 0; else j = log10(lb); len = len - (addend(j) + (j+2)*(lb-subtrahend(j))); end; if g.i ^= 1 then /* s_length(L U I) = s_length(L U 1)/I + */ /* sum(k+2, k = 0 to i) */ len = divide (len, abs (g.i), 35, 0) + divide (i * (i + 1), 2, 35, 0) + 2 * (i + 1); end; else if (lb<=0) & (ub<=0) then do; /* All numbers of set are nonpositive. */ k = lb; /* Treat (-5 -2 1) as (2 5 1) from counting */ lb = -ub; /* standpoint. */ ub = -k; if ub = 0 then i = 0; else i = log10(ub); /* Compute s_length(1 |U| 1) */ len = neg_addend(i) + (i+3)*(ub-subtrahend(i)); if lb = 1 then; else if lb = 0 then /* add 2 to handle "0 " if present. */ len = len + 2; else do; /* s_length(|L| |U| 1) = s_length(1 |U| 1) - */ lb = lb - 1; /* s_length(1 |L|-1 1) */ if lb = 0 then j = 0; else j = log10(lb); len = len - (neg_addend(j) + (j+3)*(lb-subtrahend(j))); end; if g.i ^= 1 then /* s_length(L U I) = s_length(L U 1)/I + */ /* sum(k+3, k = 0 to i) */ len = divide (len, abs (g.i), 35, 0) + divide (i * (i + 1), 2, 35, 0) + 3 * (i + 1); end; else do; /* Sets contains both positive and negative numbers*/ /* so use a combination of 2 cases above. */ lb = -lb; /* lb < 0; invert its sign. */ if lb = 0 then i = 0; else i = log10(lb); len = neg_addend(i) + (i+3)*(lb-subtrahend(i)); len = len + 2; /* Account for the 0 between neg. lower bound */ /* and pos. upper bound. */ if ub = 0 then j = 0; else j = log10(ub); len = len + (addend(j) + (j+2)*(ub-subtrahend(j))); if g.i ^= 1 then len = divide (len, abs (g.i), 35, 0) + divide ((i + j) * (i + j + 1), 2, 35, 0) + 3 * (i + 1) + 2 * (j + 1); end; if len > Lret then do; /* If return string too long, report it now when */ call err (error_table_$out_of_bounds, "index_set", " String needed to return numbers from ^d to ^d is too long.", g.l, g.u); go to RETURN; /* we know which set is too big. */ end; /* Check for sum of all sets is done by caller. */ return (len); end s_length; end; /* End of BEGIN BLOCK for group boundary store. */ RETURN: return; WNOA: call err (error_table_$wrong_no_of_args, "index_set", "^/Usage: ^[^;[^]index_set first1 bound1 increment1 ... firstN boundN incrementN^[^;]^] or: ^[^;[^]index_set first bound^[^;]^] or: ^[^;[^]index_set bound^[^;]^]", Scommand, Scommand, Scommand, Scommand, Scommand, Scommand); return; BAD_BOUND: call err (error_table_$bad_conversion, "index_set", " ^a is an invalid ^[increment^;first number^;bound^]. Argument must satisfy the condition: ^[-1000000^;-1000000000^;-1000000000^] <= ^[increment^;first number^;bound^] <= ^[1000000^;1000000000^;1000000000^]", arg, mod(i,3)+1, mod(i,3)+1, mod(i,3)+1, mod(i,3)+1); return; BAD_INVOKE: call active_fnc_err_ (code, "index_set"); return; end index_set;  login_args.pl1 11/04/82 2003.4rew 11/04/82 1610.0 73404 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ /* Written 81-12-03 E. N. Kittlitz. */ /* Modified 82-06-04 E. N. Kittlitz. make [login_args -ct] return "0", not "". */ login_arg: login_args: proc; /* command/active-function to return login arguments, specified either to enter_abs_request (absentee processes) or to the login request (daemon or interactive processes) using the -arguments control argument. Syntax: login_arg {argument_number} {-control_args} where: argument_number may be a postive non-zero decimal number, the number of the argument whose value is required. CONTROL ARGUMENTS: -count, -ct count of login arguments supplied to login request or enter_abs_request. -from argument_number, -fm argument_number number of first argument to return. All succeeding defined arguments are also returned. (one per line if this is a command invocation, or separated by a space for active function use.) -no_requote prevents the requoting of each argument. -quote causes each quote in the argument to be doubled. The same as -requote except that the string is not enclosed in quotation marks. -requote causes each argument to be requoted. This is the default. */ dcl ME char (10) init ("login_args") static options (constant); dcl NO_REQUOTE fixed bin init (0) static options (constant); dcl FORMAT char (14) int static options (constant) init ("^[^d) ^;^s^]^a"); dcl QUOTE fixed bin init (1) static options (constant); dcl REQUOTE fixed bin init (2) static options (constant); dcl argn fixed bin; /* current command argument number */ dcl argp ptr; /* ptr to command argument */ dcl argument_number fixed bin (35); /* which argument the user wants */ dcl count_sw bit (1) aligned; /* true if -count specified */ dcl from_sw bit (1) aligned; /* true if -from specified */ dcl i fixed bin; dcl quote_option fixed bin; dcl (null, substr, ltrim, char) builtin; dcl error_proc entry options (variable) variable; /* procedure called to indicate an error */ dcl arg_proc entry (fixed bin, ptr, fixed bin (21), fixed bin (35)) variable; /* procedure called to obtain a command argument */ dcl argc fixed bin; /* number of command arguments */ dcl arg char (argl) based (argp); /* command argument */ dcl argl fixed bin (21); /* length of command argument */ dcl lg_argp ptr; /* ptr to login argument */ dcl lg_argc fixed bin; /* number of login arguments */ dcl lg_arg char (lg_argl) based (lg_argp); /* login argument */ dcl lg_argl fixed bin (21); /* length of login argument */ dcl af_sw bit (1) aligned; /* "1"b if invoked as active function */ dcl af_argp ptr; /* pointer to af return argument */ dcl af_argl fixed bin (21); /* max length of af return argument */ dcl af_arg char (af_argl) based (af_argp) varying; /* af return argument */ dcl code fixed bin (35); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl active_fnc_err_ entry options (variable); dcl com_err_ entry options (variable); dcl ioa_ entry options (variable); dcl requote_string_ entry (char (*)) returns (char (*)); dcl requote_string_$quote_string entry (char (*)) returns (char (*)); dcl user_info_$login_arg_count entry (fixed bin, fixed bin (21), fixed bin (21)); dcl user_info_$login_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 error_table_$not_act_fnc fixed bin (35) ext static; dcl error_table_$badopt fixed bin (35) ext static; dcl error_table_$inconsistent fixed bin (35) ext static; %page; call cu_$af_return_arg (argc, af_argp, af_argl, code); if code = 0 then do; arg_proc = cu_$af_arg_ptr; error_proc = active_fnc_err_; af_sw = "1"b; af_arg = ""; /* initialize output string */ end; else do; error_proc = com_err_; arg_proc = cu_$arg_ptr; af_sw = "0"b; af_argp = null; af_argl = 0; if code ^= error_table_$not_act_fnc then go to no_info_error; end; argument_number = -1; /* defaults for any case */ from_sw = "0"b; /* not explicit or implicit -from */ quote_option = REQUOTE; /* default quoting */ count_sw = "0"b; /* -count not specified */ process_arguments: do argn = 1 to argc; /* one by one */ call arg_proc (argn, argp, argl, code); if code ^= 0 then go to no_info_error; /* couldn't get that argument */ if arg = "-count" | arg = "-ct" then do; if argc ^= 1 then do; call error_proc (error_table_$inconsistent, ME, "-count may not be specified with any other control argument."); return; end; count_sw = "1"b; end; else if arg = "-from" | arg = "-fm" then do; from_sw = "1"b; argn = argn + 1; call arg_proc (argn, argp, argl, code); if code ^= 0 then do; call error_proc (code, ME, "argument_number expected following -from."); return; end; try_for_argument_number: if argument_number > 0 then do; call error_proc (0, ME, "argument_number specified more than once."); return; end; argument_number = cv_dec_check_ (arg, code); if code ^= 0 | argument_number < 1 then do; call error_proc (0, ME, "^a must be an integer number greater than zero.", arg); return; end; end; else if arg = "-no_requote" then quote_option = NO_REQUOTE; else if arg = "-quote" then quote_option = QUOTE; else if arg = "-requote" then quote_option = REQUOTE; else if substr (arg, 1, 1) = "-" then do; call error_proc (error_table_$badopt, ME, "^a", arg); return; end; else go to try_for_argument_number; end process_arguments; call user_info_$login_arg_count (lg_argc, (0), (0)); /* first, get number of login arguments */ if lg_argc = 0 then do; if ^af_sw then call error_proc (0, ME, "There are no login arguments."); else if count_sw then af_arg = "0"; /* -count: return a number */ return; end; if count_sw then do; /* only want the count? */ if af_sw then af_arg = ltrim (char (lg_argc)); else call ioa_ (ltrim (char (lg_argc))); return; end; if argument_number < 0 then do; argument_number = 1; /* use default if we must */ from_sw = "1"b; end; if argument_number > lg_argc then do; /* we don't go as high as user asked */ if ^af_sw then call error_proc (0, ME, "argument_number ^d exceeds the number of login arguments (^d).", argument_number, lg_argc); return; end; make_result: do i = argument_number to lg_argc while (from_sw | i = argument_number); call user_info_$login_arg_ptr (i, lg_argp, lg_argl, code); if code ^= 0 then do; call error_proc (code, ME, "While obtaining login argument ^d.", i); return; end; if af_sw then if i > argument_number then af_arg = af_arg || " "; if quote_option = REQUOTE then if af_sw then af_arg = af_arg || requote_string_ (lg_arg); else call ioa_ (FORMAT, from_sw, i, requote_string_ (lg_arg)); else if quote_option = QUOTE then if af_sw then af_arg = af_arg || requote_string_$quote_string (lg_arg); else call ioa_ (FORMAT, from_sw, i, requote_string_$quote_string (lg_arg)); else if af_sw then af_arg = af_arg || lg_arg; else call ioa_ (FORMAT, from_sw, i, lg_arg); end make_result; return; no_info_error: call error_proc (code, ME); return; end login_args;  picture.pl1 10/22/86 1528.3rew 10/22/86 1526.3 91386 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-10-20,TLNguyen), approve(86-10-20,MCR7560), audit(86-10-22,Gilcrease), install(86-10-22,MR12.0-1195): Correct an usage message. END HISTORY COMMENTS */ /**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16 */ /**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo */ /**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend */ /**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt */ /* Created: Mar 78 J Falksen */ /* Updated: Aug 78 J Falksen */ /* added conversion handler */ /* fixed error message */ /* added valid_pictured_data entry */ /* removed quotes from command output */ /* made command use NL separator when multiple output values */ /* Updated: Aug 80 J Falksen */ /* cleanup for installation and format_pl1 */ /* Updated: Oct. 86 Tai L. Nguyen */ /* corrected an usage message */ /* Syntax: pic pic_string values {-control_arg} */ /* */ /* Function: returns one or more values processed through a specified */ /* PL/I picture. */ /* */ /* Arguments: */ /* pic_string */ /* is a valid PL/I picture as defined in the PL/I Reference Manual and */ /* the PL/I Language Specification. */ /* values */ /* are strings having data appropriate for editing into the picture. */ /* Each value must be convertible to the type implied by the picture */ /* specified. If multiple values are presented, the results are */ /* separated by single spaces. Any resulting value that contains a */ /* space is quoted. */ /* */ /* Control argument: */ /* -strip */ /* removes leading spaces from edited picture values; removes trailing */ /* zeros following a decimal point; removes a decimal point if it would */ /* have been the last character of a returned value. */ /* */ /* */ /* Syntax as active function: [pic pic_string values {-control_arg}] */ /* Syntax: [vpd pic_string values] */ /* */ /* Function: Returns "true" if all values can be formatted via pic_string. */ /* Otherwise returns "false". */ /* */ /* */ /* Arguments: */ /* pic_string */ /* is a valid PL/I picture. */ /* value */ /* is a string to be edited into the picture. */ /* */ /* */ /* Notes: For more information on PL/I picture and picture strings, see */ /* the PL/I Reference Manual, Order No. AM83 or the PL/I Language */ /* Specification, Order No. AG94. */ pic: picture: proc; /* edit a value into a picture */ testing = "0"b; me = "picture"; goto start; valid_pictured_data: vpd: entry; /* see if value will edit into pic */ testing = "1"b; me = "valid_pictured_data"; goto start; start: strip_sw = "0"b; /* dont strip leading/trailing */ call cu_$af_arg_count (argct, code); if (code ^= 0) /* called as command? */ then do; /* ...YES */ retval_p = null (); /* no return string */ error = com_err_; /* set error message routine */ arg_ptr = cu_$arg_ptr; end; else do; /* ...NO */ call cu_$af_return_arg (argct, retval_p, retval_l, code); /* get return string */ retval = ""; error = active_fnc_err_; /* set error message routine */ arg_ptr = cu_$af_arg_ptr; end; if (argct < 2) then do; /* tsk, tsk */ if (me = "picture") then call error (error_table_$noarg, me, "Usage:^-pic pic_str {-strip} value ..."); else call error (error_table_$noarg, me, "Usage:^-vpd pic_str value ..."); return; end; call arg_ptr (1, argp, argl, code); /* get the picture string */ if (argl = 0) /* he wants the default */ then do; the_picture = default; picp = addr (default); picl = length (default); /* which include NO extraneous */ strip_sw = "1"b; /* spaces or blanks */ dcl default char (13) int static options (constant) init ("(15)-9v.(15)9"); end; else do; /* use his picture (SMILE!) */ the_picture = arg; picp = argp; picl = argl; end; call picture_info_ ((picv), addr (buff), code); /* let PL/I routine process it */ if (code ^= 0) /* Oh, */ then do; /* ...you didnt like that one! */ call error (0, me, "^[Normalized picture > 64 char" || "^;Scale factor not in range -128:+127" || "^;Syntax error^]. ^a", sign (code - 434) + 2, /* That's right, they return a FUNNY */ the_picture); /* code! */ return; end; do argno = 2 to argct while (^strip_sw); call arg_ptr (argno, argp, argl, code); if (arg = "-strip") then strip_sw = "1"b; end; on condition (conversion) /* just in case he blows it */ begin; Cond = "Conversion"; goto err_exit; end; on condition (size) /* just in case he blows it */ begin; Cond = "Size"; goto err_exit; end; do argno = 2 to argct; call arg_ptr (argno, argp, argl, code); if (arg ^= "-strip") then do; /* let somebody do it who UNDERSTANDS all these things */ temp_length = addr (buff) -> picture_image.prec + 262144 * (addr (buff) -> picture_image.scale - addr (buff) -> picture_image.scalefactor); call assign_ (addr (temp), map_type (addr (buff) -> picture_image.type), temp_length, argp, 42, (argl)); call pack_picture_ (addr (target) -> bit1, buff, temp); if ^testing /* not valid_pictured_data */ then do; pictured = substr (target, 1, addr (buff) -> picture_image.varlength); if strip_sw /* should we dump the extras? */ then do; pictured = ltrim (pictured); if (index (pictured, ".") ^= 0) then do; pictured = rtrim (pictured, "0"); if (substr (pictured, length (pictured), 1) = ".") then pictured = substr (pictured, 1, length (pictured) - 1); end; end; if (retval_p = null ()) then call ioa_ ("^a", pictured); else do; j = index (pictured, " "); if (length (retval) > 0) then retval = retval || " "; if (j > 0) then retval = retval || """"; retval = retval || pictured; if (j > 0) then retval = retval || """"; end; end; end; end; if testing then do; if (retval_p = null ()) /* command? */ then call ioa_ ("true"); /* yes. print it */ else retval = "true"; /* no. return it */ end; return; err_exit: if testing then do; if (retval_p = null ()) /* command? */ then call ioa_ ("false"); /* yes. print it */ else retval = "false"; /* no. return it */ end; else call error (0, me, "^a condition occurred while editing ""^a"" thru ""^a""", Cond, arg, the_picture); return; dcl active_fnc_err_ entry options (variable); dcl arg char (argl) based (argp); dcl argct fixed bin; dcl argl fixed bin (21); dcl argno fixed bin; dcl argp ptr; dcl assign_ entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35)); dcl bit1 bit (1) unaligned based; dcl buff (20) fixed binary; dcl code fixed bin (35); dcl Cond char (12); dcl com_err_ entry options (variable); dcl conversion condition; dcl cu_$af_arg_count entry (fixed bin, fixed bin (35)); dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)) automatic; dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl error entry options (variable) automatic; dcl error_table_$noarg fixed bin (35) ext static; dcl ioa_ entry options (variable); dcl j fixed bin; dcl me char (32); dcl pack_picture_ options (variable); dcl picl fixed bin; dcl picp ptr; dcl picture_info_ entry (char (*) aligned, ptr, fixed bin (35)); dcl pictured char (256) var; dcl picv char (picl) based (picp); dcl retval char (retval_l) var based (retval_p); dcl retval_l fixed bin (21); dcl retval_p ptr; dcl size condition; dcl strip_sw bit (1); dcl target char (128); dcl temp (128) char (1) unaligned; dcl temp_length fixed bin (35); dcl testing bit (1); dcl the_picture char (100) var; dcl (addr, index, length, ltrim, null, rtrim, sign, substr) builtin; %include picture_image; dcl map_type (24:28) fixed bin int static init ( 42, /* character */ 18, /* real fixed dec */ 22, /* cplx fixed dec */ 20, /* real float dec */ 24); /* cplx float dec */ end picture;  query.pl1 01/12/88 1314.5rew 01/12/88 1245.0 122742 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ query: procedure options (variable); /* Record of Change: Created by Gary C. Dixon on November 23, 1972 Control arguments -non_null and -accept added by Txom McGary April 1977. Modified 6/81 by M.R. Jordan to add control arguments. Modified 9/81 by M.R. Jordan to get the defaults for question and answer IOCB pointers right. Modified 06/14/84 by S. Herbst to always write on specified IOCB, never on error_output. Name: query An active function which asks the user a yes-or-no question. If the user answers "yes", then query returns "true". If the user answers "no", query returns "false". Usage [query question-text {-control_args}] 1) question-text (Input) is a character string which forms the text of the question which the user is asked. 2) control_arg (Input) is one of the following: -brief, -bf supresses the newline before and spaces after the question. -disable_cp_escape, -dcpe disables the command processor escape sequence .. as a response. -enable_cp_escape, -ecpe enables the command processor escape sequence .. as a response. -input_switch STR, -isw STR specifies the I/O switch over which input is to be requested. -long, -lg adds leading newline and 3 spaces to question to be asked. -output_switch STR, -osw STR specifies the I/O switch over which the question is to be output. -repeat DT, -rp DT repeats teh question every DT is the user does not answer. Name: response An active function which asks any question of the user, and returns the user's response as the value of the active function. Usage [response question-text {-control_args}] 1) question-text (Input) is as above. 2) control_arg may be one of the control arguments listed above for query or one of the following: -non_null specifies that a null response is not allowed. -accept STR1 ... STRn specifies allowable responses. Example Assume that the user's start_up.ec contained the following lines: &command_line off &print Beginning start_up. abbrev &if [query "start_up: Do you wish to continue?"] &then &else &quit mail check_info_segs . . Then the following dialogue would cause the start_up.ec to terminate execution after the query: Beginning start_up. start_up.ec: Do you wish to continue? !no r 1722 25.797 402+625 */ /****^ HISTORY COMMENTS: 1) change(87-12-17,Gilcrease), approve(88-01-06,MCR7827), audit(88-01-08,Parisek), install(88-01-12,MR12.2-1012): Add the -trim, -no_trim control arguments. END HISTORY COMMENTS */ /* CONSTANTS */ dcl NAME (2) char (8) static options (constant) init ("query", "response"); dcl QUERY fixed bin static options (constant) init (1); dcl RESPONSE fixed bin static options (constant) init (2); /* AUTOMATIC */ dcl accept_null bit (1); dcl arg_len fixed bin; dcl arg_list_ptr ptr; dcl arg_ptr ptr; dcl argn fixed bin; dcl called_as_active_function bit (1); dcl code fixed bin (35); dcl entry_point fixed bin; dcl error entry options (variable) variable; dcl error_has_occured bit (1); dcl first_acceptable_arg fixed bin; dcl get_arg entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr) variable; dcl max_length fixed bin; dcl nargs fixed bin; dcl no_trim bit (1); dcl print_iocbp ptr; dcl question_len fixed bin; dcl question_ptr ptr; dcl rtn_string_ptr ptr; dcl temp_string char (512) varying; dcl 1 my_query_info like query_info; /* BASED */ dcl answer char (max_length) varying based (rtn_string_ptr); dcl arg char (arg_len) based (arg_ptr); dcl question char (question_len) based (question_ptr); dcl 1 open_descrip aligned based, 2 length fixed bin (17), 2 string char (0 refer (open_descrip.length)); /* ERROR CODES */ dcl error_table_$bad_arg fixed bin (35) static ext; dcl error_table_$badopt fixed bin (35) static ext; dcl error_table_$noarg fixed bin (35) static ext; dcl error_table_$not_act_fnc fixed bin (35) static ext; dcl error_table_$not_open fixed bin (35) static ext; /* EXTERNAL ENTRIES */ dcl active_fnc_err_ entry options (variable); dcl com_err_ entry options (variable); dcl command_query_ entry options (variable); dcl convert_date_to_binary_$relative entry (char (*), fixed bin (71), fixed bin (71), fixed bin (35)); dcl cu_$af_arg_count entry (fixed bin, fixed bin (35)); dcl cu_$af_arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr); dcl cu_$af_return_arg ext entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr); dcl ioa_ entry options (variable); dcl ioa_$ioa_switch ext entry options (variable); dcl iox_$look_iocb entry (char (*), ptr, fixed bin (35)); dcl iox_$user_io ptr ext; /* BUILTIN FUNCTIONS */ dcl addr builtin; dcl clock builtin; dcl divide builtin; dcl maxlength builtin; dcl null builtin; dcl substr builtin; %include iocb; %include query_info; entry_point = QUERY; go to COMMON; response: entry options (variable); entry_point = RESPONSE; COMMON: call cu_$af_arg_count (nargs, code); if code = error_table_$not_act_fnc then do; called_as_active_function = "0"b; rtn_string_ptr = addr (temp_string); max_length = maxlength (temp_string); get_arg = cu_$arg_ptr_rel; error = com_err_; end; else if code = 0 then do; called_as_active_function = "1"b; call cu_$af_return_arg (nargs, rtn_string_ptr, max_length, code); if code ^= 0 then do; call active_fnc_err_ (code, (NAME (entry_point))); return; end; get_arg = cu_$af_arg_ptr_rel; error = active_fnc_err_; end; else do; error = active_fnc_err_; USAGE: call error (code, (NAME (entry_point)), "^/Usage: ^[[^]^a question {-control_args}^[]^]", called_as_active_function, (NAME (entry_point)), called_as_active_function); return; end; if nargs < 1 then do; code = error_table_$noarg; goto USAGE; end; call cu_$arg_list_ptr (arg_list_ptr); call get_arg (1, question_ptr, question_len, code, arg_list_ptr); if code ^= 0 then do; call error (code, (NAME (entry_point)), "Referencing first argument."); return; end; accept_null = "1"b; answer = ""; error_has_occured = "0"b; first_acceptable_arg = 0; no_trim = "0"b; my_query_info.version = query_info_version_5; my_query_info.switches.yes_or_no_sw = (entry_point = QUERY); my_query_info.switches.suppress_name_sw = "1"b; my_query_info.switches.cp_escape_control = "00"b; my_query_info.switches.suppress_spacing = "0"b; my_query_info.switches.padding = ""b; my_query_info.status_code = 0; my_query_info.query_code = 0; my_query_info.question_iocbp = null (); my_query_info.answer_iocbp = null (); my_query_info.repeat_time = 0; my_query_info.explanation_ptr = null (); my_query_info.explanation_len = 0; call Process_Control_Args (2); if error_has_occured then return; print_iocbp = my_query_info.question_iocbp; if print_iocbp = null then print_iocbp = iox_$user_io; ASK: if no_trim then call command_query_ (addr (my_query_info), answer, (NAME (entry_point)), "^va", question_len, question); else call command_query_ (addr (my_query_info), answer, (NAME (entry_point)), "^a", question); goto PROCESS (entry_point); PROCESS (1): /* QUERY */ if answer = "yes" then answer = "true"; else answer = "false"; EXIT: if ^called_as_active_function then call ioa_ ("^a", answer); return; PROCESS (2): /* RESPONSE */ if ^accept_null & answer = "" then do; call ioa_$ioa_switch (print_iocbp, "^a: Null response not allowed, please retype.", (NAME (entry_point))); goto ASK; end; if first_acceptable_arg = 0 then goto EXIT; do argn = first_acceptable_arg to nargs by 1; call Get_Arg (argn, ""); if answer = arg then goto EXIT; end; call ioa_$ioa_switch (print_iocbp, "^a: '^a' is not an acceptable answer.^/Acceptable answers are:", (NAME (entry_point)), answer); do argn = first_acceptable_arg to nargs; call Get_Arg (argn, ""); call ioa_$ioa_switch (print_iocbp, "^-'^a'", arg); end; goto ASK; Process_Control_Args: procedure (first_argn); dcl first_argn fixed bin; dcl argn fixed bin; do argn = first_argn repeat argn+1 while (argn <= nargs); call Get_Arg (argn, ""); if arg = "-accept" & entry_point = RESPONSE then do; first_acceptable_arg = argn+1; if first_acceptable_arg > nargs then do; call error (error_table_$noarg, (NAME (entry_point)), "Missing argument(s) following -accept."); error_has_occured = "1"b; end; argn = nargs; end; else if arg = "-brief" | arg = "-bf" then my_query_info.switches.suppress_spacing = "1"b; else if arg = "-no_trim" then no_trim = "1"b; else if arg = "-trim" then no_trim = "0"b; else if arg = "-disable_cp_escape" | arg = "-dcpe" then my_query_info.switches.cp_escape_control = "10"b; else if arg = "-enable_cp_escape" | arg = "-ecpe" then my_query_info.switches.cp_escape_control = "11"b; else if arg = "-input_switch" | arg = "-isw" then do; call Get_Arg (argn+1, "Missing I/O switch name following " || arg); if addr (arg) ^= null () then my_query_info.answer_iocbp = IOCBp (arg, "1"b); argn = argn+1; end; else if arg = "-long" | arg = "-lg" then my_query_info.switches.suppress_spacing = "0"b; else if arg = "-non_null" & entry_point = RESPONSE then accept_null = "0"b; else if arg = "-output_switch" | arg = "-osw" then do; call Get_Arg (argn+1, "Missing I/O switch name following " || arg); if addr (arg) ^= null () then my_query_info.question_iocbp = IOCBp (arg, "0"b); argn = argn+1; end; else if arg = "-repeat" | arg = "-rp" then do; call Get_Arg (argn+1, "Missing repeat interval following " || arg); if addr (arg) ^= null () then my_query_info.repeat_time = Date_Time (arg); argn = argn+1; end; else do; call error (error_table_$badopt, (NAME (entry_point)), "^a", arg); error_has_occured = "1"b; end; end; return; IOCBp: procedure (switch_name, input_flag) returns (ptr); dcl input_flag bit (1); dcl iocbp ptr; dcl switch_name char (*); call iox_$look_iocb (switch_name, iocbp, code); if code ^= 0 then do; call error (code, (NAME (entry_point)), "^a", switch_name); error_has_occured = "1"b; return (null ()); end; if iocbp -> iocb.open_descrip_ptr = null () then do; call error (error_table_$not_open, (NAME (entry_point)), "^a", switch_name); error_has_occured = "1"b; return (null ()); end; if substr (iocbp -> iocb.open_descrip_ptr -> open_descrip.string, 1, 19) = "stream_input_output" then return (iocbp); if substr (iocbp -> iocb.open_descrip_ptr -> open_descrip.string, 1, 12) = "stream_input" & input_flag then return (iocbp); if substr (iocbp -> iocb.open_descrip_ptr -> open_descrip.string, 1, 13) = "stream_output" & ^input_flag then return (iocbp); call error (0, (NAME (entry_point)), "I/O switch ^a not open for stream_^[input^;output^] or stream_input_output.", switch_name, input_flag); error_has_occured = "1"b; return (null ()); end IOCBp; Date_Time: procedure (date_time_string) returns (fixed bin (71)); dcl current_date_time fixed bin (71); dcl date_time fixed bin (71); dcl date_time_string char (*); current_date_time = clock (); call convert_date_to_binary_$relative (date_time_string, date_time, current_date_time, code); date_time = divide ((date_time-current_date_time), 1000000, 71, 0); if code ^= 0 then do; call error (code, (NAME (entry_point)), "Converting ""^a"" to binary date/time.", date_time_string); error_has_occured = "1"b; return (0); end; else if date_time < 30 /* 30 seconds */ then do; call error (error_table_$bad_arg, (NAME (entry_point)), "Specified date/time is not ^[far enough ^]in the future. ^a", (date_time > 0), date_time_string); error_has_occured = "1"b; return (0); end; return (date_time); end Date_Time; end Process_Control_Args; Get_Arg: procedure (argn, mess); dcl argn fixed bin; dcl mess char (*); call get_arg (argn, arg_ptr, arg_len, code, arg_list_ptr); if code = 0 then return; call error (code, (NAME (entry_point)), "^[Refencing argument ^d^s^;^s^a^].", (mess = ""), argn, mess); arg_ptr = null (); arg_len = 0; error_has_occured = "1"b; return; end Get_Arg; end query;  rank.pl1 02/07/84 1052.5r 02/07/84 1050.5 48780 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2 */ rank: procedure; /* ********************************************************************** * Active function/command to implement the PL/I builtin functions * * rank and byte. * * * * Written August 1981 by Warren Johnson. * * Modified as per MCR for installation, November 1981, Benson I. * * Margulies * * Modified to fix NNo and other problems, BIM, 10/82 * * Modified to fix "byte 32" and "byte 34" (i.e. to use requote_ * * before calling ioa_), June 1983, Chris Jones * * Modified to fix arg processing errors, 1 Nov 1983 C Spitzer * ********************************************************************** */ dcl active_fnc_err_ entry options (variable); dcl com_err_ entry options (variable); dcl cu_$af_return_arg entry (fixed, ptr, fixed (21), fixed (35)); dcl cu_$arg_ptr entry (fixed, ptr, fixed (21), fixed (35)); dcl cv_dec_check_ entry (char (*), fixed (35)) returns (fixed (35)); dcl cv_oct_check_ entry (char (*), fixed (35)) returns (fixed (35)); dcl ioa_ entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl requote_string_ entry (char (*)) returns (char (*)); dcl (rank, byte, rtrim, substr, length, before, index) builtin; dcl error_table_$badopt fixed (35) external; dcl error_table_$bigarg fixed (35) external; dcl error_table_$noarg fixed (35) external; dcl error_table_$not_act_fnc fixed (35) external; dcl error_table_$too_many_args fixed (35) external; dcl error_table_$smallarg fixed bin (35) ext static; dcl error_table_$bad_conversion fixed bin (35) ext static; dcl gripe entry variable options (variable); dcl (nargs, i) fixed; dcl (rsl, argl) fixed (21); dcl (rv, code) fixed (35); dcl (argp, rsp) ptr; dcl rs char (rsl) varying based (rsp); dcl arg char (argl) based (argp); dcl cname char (4); dcl have_main_arg bit (1) aligned; dcl main_arg char (32); dcl (command, octal_sw) bit (1); %page; cname = "rank"; go to JOIN; byte: entry; cname = "byte"; JOIN: octal_sw = "0"b; call cu_$af_return_arg (nargs, rsp, rsl, code); if code = error_table_$not_act_fnc then do; /* called as a command */ command = "1"b; gripe = com_err_; end; else if code = 0 then do; /* active function */ command = "0"b; gripe = active_fnc_err_; end; else do; call com_err_ (code, cname); return; end; if nargs = 0 then do; /* one input arg required, one optional */ USAGE: call gripe (error_table_$noarg, cname, "^/Usage is: ^[[^]^a ^[CHAR^;NO^] {-control_args}^[]^]", ^command, cname, cname = "rank", ^command); return; end; have_main_arg = "0"b; do i = 1 to nargs; call cu_$arg_ptr (i, argp, argl, (0)); if ^(length (arg) > 1 & char (arg, 1) = "-") then do; if have_main_arg then do; call com_err_ (error_table_$too_many_args, cname, "Only one character may be specified. ^a is the second.", arg); return; end; have_main_arg = "1"b; main_arg = arg; /* so, it can be truncated */ end; else if (arg = "-octal" | arg = "-oc") & cname = "rank" /* not on byte */ then octal_sw = "1"b; else if (arg = "-decimal" | arg = "-dec") & cname = "rank" then octal_sw = "0"b; /* allow defaulting */ else do; call gripe (error_table_$badopt, cname, arg); return; end; end; if ^have_main_arg then go to USAGE; if cname = "rank" /* RANK */ then do; if length (rtrim (main_arg)) > 1 then do; call gripe (error_table_$bigarg, cname, "Only one character may be given. ""^a"" is too long.", main_arg); return; end; rv = rank (char (main_arg, 1)); if octal_sw then if command then call ioa_ ("^o", rv); else call ioa_$rsnnl ("^o", rs, (rsl), rv); else if command then call ioa_ ("^d", rv); else call ioa_$rsnnl ("^d", rs, (rsl), rv); end; else do; /* BYTE */ if character (reverse (rtrim (main_arg)), 1) = "o" then rv = cv_oct_check_ (before (main_arg, "o"), code); else rv = cv_dec_check_ (main_arg, code); if code ^= 0 then do; call gripe (error_table_$bad_conversion, cname, "Invalid number: ^a.", main_arg); return; end; else if rv < 0 | rv > 511 then do; call gripe (0, cname, "Number out of range: ^a.", main_arg); return; end; else if command then call ioa_ ("^a", requote_string_ (byte (rv))); else rs = byte (rv); end; if ^command then rs = requote_string_ ((rs)); return; end rank;  run.pl1 11/04/82 2003.4rew 11/04/82 1630.2 72756 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ run: proc; /* This procedure is the run command. The syntax is: run {-control_structure} {main_program} {program_args} If no exec_com is specified and -no_exec_com is not specified, main_program.run.ec in the main program's directory is used. */ /* coded by Melanie Weaver August 1977 */ /* modified June 1979 by Melanie Weaver */ dcl (i, j, k, m, alng, nargs, nprogargs, ref_name_spec_count) fixed bin; dcl code fixed bin (35); dcl type fixed bin (2); dcl bit_cnt fixed bin (24); dcl me char (3) init ("run") static options (constant); dcl arg char (alng) based (aptr); dcl (main_dir, arg_ec_name) char (168); dcl ec_name char (168) var; dcl main_ename char (32); dcl (no_ec, have_main) bit (1) aligned; dcl (aptr, arglist_ptr, new_arglist_ptr, sys_areap) ptr; dcl (error_table_$noarg, error_table_$badopt) fixed bin (35) ext; dcl system_area area based (sys_areap); dcl 1 control_structure aligned like run_control_structure; dcl 1 char_desc aligned, 2 flag bit (1) unal init ("1"b), 2 type fixed bin (5) unal init (21), 2 packed bit (1) unal init ("1"b), 2 number_dims bit (4) unal init ("0"b), 2 size fixed bin (23) unal; dcl 1 old_arglist aligned based (arglist_ptr), 2 (arg_count, code) fixed bin (17) unal, 2 (desc_count, mbz) fixed (17) unal, 2 args (nargs) ptr, 2 descs (nargs) ptr; dcl 1 new_arglist aligned based (new_arglist_ptr), 2 (arg_count, code) fixed bin (17) unal, 2 (desc_count, mbz) fixed bin (17) unal, 2 args (nprogargs) ptr, 2 descs (nprogargs) ptr; dcl (addr, hbound, length, null, rtrim, substr, unspec) builtin; dcl main_entry entry variable; dcl cu_$arg_count entry () returns (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$arg_list_ptr entry () returns (ptr); dcl com_err_ entry options (variable); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl hcs_$make_entry entry (ptr, char (*), char (*), entry, fixed bin (35)); dcl cv_entry_ entry (char (*), ptr, fixed bin (35)) returns (entry); dcl run_ entry (entry, ptr, ptr, fixed bin (35)); dcl get_wdir_ entry () returns (char (168)); dcl get_system_free_area_ entry () returns (ptr); %include run_control_structure; unspec (control_structure) = "0"b; control_structure.version = run_control_structure_version_1; no_ec = "0"b; ref_name_spec_count = 0; nargs = cu_$arg_count (); do i = 1 to nargs; /* find all control args */ call cu_$arg_ptr (i, aptr, alng, code); if code ^= 0 then do; if code = error_table_$noarg then goto no_main; call com_err_ (code, me); return; end; if (arg = "-exec_com") | (arg = "-ec") then do; i = i + 1; control_structure.flags.ec = "1"b; no_ec = "0"b; call cu_$arg_ptr (i, aptr, alng, code); if code ^= 0 then do; call com_err_ (code, me, "exec_com name"); return; end; ec_name = arg; end; else if (arg = "-no_exec_com") | (arg = "-nec") then do; control_structure.flags.ec = "0"b; no_ec = "1"b; end; else if (arg = "-limit") | (arg = "-li") then do; i = i + 1; call cu_$arg_ptr (i, aptr, alng, code); if code ^= 0 then do; call com_err_ (code, me, "time limit"); return; end; control_structure.time_limit = cv_dec_check_ (arg, code); if code ^= 0 then do; call com_err_ (0, me, "Invalid time limit specification ^a.", arg); return; end; end; else if (arg = "-copy_reference_names") | (arg = "-crn") then do; control_structure.reference_name_switch = COPY_REFERENCE_NAMES; ref_name_spec_count = ref_name_spec_count + 1; end; else if (arg = "-old_reference_names") | (arg = "-orn") then do; control_structure.reference_name_switch = OLD_REFERENCE_NAMES; ref_name_spec_count = ref_name_spec_count + 1; end; else if (arg = "-new_reference_names") | (arg = "-nrn") then do; control_structure.reference_name_switch = NEW_REFERENCE_NAMES; ref_name_spec_count = ref_name_spec_count + 1; end; else if substr (arg, 1, 1) = "-" then do; call com_err_ (error_table_$badopt, me, arg); return; end; else do; /* main program name */ if ^control_structure.flags.ec then do; /* need to know dir of main program */ call expand_pathname_ (arg, main_dir, main_ename, code); if code ^= 0 then do; call com_err_ (code, me, arg); return; end; end; have_main = "1"b; goto setup_entry_var; end; end; no_main: have_main = "0"b; setup_entry_var: if ref_name_spec_count > 1 then do; call com_err_ (0, me, "Only one reference name control argument may be specified."); return; end; if control_structure.flags.ec then if no_ec then do; call com_err_ (0, me, "Incompatible exec_com arguments specified."); return; end; if ^control_structure.flags.ec then if ^no_ec then do; /* look for main_program.run.ec */ if ^have_main then do; call com_err_ (0, me, "No exec_com or main program specified."); return; end; call hcs_$status_minf (main_dir, rtrim (main_ename) || ".run.ec", 1, type, bit_cnt, code); if code = 0 then do; control_structure.flags.ec = "1"b; ec_name = rtrim (main_dir) || ">" || rtrim (main_ename) || ".run.ec"; end; end; if control_structure.flags.ec then do; /* this is not an else clause because flag could have been reset */ call hcs_$make_entry (null, "exec_com", "exec_com", main_entry, code); if code ^= 0 then do; call com_err_ (code, me, "exec_com"); return; end; i = i - 1; /* must pass ec name to ec */ end; else do; /* no exec_com; i is index of main */ i = i + 1; /* don't pass name of main to main */ main_entry = cv_entry_ (arg, null, code); if code ^= 0 then do; call com_err_ (code, me, arg); return; end; end; if i > nargs then nprogargs = 0; else nprogargs = nargs - i + 1; sys_areap = get_system_free_area_ (); allocate new_arglist in (sys_areap -> system_area) set (new_arglist_ptr); arglist_ptr = cu_$arg_list_ptr (); new_arglist.arg_count, new_arglist.desc_count = nprogargs * 2; new_arglist.code = 4; if control_structure.flags.ec then do; /* set up ec_name arg */ m = 2; arg_ec_name = ec_name; /* can't pass varying string in command arglist */ new_arglist.args (1) = addr (arg_ec_name); char_desc.size = length (ec_name); new_arglist.descs (1) = addr (char_desc); end; else m = 1; /* first arg is from original arg list */ do j = m to nprogargs; k = j + i - 1; new_arglist.args (j) = old_arglist.args (k); new_arglist.descs (j) = old_arglist.descs (k); end; call run_ (main_entry, new_arglist_ptr, addr (control_structure), code); if code ^= 0 then call com_err_ (code, me); free new_arglist_ptr -> new_arglist; return; end;  run_.pl1 07/05/88 1442.9rew 07/05/88 1426.2 321327 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-06-24,DGHowe), approve(86-06-24,MCR7396), audit(86-08-01,Schroth), install(86-11-20,MR12.0-1222): null variable node seg ptr in cleanup_old_linkage_section 2) change(88-05-03,Farley), approve(88-05-26,MCR7901), audit(88-06-07,GWMay), install(88-07-05,MR12.2-1053): Changed RNT area manipulation code to use stack_header.rnt_ptr directly, instead of copying to the automatic rntp variable. The RNT area can move and using the stack_header is the only sure way of referencing the correct location. Also inhibit interrupts during this period. END HISTORY COMMENTS */ /* format: style3,^indnoniterdo */ run_: proc (main_entry, arglist_ptr, ca_ptr, code); /* coded December 1977 by Melanie Weaver */ /* modified June 1979 by Melanie Weaver to add -old_reference_names handling */ /* modified February 1983 by Melanie Weaver to clean up vla segments */ /* Parameters */ dcl main_entry entry variable; dcl arglist_ptr ptr; dcl ca_ptr ptr; dcl code fixed bin (35); /* Static */ dcl in_run bit (1) aligned static init ("0"b); /* init important for stop_run */ dcl run_sp ptr static init (null); dcl static_abort_label label static; dcl 1 saved_ptrs aligned static like env_ptrs; dcl saved_vla_flag bit (1) aligned static; /* Automatic */ dcl (i, j, old_cur_lot_size, old_rnt_size, rnt_size, nwords, linkage_lng, static_lng, hcscnt, highseg) fixed bin; dcl xcode fixed bin (35); dcl mask bit (36) aligned; dcl timer_set bit (1) aligned; dcl Its_mod bit (6) aligned static options (constant) init ("100011"b); dcl perprocess_array (4096) bit (1) unaligned; dcl (new_lot_ptr, new_isot_ptr, new_sct_ptr, area_ptr, new_rnt_areap, tss_ptr, old_rntp, new_rntp, linkp, run_stp, stp, tp, np, link_ptr, temp_ptr, table_ptr) ptr; dcl (outer_env_linkage_ptr, run_unit_linkage_ptr) ptr unaligned; dcl search_rule_entry_var entry (ptr, fixed bin (35)) variable; dcl 1 search_rules aligned, 2 number fixed bin, 2 name (21) char (168) aligned; dcl 1 auto_run_control_structure aligned like run_control_structure; dcl 1 ainfo aligned like area_info; dcl 1 finish_info aligned, 2 header aligned like condition_info_header, 2 type char (8); dcl 1 cond_info aligned like condition_info; /* Based */ dcl sct_array (128) bit (36) aligned based; dcl based_array (nwords) fixed bin (35) based; dcl based_area area based; dcl based_bit bit (72) aligned based; dcl rnt_area area (rnt_size) based; dcl old_rnt_area area (old_rnt_size) based; dcl linkage_section (linkage_lng) fixed bin (35) based; dcl static_section (static_lng) fixed bin (35) based; dcl 1 control_args aligned based (ca_ptr), 2 flags aligned, 3 ec bit (1) unaligned, 3 crn bit (1) unaligned, 3 pad bit (34) unaligned, 2 time_limit fixed bin (35); dcl 1 temp_seg_struc aligned based (tss_ptr), 2 ntemps fixed bin, 2 segno (2000) fixed bin; /* Builtins */ dcl (addr, addrel, baseno, baseptr, bin, empty, hbound, lbound, null, stackbaseptr, stackframeptr) builtin; dcl (ptr, rel, size, string, unspec) builtin; /* Conditions */ dcl (any_other, cleanup, finish, command_abort_) condition; /* externals */ dcl sys_info$max_seg_size ext fixed bin (19); dcl error_table_$run_unit_not_recursive external fixed bin (35); dcl (get_temp_segment_, release_temp_segment_) entry (char (*), ptr, fixed bin (35)); dcl define_area_ entry (ptr, fixed bin (35)); dcl hcs_$high_low_seg_count entry (fixed bin, fixed bin); dcl hcs_$initiate_search_rules entry (ptr, fixed bin (35)); dcl find_command_$clear entry (); dcl ( hcs_$set_ips_mask, hcs_$reset_ips_mask ) entry (bit (36) aligned, bit (36) aligned); dcl timer_manager_$cpu_call entry (fixed bin (71), bit (2), entry); dcl timer_manager_$reset_cpu_call entry (entry); dcl cu_$generate_call entry (entry, ptr); dcl execute_epilogue_ entry (bit (1) aligned); dcl get_temp_segments_$list_segnos entry (ptr); dcl hcs_$terminate_seg entry (ptr, fixed bin (1), fixed bin (35)); dcl link_unsnap_ entry (ptr, ptr, ptr, fixed bin, fixed bin); dcl release_area_ entry (ptr); dcl find_condition_info_ entry (ptr, ptr, fixed bin (35)); dcl continue_to_signal_ entry (fixed bin (35)); dcl signal_ entry (char (*), ptr, ptr); dcl hcs_$get_search_rules entry (ptr); dcl fortran_storage_manager_$get_vla_segnos entry ((4096) bit (1) unaligned); dcl fortran_storage_manager_$free entry (ptr); if in_run then do; /* do not allow recursive invocation because it won't work */ code = error_table_$run_unit_not_recursive; return; end; code = 0; area_ptr = null; temp_ptr = null; if ca_ptr -> run_control_structure.version = run_control_structure_version_1 then run_cs_ptr = ca_ptr; /* caller used include file */ else do; /* copy items into standard structure */ run_cs_ptr = addr (auto_run_control_structure); run_control_structure.flags.ec = control_args.flags.ec; if control_args.flags.crn then run_control_structure.reference_name_switch = COPY_REFERENCE_NAMES; else run_control_structure.reference_name_switch = NEW_REFERENCE_NAMES; run_control_structure.time_limit = control_args.time_limit; end; mask = "0"b; on cleanup begin; if temp_ptr ^= null then call release_temp_segment_ ("run_", temp_ptr, code); if mask then call hcs_$reset_ips_mask (mask, mask); end; call get_temp_segment_ ("run_", temp_ptr, code); if code ^= 0 then return; call hcs_$set_ips_mask ("0"b, mask); run_sp = stackframeptr; /* save for environment_info entry point */ sb = stackbaseptr; new_lot_ptr = temp_ptr; old_cur_lot_size = sb -> stack_header.cur_lot_size; new_isot_ptr, new_sct_ptr = addrel (new_lot_ptr, old_cur_lot_size); lotp = sb -> stack_header.lot_ptr; isotp = sb -> stack_header.isot_ptr; /* fill in run unit lot */ /* WARNING: If this code is changed to combine new linkage sections for perprocess static segments (copying active static sections), stack_header.trans_op_tv_ptr must be pushed, since it must point to the actual links being used. This assumes that operator_pointers_ is still perprocess static. */ call hcs_$high_low_seg_count (highseg, hcscnt); do i = hcscnt to hcscnt + highseg; if baseno (lotp -> lot.lp (i)) = "0"b then do; /* either 0 or lot fault; just copy entry */ unspec (new_lot_ptr -> lot.lp (i)) = unspec (lotp -> lot.lp (i)); /* use bit copy to avoid possible fault */ unspec (new_isot_ptr -> isot.isp (i)) = unspec (isotp -> isot.isp (i)); end; else if ^lotp -> lot.lp (i) -> linkage_header_flags.perprocess_static then unspec (new_lot_ptr -> lot.lp (i)) = lot_fault; else do; /* perprocess static; use same linkage and static */ new_lot_ptr -> lot.lp (i) = lotp -> lot.lp (i); /* this should combine if there was a lot fault */ new_isot_ptr -> isot.isp (i) = isotp -> isot.isp (i); /* we want any isot faults to handled at this time so static will be in the right place */ end; end; new_isot_ptr -> sct_array = isotp -> sct_array; /* copy static condition table */ /* set up the area for linkage sections, etc. */ ainfo.version = area_info_version_1; ainfo.size = sys_info$max_seg_size - 2 * old_cur_lot_size; /* everything except lot annd isot */ area_ptr, ainfo.areap = addrel (new_isot_ptr, old_cur_lot_size); string (ainfo.control) = "0"b; ainfo.control.extend = "1"b; ainfo.control.zero_on_free = "1"b; ainfo.control.system = "1"b; ainfo.owner = "run_"; call define_area_ (addr (ainfo), code); if code ^= 0 then do; call release_temp_segment_ ("run_", temp_ptr, xcode); call hcs_$reset_ips_mask (mask, mask); return; end; /* allocate new rnt area and initialize rnt if necessary */ if run_control_structure.reference_name_switch ^= OLD_REFERENCE_NAMES then do; /* set up new name space */ allocate_new_rnt: rnt_size = sb -> stack_header.rnt_ptr -> rnt.rnt_area_size; allocate rnt_area in (area_ptr -> based_area) set (new_rnt_areap); if run_control_structure.reference_name_switch = COPY_REFERENCE_NAMES then do; /* copy whole area and update ptrs in rnt */ new_rnt_areap -> rnt_area = empty; new_rnt_areap -> rnt_area = sb -> stack_header.rnt_ptr -> rnt.areap -> rnt_area; if rnt_size ^= sb -> stack_header.rnt_ptr -> rnt.rnt_area_size then do; /* Has RNT grown/moved during the copy? */ free new_rnt_areap -> rnt_area; /* remove the new area */ goto allocate_new_rnt; /* and try again */ end; new_rntp = addrel (new_rnt_areap, (bin (rel (sb -> stack_header.rnt_ptr), 18) - bin (rel (sb -> stack_header.rnt_ptr -> rnt.areap), 18))); new_rntp -> rnt.srulep = addrel (new_rnt_areap, (bin (rel (sb -> stack_header.rnt_ptr -> rnt.srulep), 18) - bin (rel (sb -> stack_header.rnt_ptr -> rnt.areap), 18))); end; else do; /* initialize rnt and set up to init search rules */ ainfo.control.extend = "0"b; /* other control settings are ok */ ainfo.owner = "rnt"; ainfo.size = rnt_size; ainfo.areap = new_rnt_areap; call define_area_ (addr (ainfo), code); if code ^= 0 then do; call release_temp_segment_ ("run_", temp_ptr, xcode); call hcs_$reset_ips_mask (mask, mask); return; end; allocate rnt in (new_rnt_areap -> based_rnt_area) set (new_rntp); new_rntp -> rnt.name_hash_table (*) = null; new_rntp -> rnt.segno_hash_table (*) = null; new_rntp -> rnt.srulep = null; call hcs_$get_search_rules (addr (search_rules)); /* use existing rules by default */ search_rule_entry_var = hcs_$initiate_search_rules; /* must snap link before entering run environment */ end; new_rntp -> rnt.areap = new_rnt_areap; /* same for both cases */ new_rntp -> rnt.rnt_area_size = rnt_size; end; else new_rntp = sb -> stack_header.rnt_ptr; /* no net change when keep same name space */ /* save current environment pointers in static */ saved_ptrs.version = 1; saved_ptrs.pad = 0; saved_ptrs.lot_ptr = lotp; saved_ptrs.isot_ptr = isotp; saved_ptrs.clr_ptr = sb -> stack_header.clr_ptr; saved_ptrs.combined_stat_ptr = sb -> stack_header.combined_stat_ptr; saved_ptrs.user_free_ptr = sb -> stack_header.user_free_ptr; saved_ptrs.sys_link_info_ptr = sb -> stack_header.sys_link_info_ptr; saved_ptrs.rnt_ptr = sb -> stack_header.rnt_ptr; saved_ptrs.sct_ptr = sb -> stack_header.sct_ptr; saved_vla_flag = sb -> stack_header.have_static_vlas; /* set up condition handlers */ on finish begin; dcl 1 based_finish_info aligned based like finish_info; call find_condition_info_ (null, addr (cond_info), xcode); if cond_info.info_ptr = null then call continue_to_signal_ (xcode); else if cond_info.info_ptr -> based_finish_info.type ^= "run" then call continue_to_signal_ (xcode); /* stop signalling if finish is just for run */ end; on any_other system; /* set up wall */ run_sp -> stack_frame_flags.run_unit_manager = "1"b; /* mark stack frame for PL/I options (main) */ call find_command_$clear; /* reset command processor's associative memory */ on cleanup begin; call restore_environment; if temp_ptr ^= null then call release_temp_segment_ ("run_", temp_ptr, code); if mask then call hcs_$reset_ips_mask (mask, mask); end; /* change to run environment */ sb -> stack_header.lot_ptr = new_lot_ptr; sb -> stack_header.isot_ptr, sb -> stack_header.sct_ptr = new_isot_ptr; sb -> stack_header.clr_ptr = area_ptr; sb -> stack_header.combined_stat_ptr = area_ptr; sb -> stack_header.user_free_ptr = area_ptr; sb -> stack_header.sys_link_info_ptr = null; sb -> stack_header.rnt_ptr = new_rntp; sb -> stack_header.have_static_vlas = "0"b; if run_control_structure.reference_name_switch = NEW_REFERENCE_NAMES /* fill in search rules without snapping links */ then call search_rule_entry_var (addr (search_rules), code); call hcs_$reset_ips_mask (mask, mask); /* unmask now */ timer_set = "0"b; on cleanup call Clean_up; if run_control_structure.time_limit > 0 then do; timer_set = "1"b; /* doesn't hurt to set it ahead of time */ call timer_manager_$cpu_call ((run_control_structure.time_limit), "11"b, interrupt_run); end; static_abort_label = abort; in_run = "1"b; sb -> stack_header.main_proc_invoked = 0; /* be sure this is set correctly */ sb -> stack_header.run_unit_depth = 1; call cu_$generate_call (main_entry, arglist_ptr); /* start running */ abort: on cleanup call quick_cleanup; /* be sure critical environment changing is done */ call Clean_up; return; Clean_up: proc; if timer_set then call timer_manager_$reset_cpu_call (interrupt_run); if in_run then do; /* probably did something before stopping */ call execute_epilogue_ ("1"b); /* just run epilogue_ handlers */ if old_cur_lot_size < sb -> stack_header.cur_lot_size then do; /* lot has grown; grow the outer env lot also */ /* This code is similar to that in link_man$grow_lot, which cannot be used here . because it updates the stack header itself, which has already been done within the run unit. */ nwords = 2 * sb -> stack_header.max_lot_size; allocate based_array in (saved_ptrs.clr_ptr -> based_area) set (saved_ptrs.lot_ptr); /* allocate new lot and isot */ saved_ptrs.isot_ptr = addrel (saved_ptrs.lot_ptr, sb -> stack_header.max_lot_size); nwords = old_cur_lot_size; saved_ptrs.lot_ptr -> based_array = lotp -> based_array; /* copy old lot and isot */ saved_ptrs.isot_ptr -> based_array = isotp -> based_array; lotp = saved_ptrs.lot_ptr; isotp = saved_ptrs.isot_ptr; old_cur_lot_size = sb -> stack_header.max_lot_size; new_lot_ptr = sb -> stack_header.lot_ptr; /* update run copies also */ new_isot_ptr = sb -> stack_header.isot_ptr; end; /* Now, if VLA external variables have been used, we must check all the external variables and free any attached VLA segments. We do not need to free the variables themselves because they will go away anyway. */ table_ptr = sb -> stack_header.sys_link_info_ptr; if table_ptr ^= null then if table_ptr -> variable_table_header.flags.have_vla_variables then call free_vla_common (); call hcs_$high_low_seg_count (highseg, hcscnt); /* find current range of segment numbers */ if run_control_structure.reference_name_switch ^= OLD_REFERENCE_NAMES then do; /* terminate segs initiated only in run unit and adjust outer environment LOT */ /* obtain list of non-procedure perprocess_segments */ string (perprocess_array) = "0"b; call find_area_components (saved_ptrs.clr_ptr); /* find all extensions of outer clr area */ if saved_ptrs.combined_stat_ptr ^= saved_ptrs.clr_ptr then call find_area_components (saved_ptrs.combined_stat_ptr); if (sb -> stack_header.system_free_ptr ^= saved_ptrs.clr_ptr) & (sb -> stack_header.system_free_ptr ^= saved_ptrs.combined_stat_ptr) then call find_area_components (sb -> stack_header.system_free_ptr); if (saved_ptrs.user_free_ptr ^= saved_ptrs.clr_ptr) & (saved_ptrs.user_free_ptr ^= saved_ptrs.combined_stat_ptr) & (saved_ptrs.user_free_ptr ^= sb -> stack_header.system_free_ptr) then call find_area_components (saved_ptrs.user_free_ptr); call find_area_components (area_ptr); /* note components in own area; they should be terminated and deleted later by release_area_ if they are not temp segments */ call get_temp_segments_$list_segnos (tss_ptr); /* find all the temp segs */ do i = 1 to temp_seg_struc.ntemps; perprocess_array (temp_seg_struc.segno (i)) = "1"b; end; free tss_ptr -> temp_seg_struc; if sb -> stack_header.have_static_vlas then call fortran_storage_manager_$get_vla_segnos (perprocess_array); /* Note segments used in VLAs so they won't be terminated prematurely. fsm$free wants to truncate them first. */ /* The following code updates the outer environment LOT with the permanent changes that have taken place during the run unit. This comment explains what the possibilities are and what actions are taken for each case. . Run Unit . Environment . 0 lot fault linkage ptr . ____________________________________ . 0 | no change | *1 | *2 | . Outer _|____________|____________|___________| . Environment lot fault | *5 | no change | *3 | . _|____________|____________|____________| . linkage ptr | *4 | no change | *6 | . _|____________|____________|____________| . *1 lot fault if non object perprocess segment; otherwise terminate . *2 if perprocess, allocate linkage in outer, copy virgin linkage, copy static from run unit, . and update outer lot; if not perprocess, terminate . *3 if perprocess, same as *2 perprocess; otherwise do not change . *4 (segment terminated during run unit) do everything term_ does except terminating, . before environment is restored (don't risk reuse of segno in meantime) . *5 (segment terminated during run unit) zero LOT entry and unsnap links to seg in outer . *6 if perprocess, unsnap all links snapped during run unit because some are invalid; otherwise (shouldn't be possible) do not change */ do i = hcscnt to hcscnt + highseg; unspec (outer_env_linkage_ptr) = unspec (lotp -> lot.lp (i)); unspec (run_unit_linkage_ptr) = unspec (new_lot_ptr -> lot.lp (i)); if unspec (outer_env_linkage_ptr) = unspec (run_unit_linkage_ptr) then do; if baseno (outer_env_linkage_ptr) /* had linkage ptr in outer env */ then if outer_env_linkage_ptr -> linkage_header_flags.perprocess_static /* superfluous; wouldn't be = if not perprocess */ then call unsnap_links_in_outer_pps_linkage (i); end; else if unspec (outer_env_linkage_ptr) = "0"b then do; /* seg not known before run unit */ if unspec (run_unit_linkage_ptr) = lot_fault then do; /* no active linkage section */ if perprocess_array (i) then unspec (lotp -> lot.lp (i)) = lot_fault; /* don't forget about temp segs, etc. */ else call hcs_$terminate_seg (baseptr (i), 0, code); end; else do; /* segment with linkage section */ if run_unit_linkage_ptr -> linkage_header_flags.perprocess_static then call copy_linkage (i); else do; if run_unit_linkage_ptr -> linkage_header_flags.static_vlas then call fortran_storage_manager_$free ((run_unit_linkage_ptr)); call hcs_$terminate_seg (baseptr (i), 0, code); end; end; end; else if unspec (outer_env_linkage_ptr) = lot_fault then do; /* segment initiated before run unit but no linkage in outer */ if unspec (run_unit_linkage_ptr) = "0"b then do; call link_unsnap_ (lotp, isotp, addrel (baseptr (i), -1), hcscnt, highseg); /* indicate no linkage section by offset of -1 */ lotp -> lot.lp (i) = baseptr (0); /* indicate termination in outer env */ end; else do; /* seg has linkage section in run unit only */ if run_unit_linkage_ptr -> linkage_header_flags.perprocess_static then call copy_linkage (i); else if run_unit_linkage_ptr -> linkage_header_flags.static_vlas then call fortran_storage_manager_$free ((run_unit_linkage_ptr)); /* leave a lot fault but free "attached" VLAs before throwing away linkage section from run unit */ end; end; else do; /* seg with linkage section in outer environment */ if unspec (run_unit_linkage_ptr) = "0"b then call cleanup_old_linkage_section (i); /* seg has since been terminated; clean up outer env */ else if unspec (run_unit_linkage_ptr) ^= lot_fault /* non-pps linkage section in run unit; free "attached" VLAs before throwing it away */ then if run_unit_linkage_ptr -> linkage_header_flags.static_vlas then call fortran_storage_manager_$free ((run_unit_linkage_ptr)); end; end; end; /* of new_name_space cleanup */ else do; /* same name space case -- same RNT is used and segs are not terminated */ if sb -> stack_header.rnt_ptr ^= saved_ptrs.rnt_ptr then do; /* RNT got reallocated (grown) in run unit's area; copy it back into outer environment */ call hcs_$set_ips_mask ("0"b, mask); reallocate_new_rnt: rnt_size = sb -> stack_header.rnt_ptr -> rnt.rnt_area_size; allocate rnt_area in (saved_ptrs.clr_ptr -> based_area) set (new_rnt_areap); /* allocate new RNT in outer environment */ new_rnt_areap -> rnt_area = empty; /* PL/I areas must be initiaslized before being used in any way */ new_rnt_areap -> rnt_area = sb -> stack_header.rnt_ptr -> rnt.areap -> rnt_area; /* copy it out */ if rnt_size ^= sb -> stack_header.rnt_ptr -> rnt.rnt_area_size then do; /* Has RNT grown/moved during the copy? */ free new_rnt_areap -> rnt_area; /* remove the new area */ goto reallocate_new_rnt; /* and try again */ end; new_rntp = addrel (new_rnt_areap, bin (rel (sb -> stack_header.rnt_ptr), 18) - bin (rel (sb -> stack_header.rnt_ptr -> rnt.areap), 18)); /* locate copy of RNT within area */ new_rntp -> rnt.areap = new_rnt_areap; new_rntp -> rnt.srulep = addrel (new_rnt_areap, bin (rel (sb -> stack_header.rnt_ptr -> rnt.srulep), 18) - bin (rel (sb -> stack_header.rnt_ptr -> rnt.areap), 18)); /* must relocate search rule ptr in new area */ old_rntp = sb -> stack_header.rnt_ptr; old_rnt_size = sb -> stack_header.rnt_ptr -> rnt.rnt_area_size; sb -> stack_header.rnt_ptr = new_rntp; free old_rntp -> rnt.areap -> old_rnt_area; call hcs_$reset_ips_mask (mask, mask); end; /* The following code updates the outer environment LOT with the permanent changes that have taken place during the run unit. This comment explains what the possibilities are and what actions are taken for each case. . Run Unit . Environment . 0 lot fault linkage ptr . ____________________________________ . 0 | no change | lot fault | *1 | . Outer _|____________|____________|___________| . Environment lot fault | *2 | no change | *1 | . _|____________|____________|____________| . linkage ptr | *3 | no change | *4 | . _|____________|____________|____________| *1 if perprocess, allocate linkage in outer, copy virgin linkage, copy static from run unit, and update outer LOT; if not perprocess, set lot fault *2 (segment terminated during run unit) zero LOT entry and unsnap links to segment in outer *3 (segment terminated during run unit) do everything term_ does except terminating, before environment is restored . *4 if perprocess, unsnap all links snapped during run unit because some are invalid; otherwise (shouldn't be possible) do not change */ do i = hcscnt to hcscnt + highseg; unspec (outer_env_linkage_ptr) = unspec (lotp -> lot.lp (i)); unspec (run_unit_linkage_ptr) = unspec (new_lot_ptr -> lot.lp (i)); if unspec (outer_env_linkage_ptr) = unspec (run_unit_linkage_ptr) then do; if baseno (outer_env_linkage_ptr) /* had linkage ptr in outer env */ then if outer_env_linkage_ptr -> linkage_header_flags.perprocess_static /* superfluous; wouldn't be = if not perprocess */ then call unsnap_links_in_outer_pps_linkage (i); end; else if unspec (outer_env_linkage_ptr) = "0"b then do; /* segment was not known before run unit */ if unspec (run_unit_linkage_ptr) = lot_fault then unspec (lotp -> lot.lp (i)) = lot_fault; else do; if run_unit_linkage_ptr -> linkage_header_flags.perprocess_static then call copy_linkage (i); else do; if run_unit_linkage_ptr -> linkage_header_flags.static_vlas then call fortran_storage_manager_$free ((run_unit_linkage_ptr)); unspec (lotp -> lot.lp (i)) = lot_fault; end; end; end; else if unspec (outer_env_linkage_ptr) = lot_fault then do; /* segment was initiated before run unit but had no linkage in outer */ if unspec (run_unit_linkage_ptr) = "0"b then do; call link_unsnap_ (lotp, isotp, addrel (baseptr (i), -1), hcscnt, highseg); /* indicate no linkage section by offset of -1 */ lotp -> lot.lp (i) = baseptr (0); /* indicate termination in outer environment */ end; else do; if run_unit_linkage_ptr -> linkage_header_flags.perprocess_static then call copy_linkage (i); else if run_unit_linkage_ptr -> linkage_header_flags.static_vlas then call fortran_storage_manager_$free ((run_unit_linkage_ptr)); end; end; else do; /* segment with linkage section in outer environment */ if unspec (run_unit_linkage_ptr) = "0"b then call cleanup_old_linkage_section (i); /* segment has since been terminated; clean up outer environment */ else if unspec (run_unit_linkage_ptr) ^= lot_fault /* non-pps linkage section in run unit; free "attached" VLAs before throwing it away */ then if run_unit_linkage_ptr -> linkage_header_flags.static_vlas then call fortran_storage_manager_$free ((run_unit_linkage_ptr)); end; end; /* of LOT entry comparison loop */ end; /* of code to cleanup same name space case */ end; /* of stuff done when in_run is on */ /* now restore the outer environment */ call quick_cleanup; code = 0; /* just in case */ end; interrupt_run: proc (mcptr, cname); /* This is the routine called by timer_manager_ when the user specifies a time limit. */ dcl mcptr ptr; dcl cname char (*); dcl answer char (10) varying; dcl command_query_ entry options (variable); dcl 1 query_info aligned, 2 version fixed bin init (2), 2 yes_or_no_sw bit (1) unaligned init ("1"b), 2 suppress_name_sw bit (1) unaligned init ("0"b), 2 code fixed bin (35) init (0), 2 query_code fixed bin (35) init (0); call command_query_ (addr (query_info), answer, "run", "Time limit reached. Do you want to continue the program? "); if answer = "no" then goto abort; call timer_manager_$cpu_call ((run_control_structure.time_limit), "11"b, interrupt_run); end; quick_cleanup: proc; /* this procedure does the most essential cleaning up of the environment and static variables */ sb -> stack_header.run_unit_depth = 0; sb -> stack_header.main_proc_invoked = 0; mask = "0"b; on cleanup begin; if mask then call hcs_$reset_ips_mask (mask, mask); end; call hcs_$set_ips_mask ("0"b, mask); call restore_environment; in_run = "0"b; call hcs_$reset_ips_mask (mask, mask); run_sp = null; call find_command_$clear; /* clear command processor assoc. memory again */ end; restore_environment: proc; /* restore original stack header variables and release temp seg */ sb -> stack_header.lot_ptr = saved_ptrs.lot_ptr; sb -> stack_header.isot_ptr = saved_ptrs.isot_ptr; sb -> stack_header.clr_ptr = saved_ptrs.clr_ptr; sb -> stack_header.combined_stat_ptr = saved_ptrs.combined_stat_ptr; sb -> stack_header.user_free_ptr = saved_ptrs.user_free_ptr; sb -> stack_header.sys_link_info_ptr = saved_ptrs.sys_link_info_ptr; sb -> stack_header.sct_ptr = saved_ptrs.sct_ptr; if run_control_structure.reference_name_switch ^= OLD_REFERENCE_NAMES then sb -> stack_header.rnt_ptr = saved_ptrs.rnt_ptr; sb -> stack_header.have_static_vlas = saved_vla_flag; if area_ptr ^= null then call release_area_ (area_ptr); /* clean up any area extensions */ if temp_ptr ^= null then call release_temp_segment_ ("run_", temp_ptr, code); end; copy_linkage: proc (segno); /* copy original linkage section and static section from run unit into outer environment */ dcl segno fixed bin; linkage_lng = bin (run_unit_linkage_ptr -> header.stats.block_length, 18); allocate linkage_section in (saved_ptrs.clr_ptr -> based_area) set (linkp); linkp -> linkage_section = run_unit_linkage_ptr -> header.original_linkage_ptr -> linkage_section; /* copy virgin linkage into outer env */ linkage_lng = size (header); linkp -> linkage_section = run_unit_linkage_ptr -> linkage_section; /* copy active header stuff */ static_lng = bin (linkp -> header.stats.static_length, 18); if static_lng > 0 then do; /* have a static section */ run_stp = new_isot_ptr -> isot.isp (segno); if run_stp ^= run_unit_linkage_ptr /* separate static */ then allocate static_section in (saved_ptrs.combined_stat_ptr -> based_area) set (stp); else do; stp = addrel (linkp, size (header)); run_stp = addrel (run_stp, size (header)); end; stp -> static_section = run_stp -> static_section; /* copy static */ if new_isot_ptr -> isot.isp (segno) = run_unit_linkage_ptr then stp = linkp; end; else stp = linkp; /* no static; isote = lote by default */ saved_ptrs.lot_ptr -> lot.lp (segno) = linkp; /* update original lot, isot */ saved_ptrs.isot_ptr -> isot.isp (segno) = stp; end; unsnap_links_in_outer_pps_linkage: proc (segno); /* This procedure unsnaps all links in a perprocess segment that were snapped during the run unit because they may have been snapped to segments being terminated. This wouldn't be necessary if perprocess segments also got new linkage sections during run units. */ declare segno fixed bin; linkp = lotp -> lot.lp (segno); do j = bin (linkp -> header.stats.begin_links, 18) to bin (linkp -> header.stats.block_length, 18) - 1 by 2; link_ptr = addrel (linkp, j); if link_ptr -> link.ft2 = Its_mod /* snapped link */ then if link_ptr -> link.run_depth > 0 /* snapped during run unit */ then link_ptr -> based_bit = addrel (linkp -> header.original_linkage_ptr, j) -> based_bit; end; return; end; cleanup_old_linkage_section: proc (segno); /* This procedure does what term_ does but in the outer environment (except terminating). */ dcl segno fixed bin; call link_unsnap_ (lotp, isotp, (outer_env_linkage_ptr), hcscnt, highseg); if saved_ptrs.sys_link_info_ptr ^= null then do; /* there are *system links */ tp = saved_ptrs.sys_link_info_ptr; do j = lbound (tp -> variable_table_header.hash_table, 1) to hbound (tp -> variable_table_header.hash_table, 1); do np = tp -> variable_table_header.hash_table (j) repeat np -> variable_node.forward_thread while (np ^= null); if bin (baseno (np -> variable_node.init_ptr), 15) = i then do; /* zap init ptrs to terminated seg */ np -> variable_node.init_ptr = null; np -> variable_node.seg_ptr = null; end; end; end; end; /* now free static and linkage */ if isotp -> isot.isp (segno) ^= outer_env_linkage_ptr then if isotp -> isot1 (segno).flags.fault ^= "11"b then do; /* have separate static section to free */ free isotp -> isot.isp (segno) -> static_section; end; unspec (isotp -> isot.isp (segno)) = "0"b; /* 0 the isot slot to be discarded */ free outer_env_linkage_ptr -> linkage_section; unspec (lotp -> lot.lp (segno)) = "0"b; return; end /* cleanup_old_linkage_section */; find_area_components: proc (a_area_ptr); /* this subroutine turns on a bit in the perprocess array for each segment contained in the given area. */ dcl (a_area_ptr, area_ptr) ptr; dcl ii fixed bin; area_ptr = a_area_ptr; do ii = 1 to 500 while (area_ptr ^= null); /* set limit to avoid infinite loop */ perprocess_array (bin (baseno (area_ptr), 15)) = "1"b; if area_ptr -> area_header.extend_info then area_ptr = addrel (area_ptr, area_ptr -> area_header.extend_info) -> extend_block.next_area; else area_ptr = null; end; end; free_vla_common: proc (); dcl node_ptr ptr; dcl hash_index fixed bin; if table_ptr -> variable_table_header.cur_num_of_variables < 1 then return; do hash_index = lbound (table_ptr -> variable_table_header.hash_table, 1) to hbound (table_ptr -> variable_table_header.hash_table, 1); node_ptr = table_ptr -> variable_table_header.hash_table (hash_index); do while (node_ptr ^= null); if node_ptr -> variable_node.vbl_size > sys_info$max_seg_size then call fortran_storage_manager_$free (node_ptr); node_ptr = node_ptr -> variable_node.forward_thread; end; end; return; end; environment_info: entry (asp, ep, ecode); /* This entry returns stack header information which is relevant for a given stack frame */ dcl (asp, ep) ptr; dcl ecode fixed bin (35); ecode = 0; if in_run & (bin (rel (asp), 18) < bin (rel (run_sp), 18)) then do; ep -> env_ptrs = saved_ptrs; end; else do; /* in run unit; return current info */ sb = ptr (addr (sb), 0); ep -> env_ptrs.lot_ptr = sb -> stack_header.lot_ptr; ep -> env_ptrs.isot_ptr = sb -> stack_header.isot_ptr; ep -> env_ptrs.clr_ptr = sb -> stack_header.clr_ptr; ep -> env_ptrs.combined_stat_ptr = sb -> stack_header.combined_stat_ptr; ep -> env_ptrs.user_free_ptr = sb -> stack_header.user_free_ptr; ep -> env_ptrs.sys_link_info_ptr = sb -> stack_header.sys_link_info_ptr; ep -> env_ptrs.rnt_ptr = sb -> stack_header.rnt_ptr; ep -> env_ptrs.sct_ptr = sb -> stack_header.sct_ptr; end; return; stop_run: entry; /* This entry is a command and is also called by the PL/I and fortran stop statements */ if in_run then do; /* set up structure for signalling finish */ finish_info.header.length = size (finish_info); finish_info.header.version = 1; string (finish_info.header.action_flags) = "0"b; finish_info.header.default_restart = "1"b; finish_info.header.info_string = ""; finish_info.header.status_code = 0; finish_info.type = "run"; call signal_ ("finish", null, addr (finish_info)); goto static_abort_label; end; else do; signal command_abort_; return; end; %include run_control_structure; %include env_ptrs; %include lot; %include area_info; %include area_structures; %include rnt; %include stack_header; %include linkdcl; %include system_link_names; %include stack_frame; %include condition_info_header; %include condition_info; end;  set_fortran_common.pl1 11/20/86 1359.8rew 11/20/86 1142.5 191673 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-06-24,DGHowe), approve(86-06-24,MCR7420), audit(86-08-21,Schroth), install(86-11-20,MR12.0-1222): changed calling sequence for list_init_ 2) change(86-08-06,Elhard), approve(86-08-06,MCR7457), audit(86-08-22,DGHowe), install(86-11-20,MR12.0-1222): Modified to look in all components of object MSFs for external links and to ignore external variables with deferred initialization. END HISTORY COMMENTS */ /* format: style3,^indnoniterdo */ set_fortran_common: sfc: proc; /* This program finds the links to common blocks in the specified segments and obtains the initialization info from them. If there are multiple initializations for the same common block, they are combined, with the longest length being used. Then all the common blocks are initialized with the specified init info (allocated first if necessary). */ /* coded October 18, 1977 by Melanie Weaver */ /* modified December , 1977 by Melanie Weaver to increase dimensions and handle stat_ */ /* Modified: November 12, 1982 - T Oke, to handle Very Large Array COMMON. */ /* modified January 1983 by Melanie Weaver to handle variables occupying a whole segment */ /* Modified November 1 1984 by M. Mabey to explicitly zero any variable that is */ /* reinitialized with list templates. */ /* AUTOMATIC */ dcl (nargs, alng, i, j, nblocks) fixed bin; dcl (new_vsize, variable_size) fixed bin (35); dcl bitcnt fixed bin (24); dcl type fixed bin (18); dcl code fixed bin (35); dcl (longsw, fatalsw, found_sw) bit (1) aligned; dcl block_end bit (18) aligned; dcl dummy_init_info bit (72) aligned; dcl k fixed bin; dcl sys_areap ptr; dcl sys_area area based (sys_areap); dcl n_segs fixed bin; dcl msf_sw bit (1); dcl (aptr, seg_ptr, p, type_ptr, segnp, node_ptr, ext_ptr) ptr; dcl viptr (2) ptr; dcl ext_name char (65); dcl dir char (168); dcl ent char (32); dcl component_generator char (8); dcl 1 seg_info (1000) aligned based (viptr (2)), 2 pathname char (168), 2 segp ptr, 2 bc fixed bin (24); dcl 1 var_info (10000) aligned based (viptr (1)), 2 init_ptr ptr, 2 vsize fixed bin (35), 2 init_owner fixed bin, 2 name char (65) unaligned; dcl 1 oi aligned like object_info; /* CONSTANTS */ dcl me char (18) init ("set_fortran_common") static options (constant); dcl Fault_Tag_2 bit (6) aligned init ("100110"b) static options (constant); /* EXTERNALS */ dcl (addr, addrel, baseno, bin, bit, clock, divide, empty, fixed, index, rel, max, null, ptr, substr, unspec) builtin; dcl cleanup condition; dcl ( error_table_$badopt, error_table_$bad_link_target_init_info ) ext fixed bin (35); dcl sys_info$max_seg_size ext fixed bin (35); dcl pl1_operators_$VLA_words_per_seg_ fixed bin (19) external; dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl (com_err_, ioa_) entry options (variable); dcl get_system_free_area_ entry () returns (ptr); dcl object_lib_$initiate entry (char (*), char (*), char (*), bit (1), ptr, fixed bin (24), bit (1), fixed bin (35)); dcl object_lib_$get_component_info entry (ptr, ptr, char (8), char (*), ptr, fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35)); dcl set_ext_variable_ entry (char(*), ptr, ptr, bit(1) aligned, ptr, fixed bin(35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl (get_temp_segments_, release_temp_segments_) entry (char (*), (*) ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl unique_chars_ entry (bit (36)) returns (char (15)); dcl list_init_ entry (ptr, ptr, fixed bin (35), ptr , ptr, fixed bin(35)); dcl list_init_$variable_already_zero entry (ptr, ptr, fixed bin (35), ptr, ptr, fixed bin(35)); dcl fortran_storage_manager_$alloc entry (fixed bin, ptr, ptr); dcl fortran_storage_manager_$free entry (ptr); /* BASED */ dcl arg char (alng) based (aptr); dcl new_init_info (new_vsize) fixed bin (35) based; dcl based_area area (variable_size) based; dcl variable (variable_size) bit (36) based; dcl 1 acc_name aligned based, 2 nsize fixed bin (8) unal, 2 string char (0 refer (acc_name.nsize)) unaligned; /* */ nblocks = 0; n_segs = 0; longsw = "0"b; fatalsw = "0"b; sb = ptr (addr (sb), 0); lotp = sb -> stack_header.lot_ptr; call cu_$arg_count (nargs); if nargs = 0 then do; call com_err_ (0, me, "Usage is: set_fortran_common paths {-long}"); return; end; sys_areap = get_system_free_area_ (); viptr (1) = null; comp_infop = null; on cleanup begin; if viptr (1) ^= null then do; do i = 1 to n_segs; if seg_info (i).segp ^= null then call hcs_$terminate_noname (seg_info (i).segp, code); end; call release_temp_segments_ (me, viptr, code); end; if comp_infop ^= null then free component_info in (sys_area); end; call get_temp_segments_ (me, viptr, code); do i = 1 to nargs; /* first loop to find control args */ call cu_$arg_ptr (i, aptr, alng, code); if (arg = "-long") | (arg = "-lg") then do; longsw = "1"b; goto end_arg_loop; end; else if substr (arg, 1, 1) = "-" then do; call com_err_ (error_table_$badopt, me, arg); fatalsw = "1"b; end; call expand_pathname_ (arg, dir, ent, code); if code ^= 0 then do; error1: call com_err_ (code, me, arg); fatalsw = "1"b; goto end_arg_loop; end; call object_lib_$initiate (dir, ent, "", "1"b, seg_ptr, bitcnt, msf_sw, code); if code ^= 0 then do; error2: call com_err_ (code, me, "^a>^a", dir, ent); fatalsw = "1"b; goto end_arg_loop; end; seg_info (n_segs+1).segp = null; /* initialize variable for cleanup handler. */ n_segs = n_segs + 1; do j = 1 to n_segs - 1; /* see if this arg is a duplicate */ if seg_info (j).segp = seg_ptr then do; /* already have this one */ n_segs = n_segs - 1; goto end_arg_loop; end; end; seg_info (n_segs).segp = seg_ptr; seg_info (n_segs).bc = bitcnt; seg_info (n_segs).pathname = pathname_ (dir, ent); if msf_sw then do; call object_lib_$get_component_info (seg_ptr, sys_areap, component_info_version_1, "none", comp_infop, code); if code ^= 0 then goto error2; do j = 1 to component_info.max; seg_info (n_segs+1).segp = null; /* initialize variable for cleanup handler. */ n_segs = n_segs + 1; do k = 1 to n_segs - 1; /* see if this arg is a duplicate */ if seg_info (k).segp = component_info.comp (j).segp then do; /* already have this one */ n_segs = n_segs - 1; free component_info in (sys_area); comp_infop = null; goto end_arg_loop; end; end; seg_info (n_segs).segp = component_info.comp (j).segp; seg_info (n_segs).bc = component_info.comp (j).bc; seg_info (n_segs).pathname = pathname_ (dir, ent); end; free component_info in (sys_area); comp_infop = null; end; end_arg_loop: end; if fatalsw then goto terminate; do i = 1 to n_segs; /* get object info and check for non fortran */ oi.version_number = object_info_version_2; call object_info_$brief (seg_info (i).segp, seg_info (i).bc, addr (oi), code); if code ^= 0 then goto error2; /* . call get_bound_seg_info_ (seg_ptr, bitcnt, addr (oi), bmp, binder_sblkp, code); . if code ^= 0 then do; . if code ^= error_table_$not_bound then goto error2; . if (oi.compiler = "fortran") | (oi.compiler = "fortran2") then goto has_fortran; . end; . else do j = 1 to bmp -> bindmap.n_components; . component_generator = addrel (oi.symbp, bmp -> bindmap.component (j).symb_start) . -> std_symbol_header.generator; . if (component_generator = "fortran") | (component_generator = "fortran2") . then goto has_fortran; . end; . . fatalsw = "1"b; . if code = 0 then call com_err_ (0, me, "^a does not have a fortran component.", arg); . else call com_err_ (0, me, "^a was not compiled by fortran.", arg); . . goto end_arg_loop; . .has_fortran: */ /* look through links for common */ if oi.linkp -> virgin_linkage_header.defs_in_link = "010000"b then block_end = rel (addrel (oi.linkp, oi.linkp -> virgin_linkage_header.def_offset)); else block_end = rel (addrel (oi.linkp, oi.linkp -> virgin_linkage_header.linkage_section_lng)); do p = addrel (oi.linkp, oi.linkp -> header.stats.begin_links) repeat (addrel (p, 2)) while (rel (p) < block_end); if p -> link.ft2 = Fault_Tag_2 then do; /* see if it is to common */ type_ptr = addrel (oi.defp, (addrel (oi.defp, p -> link.exp_ptr) -> exp_word.type_ptr)); type = bin (type_ptr -> type_pair.type, 18); if type = 5 then do; if bin (type_ptr -> type_pair.seg_ptr, 18) = 5 /* *system */ then ext_name = addrel (oi.defp, type_ptr -> type_pair.ext_ptr) -> acc_name.string; else goto next_link; end; else if type = 6 then do; segnp = addrel (oi.defp, type_ptr -> type_pair.seg_ptr); ext_ptr = addrel (oi.defp, type_ptr -> type_pair.ext_ptr); if ext_ptr -> acc_name.nsize = 0 then do; j = index (segnp -> acc_name.string, ".com"); if (j = 0) | (j < (segnp -> acc_name.nsize - 3)) then goto next_link; ext_name = substr (segnp -> acc_name.string, 1, j - 1); if ext_name = "b_" then ext_name = "blnk*com"; end; else if segnp -> acc_name.string = "stat_" then ext_name = ext_ptr -> acc_name.string; else if segnp -> acc_name.string = "cobol_fsb_" then ext_name = "cobol_fsb_" || ext_ptr -> acc_name.string; else goto next_link; end; else goto next_link; end; else goto next_link; /* not a link */ if type_ptr -> type_pair.trap_ptr = "0"b then goto next_link; /* no init info */ init_info_ptr = addrel (oi.defp, type_ptr -> type_pair.trap_ptr); do j = 1 to nblocks; /* see if name is on list; if not, add it */ if ext_name = var_info (j).name then do; /* we do have name */ if init_info_ptr -> init_info.type > NO_INIT & init_info_ptr -> init_info.type ^= INIT_DEFERRED then do; /* we have an init template */ if var_info (j).init_ptr -> init_info.type = NO_INIT then do; /* now we have init template to use */ var_info (j).init_ptr = init_info_ptr; var_info (j).init_owner = i; end; else if var_info (j).init_ptr -> init_info.size < init_info_ptr -> init_info.size then do; /* have a larger template to use */ call ioa_ ( "^a: Initialization for common block ^a defined in subprogram ^a^/^-replacing initialization defined in subprogram ^a because it is longer.", me, ext_name, seg_info (i).pathname, seg_info (var_info (j).init_owner).pathname); var_info (j).init_ptr = init_info_ptr; var_info (j).init_owner = i; end; else do; /* new template is same or smaller size */ if unspec (var_info (j).init_ptr -> init_info.init_template) ^= unspec (init_info_ptr -> init_info.init_template) then call ioa_ ( "^a: Initialization for common block ^a defined in subprogram ^a is ignored; ^/^-using initialization defined in subprogram ^a.", me, ext_name, seg_info (i).pathname, seg_info (var_info (j).init_owner).pathname); end; end; var_info (j).vsize = max (var_info (j).vsize, init_info_ptr -> init_info.size); goto next_link; end; end; nblocks = nblocks + 1; var_info (nblocks).init_ptr = init_info_ptr; var_info (nblocks).vsize = init_info_ptr -> init_info.size; var_info (nblocks).init_owner = i; var_info (nblocks).name = ext_name; next_link: end; end; if fatalsw then goto terminate; /* we have gone as far as we can go */ if nblocks = 0 then do; call ioa_ ("^a: None of the specified programs have any common blocks.", me); goto terminate; end; /* now allocate/initialize all common blocks */ do i = 1 to nblocks; new_vsize = 0; if var_info (i).vsize > var_info (i).init_ptr -> init_info.size then do; /* must make temp init info with correct size */ if var_info (i).init_ptr -> init_info.type = TEMPLATE_INIT then do; /* must copy template */ new_vsize = var_info (i).vsize + 2; allocate new_init_info in (sb -> stack_header.user_free_ptr -> based_area) set (init_info_ptr); init_info_ptr -> init_info.size = var_info (i).vsize; init_info_ptr -> init_info.type = TEMPLATE_INIT; unspec (init_info_ptr -> init_info.init_template) = unspec (var_info (i).init_ptr -> init_info.init_template); end; else if var_info (i).init_ptr -> init_info.type = LIST_TEMPLATE_INIT then do; /* copy list template */ new_vsize = var_info (i).init_ptr -> list_init_info.list_size + 3; allocate new_init_info in (sb -> stack_header.user_free_ptr -> based_area) set (init_info_ptr); unspec (init_info_ptr -> list_init_info) = unspec (var_info (i).init_ptr -> list_init_info); init_info_ptr -> init_info.size = var_info (i).vsize; end; else do; init_info_ptr = addr (dummy_init_info); init_info_ptr -> init_info.size = var_info (i).vsize; init_info_ptr -> init_info.type = var_info (i).init_ptr -> init_info.type; end; end; else init_info_ptr = var_info (i).init_ptr; /* can use program's init info directly */ call set_ext_variable_ (var_info (i).name, init_info_ptr, sb, found_sw, node_ptr, code); if code ^= 0 then if ^found_sw then do; init_error: call com_err_ (code, me, "Initializing common block ^a", var_info (i).name); if new_vsize > 0 then free init_info_ptr -> new_init_info; goto terminate; end; if ^found_sw then goto next_block; /* allocated as specified */ if node_ptr -> variable_node.vbl_size < init_info_ptr -> init_info.size then do; /* must reallocate and unsnap links */ if longsw then call ioa_ ( "^a: Common block ^a is already in use with a smaller block length.^/^-The old version will be deleted.", me, var_info (i).name); call delete_it (node_ptr); variable_size = init_info_ptr -> init_info.size; if variable_size > sys_info$max_seg_size then do; if (init_info_ptr -> init_info.type ^= NO_INIT) & (init_info_ptr -> init_info.type ^= LIST_TEMPLATE_INIT) then do; /* multi-seg variable can't have template or area */ code = error_table_$bad_link_target_init_info; go to init_error; end; call fortran_storage_manager_$alloc ( divide (variable_size + pl1_operators_$VLA_words_per_seg_ - 1, pl1_operators_$VLA_words_per_seg_, 17), node_ptr, node_ptr -> variable_node.vbl_ptr); end; else if variable_size > (sys_info$max_seg_size - 50) then do; call hcs_$make_seg ("", unique_chars_ (""b) || "linker", "", 01110b, node_ptr -> variable_node.vbl_ptr, code); if code ^= 0 then go to init_error; end; else allocate variable in (sb -> stack_header.user_free_ptr -> based_area) set (node_ptr -> variable_node.vbl_ptr); node_ptr -> variable_node.vbl_size = variable_size; node_ptr -> variable_node.time_allocated = clock (); sb -> stack_header.sys_link_info_ptr -> variable_table_header.total_allocated_size = sb -> stack_header.sys_link_info_ptr -> variable_table_header.total_allocated_size + variable_size; end; /* reinitialize the variable; not worth checking to see if it's already OK */ variable_size = node_ptr -> variable_node.vbl_size; if init_info_ptr -> init_info.type = NO_INIT then call list_init_ (node_ptr -> variable_node.vbl_ptr, null (), variable_size, null(), null(), code); else if init_info_ptr -> init_info.type = EMPTY_AREA_INIT /* this would not be a fortran link */ then node_ptr -> variable_node.vbl_ptr -> based_area = empty; else if init_info_ptr -> init_info.type = LIST_TEMPLATE_INIT /* list_template init */ then do; call list_init_ (node_ptr -> variable_node.vbl_ptr, null (), variable_size, null(), null(), code); call list_init_$variable_already_zero ( node_ptr -> variable_node.vbl_ptr, addr (init_info_ptr -> list_init_info.template), variable_size, null(), null(), code); end; else unspec (node_ptr -> variable_node.vbl_ptr -> variable) = unspec (init_info_ptr -> init_info.init_template); /* now check for possible errors from list init and set_ext_var */ if code ^= 0 then do; call com_err_ (code,me, " while referencing ^a", node_ptr->variable_node.name); goto terminate; end; node_ptr -> variable_node.init_type = init_info_ptr -> init_info.type; next_block: node_ptr -> variable_node.init_ptr = var_info (i).init_ptr; /* fill in with permanent address */ if new_vsize > 0 then free init_info_ptr -> new_init_info; end; /* now terminate noname everything that was known before the command was invoked */ terminate: do i = 1 to n_segs; if seg_info (i).segp ^= null then call hcs_$terminate_noname (seg_info (i).segp, code); end; if viptr (1) ^= null then call release_temp_segments_ (me, viptr, code); return; /* */ delete_it: proc (np); /* This procedure unsnaps the links to an external variable and then frees it */ dcl (np, headptr, defstartptr, linkstartptr, itsptr, vlp, lptr, vptr) ptr; dcl based_ptr ptr based; dcl based_double bit (72) aligned based; dcl (segno, hcscnt, high_seg) fixed bin; dcl vsize fixed bin (35); dcl old_variable (vsize) bit (36) based; dcl hcs_$high_low_seg_count entry (fixed bin, fixed bin); dcl delete_$ptr entry (ptr, bit (6), char (*), fixed bin (35)); vptr = np -> variable_node.vbl_ptr; /* get value links would have */ call hcs_$high_low_seg_count (high_seg, hcscnt); do segno = hcscnt + 1 to hcscnt + high_seg; if rel (lotp -> lot.lp (segno)) ^= "0"b then do; headptr = lotp -> lot.lp (segno); defstartptr = headptr -> header.def_ptr;/* pointer to beginning of def section */ linkstartptr = addrel (headptr, headptr -> header.stats.begin_links); /* check for defs in linkage section and compute end of links */ if (baseno (linkstartptr) = baseno (defstartptr)) & (fixed (rel (defstartptr), 18) > fixed (rel (linkstartptr), 18)) then block_end = rel (defstartptr); /* end of links before end of block if defs follow links */ else block_end = rel (addrel (headptr, headptr -> header.stats.block_length)); /* end of links and of block are the same */ do itsptr = linkstartptr repeat (addrel (itsptr, 2)) /* loop through all links */ while (rel (itsptr) < block_end); if itsptr -> its.its_mod = "100011"b then do; /* snapped link */ lptr = itsptr -> based_ptr; /* copy to pick up any indirection */ if lptr = vptr then do; /* have a link pointing to the variable; unsnap */ vlp = headptr -> header.original_linkage_ptr; itsptr -> based_double = addrel (vlp, bit (bin (bin (rel (itsptr), 18) - bin (rel (headptr), 18), 18))) -> based_double; end; end; end; end; end; /* now free the variable */ vsize = np -> variable_node.vbl_size; if vsize > sys_info$max_seg_size then call fortran_storage_manager_$free (np); else if rel (np -> variable_node.vbl_ptr) = "0"b /* separate seg was created outside area */ then call delete_$ptr (np -> variable_node.vbl_ptr, "010100"b, me, code); else free np -> variable_node.vbl_ptr -> old_variable; np -> variable_node.vbl_ptr = null; sb -> stack_header.sys_link_info_ptr -> variable_table_header.total_allocated_size = sb -> stack_header.sys_link_info_ptr -> variable_table_header.total_allocated_size - vsize; return; end; /* of delete_it */ %page; /* Include Files */ %include system_link_names; %page; %include system_link_init_info; %page; %include object_info; %page; %include linkdcl; %page; %include stack_header; %page; %include lot; %page; %include its; %page; %include std_symbol_header; %page; %include object_lib_defs; end;  string.pl1 11/04/82 2003.4rew 11/04/82 1630.9 48816 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* string an active function which returns its input arguments, strung together */ /* in a quoted character string and separated by blanks. An arbitrary */ /* number of input arguments can be handled (0 to infinite). The only */ /* bound on their number of length is the maximum command line size. */ /* When invoked as a command, string has the effect of: */ /* ioa_ [string ...] */ /* */ /* U__s_a_g_e */ /* */ /* [string arg1_ ... arg_n] */ /* or string arg1_ ... arg_n */ /* */ /* 1) arg_i are optional input arguments which are returned as a single quoted */ /* string. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* TR7417, call iox_$put_chars only once for command invocation 10/31/80 S. Herbst */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ string: procedure; /* active function which returns its input args, */ /* separated by blanks, as a quoted string. */ dcl /* automatic variables */ Larg fixed bin (21), /* length of an input arg. */ Lmax fixed bin (21), /* max estimate for string to print */ Lret fixed bin (21), /* maximum length of our return value. */ Nargs fixed bin, /* number of arguments we were passed. */ Parg ptr, /* ptr to an input argument. */ Parg_list ptr, /* ptr to the argument list */ Pret ptr, /* ptr to our return value. */ code fixed bin (35), /* an error code value. */ i fixed bin; /* a do-group index. */ dcl /* based variables */ arg char(Larg) based (Parg), /* an input argument. */ ret char(Lret) varying based (Pret); /* overlay for portions of our return value. */ dcl (addr, addrel, length, search) builtin; dcl /* entries */ cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin(35)), (cu_$af_arg_ptr, cu_$arg_ptr) entry (fixed bin, ptr, fixed bin (21), fixed bin(35)), cu_$arg_list_ptr entry (ptr), cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr), iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin(35)); dcl /* static variables */ NL char(1) int static init (" "), SPACE char(1) int static init (" "), iox_$user_output ptr ext static; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ call cu_$af_return_arg (Nargs, Pret, Lret, code); /* see how we were called. */ if code = 0 then do; /* as an active function. */ if Nargs = 0 then do; /* no input args. Return a null string. */ ret = """"""; return; end; ret = """"; call cu_$af_arg_ptr (1, Parg, Larg, code); /* add first argument to return string. */ if search (arg, """") > 0 then ret = ret || double_quotes (arg); else ret = ret || arg; do i = 2 to Nargs; /* add remaining args to return string. */ ret = ret || " "; call cu_$af_arg_ptr (i, Parg, Larg, code); if search (arg, """") > 0 then ret = ret || double_quotes (arg); else ret = ret || arg; end; ret = ret || """"; end; else do; /* command merely output's its args, separated by */ Lmax = 1; /* allow for NL always */ do i = 1 to Nargs; call cu_$arg_ptr (i, Parg, Larg, code); Lmax = Lmax + Larg + 1; end; call cu_$arg_list_ptr (Parg_list); begin; dcl the_string char (Lmax) varying; dcl i fixed bin; the_string = ""; do i = 1 to Nargs; call cu_$arg_ptr_rel (i, Parg, Larg, code, Parg_list); if i ^= 1 then the_string = the_string || SPACE; the_string = the_string || arg; end; the_string = the_string || NL; call iox_$put_chars (iox_$user_output, addrel (addr (the_string), 1), length (the_string), code); end; end; double_quotes: procedure (string) returns (char(*) varying); /* internal procedure to double all quotes in */ /* a "to be quoted" string. */ dcl string char(*); dcl (i, j) fixed bin; dcl copied_string char(length(string)*2) varying; dcl string_begin char(i-1) based (addr(string_array(j))), string_end char(length(string)-(j-1)) based(addr(string_array(j))), string_array (length(string)) char(1) based (addr(string)); i = search(string,""""); if i = 0 then return(string); j = 1; copied_string = ""; do while (i > 0); copied_string = copied_string || string_begin; copied_string = copied_string || """"""; j = i+j; i = search (string_end, """"); end; copied_string = copied_string || string_end; return (copied_string); end double_quotes; end string;  system.pl1 06/09/89 1257.9rew 06/09/89 1255.3 119340 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-28,Vu), approve(89-04-28,MCR8100), audit(89-05-05,Lee), install(89-06-09,MR12.3-1057): use the process date_time format rather than the concatenation of the process date and time format for all keywords starting with date_time_**. END HISTORY COMMENTS */ system: proc; /* Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures.(UNCA) Changed to requote return string 03/19/80 S. Herbst Modified June 1981 by E. N. Kittlitz for UNCA rate structures Modified Sept 1982 by Linda Pugh to add date_time_XXX and default_absentee_queue keys. The following key words are obsolete and are no longer documented; however, they are retained for compatibility (time_up, next_down_time, down_until time, shift_change_time, date_up, next_down_date, last_down_time, last_down date, shift_change_date, down_until_date) Modified May 1983 by Art Beattie to add version_id key word. Modified 10/3/83 by C Spitzer to add all keyword, printed in sorted list make last_down_reason return ERFnn instead of just nn. Modified 06/19/84 by J A Falksen to utilize date_time_$format with keywords "date", "time", and "date_time". Modified 840619 for session_type keyword, and to make ERF DUMP... -E. A. Ranzenbach Modified 841113 to put back BIM's trusted_path_login keyword that was mistakenly backed out by the date_time_$format installation... */ dcl ap ptr, /* ptr to argument */ al fixed bin (21), /* lth of argument */ bchr char (al) based (ap) unal, /* argument */ answer char (al) varying based (ap); /* return argument */ dcl time fixed bin (71), nactsw bit (1), all_switch bit (1) aligned, stp_sw bit (36) aligned, switch fixed bin, host_num fixed binary (16), ec fixed bin (35), rs_number fixed bin, rs_name char (32), tli fixed bin (71), wd char (9) aligned, dn char (168), j fixed bin, (t1, t2) fixed bin, i35 fixed bin (35), string char (300) varying init (""); dcl max_rs_number fixed bin; dcl default_q fixed bin; dcl error entry options (variable) variable; dcl get_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35)) variable; dcl inarg char (32) aligned; dcl item (38) char (32) aligned int static options (constant) init ( "ARPANET_host_number", /* case 1 */ "company", /* case 2 */ "date_time_last_down", /* case 3 */ "date_time_last_up", /* case 4 */ "date_time_next_down", /* case 5 */ "date_time_next_up", /* case 6 */ "date_time_shift_change", /* case 7 */ "date_up", /* case 8 */ "default_absentee_queue", /* case 9 */ "department", /* case 10 */ "down_until_date", /* case 11 */ "down_until_time", /* case 12 */ "ds_company", /* case 13 */ "ds_department", /* case 14 */ "installation_id", /* case 15 */ "last_down_date", /* case 16 */ "last_down_reason", /* case 17 */ "last_down_time", /* case 18 */ "max_rate_structure_number", /* case 19 */ "max_units", /* case 20 */ "max_users", /* case 21 */ "n_units", /* case 22 */ "n_users", /* case 23 */ "next_down_date", /* case 24 */ "next_down_time", /* case 25 */ "next_shift", /* case 26 */ "rate_structure_name", /* case 27 */ "rate_structure_number", /* case 28 */ "reason_down", /* case 29 */ "shift", /* case 30 */ "shift_change_date", /* case 31 */ "shift_change_time", /* case 32 */ "sysid", /* case 33 */ "time_up", /* case 34 */ "version_id", /* case 35 */ "session_type", /* case 36 */ "trusted_path_login", /* case 37 */ "all"); /* MUST BE LAST */ dcl error_table_$badopt fixed bin (35) ext, error_table_$bad_arg fixed bin (35) ext, error_table_$not_act_fnc fixed bin (35) ext; dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)), cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)), cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35)), cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)), active_fnc_err_ entry options (variable), com_err_ entry options (variable), ioa_ entry options (variable), date_time_$format entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var), requote_string_ entry (char (*)) returns (char (*)), system_info_$installation_id entry (char (*)), system_info_$sysid entry (char (*)), system_info_$session entry (char (*)), system_info_$trusted_path_flags entry (bit(36) aligned), system_info_$version_id entry (char (*)), system_info_$titles entry options (variable), system_info_$users entry options (variable), system_info_$timeup entry (fixed bin (71)), system_info_$next_shutdown entry options (variable), system_info_$next_shift_change entry options (variable), system_info_$last_shutdown entry options (variable), system_info_$ARPANET_host_number entry (fixed bin (16)), system_info_$rs_number entry (char (*), fixed bin, fixed bin (35)), system_info_$rs_name entry (fixed bin, char (*), fixed bin (35)), system_info_$max_rs_number entry (fixed bin), system_info_$default_absentee_queue entry (fixed bin), ioa_$rsnnl entry options (variable); dcl (hbound, ltrim, rtrim) builtin; /* ======================================================= */ call cu_$af_arg_ptr (1, ap, al, ec); if ec = error_table_$not_act_fnc then do; error = com_err_; get_arg = cu_$arg_ptr; call get_arg (1, ap, al, ec); nactsw = "1"b; end; else do; error = active_fnc_err_; get_arg = cu_$af_arg_ptr; nactsw = "0"b; end; if ec ^= 0 then do; er: call error (ec, "system"); return; end; inarg = bchr; all_switch = "0"b; do switch = 1 to hbound (item, 1); if inarg = item (switch) then go to have_good_item; end; call error (error_table_$badopt, "system", """^a""", inarg); return; have_good_item: if switch = hbound (item, 1) then if nactsw then do; all_switch = "1"b; switch = 1; end; else do; call error (error_table_$bad_arg, "system", "^a", inarg); end; ok: go to case (switch); case (15): /* installation_id */ call system_info_$installation_id (dn); rtrim_string: string = rtrim (dn); go to exit; case (33): /* sysid */ call system_info_$sysid (dn); go to rtrim_string; case (37): /* trusted_path_login */ call system_info_$trusted_path_flags (stp_sw); if stp_sw then dn = "true"; else dn = "false"; go to rtrim_string; case (36): /* session_type */ call system_info_$session (dn); go to rtrim_string; case (2): /* company */ call system_info_$titles (dn, wd, wd, wd); go to rtrim_string; case (10): /* department */ call system_info_$titles (wd, dn, wd, wd); go to rtrim_string; case (13): /* ds_company */ call system_info_$titles (wd, wd, dn, wd); go to rtrim_string; case (14): /* ds_department */ call system_info_$titles (wd, wd, wd, dn); go to rtrim_string; case (21): /* max_users */ call system_info_$users (t1, t2, t2, t2); cv_num: call ioa_$rsnnl ("^d", string, j, t1); go to exit; case (23): /* n_users */ call system_info_$users (t2, t1, t2, t2); go to cv_num; case (20): /* max_units */ call system_info_$users (t2, t2, t1, t2); cv_float: call ioa_$rsnnl ("^.1f", string, j, t1*1e-1); go to exit; case (22): /* n_units */ call system_info_$users (t2, t2, t2, t1); go to cv_float; case (34): /* time_up */ call system_info_$timeup (tli); cv_time: string = date_time_$format ("time",tli,"",""); go to exit; case (25): /* next_down_time */ call system_info_$next_shutdown (tli); if tli = 0 then do; notime: string = "none"; go to exit; end; go to cv_time; case (12): /* down_until_time */ call system_info_$next_shutdown (time, dn, tli); if time = 0 then go to notime; if tli = 0 then go to notime; go to cv_time; case (29): /* reason_down */ call system_info_$next_shutdown (tli, dn); if tli = 0 then go to notime; go to rtrim_string; case (30): /* shift */ call system_info_$next_shift_change (t1, tli, t2); go to cv_num; case (32): /* shift_change_time */ call system_info_$next_shift_change (t1, tli, t2); go to cv_time; case (26): /* next_shift */ call system_info_$next_shift_change (t2, tli, t1); go to cv_num; case (8): /* date_up */ call system_info_$timeup (tli); cv_date: string = date_time_$format ("date",tli,"",""); go to exit; case (24): /* next_down_date */ call system_info_$next_shutdown (tli); if tli = 0 then go to notime; go to cv_date; case (11): /* down_until_date */ call system_info_$next_shutdown (time, dn, tli); if time = 0 then go to notime; if tli = 0 then go to notime; go to cv_date; case (31): /* shift_change_date */ call system_info_$next_shift_change (t1, tli, t2); go to cv_date; case (18): /* last_down_time */ call system_info_$last_shutdown (tli); go to cv_time; case (16): /* last_down_date */ call system_info_$last_shutdown (tli); go to cv_date; case (17): /* last_down_reason */ call system_info_$last_shutdown (tli, dn); go to rtrim_string; case (1): /* ARPANET_host_number */ call system_info_$ARPANET_host_number (host_num); t1 = host_num; go to cv_num; case (28): /* rate_structure_number */ string = ""; call get_arg (2, ap, al, ec); if ec ^= 0 then if all_switch then goto exit; else go to er; call system_info_$rs_number (bchr, rs_number, ec); if ec ^= 0 then do; call error (ec, "system", "Rate structure name ""^a"".", bchr); if all_switch then goto exit; else return; end; t1 = rs_number; go to cv_num; case (27): /* rate_structure_name */ call system_info_$max_rs_number (max_rs_number); string = ""; call get_arg (2, ap, al, ec); if ec = 0 then do; i35 = cv_dec_check_ (bchr, ec); if ec ^= 0 then do; rs_nm_error: ec = error_table_$bad_arg; call error (ec, "system", "Rate structure number ^a.", bchr); if all_switch then goto exit; else return; end; if i35 < 0 | i35 > max_rs_number then go to rs_nm_error; /* outside capbility of rs_number? */ rs_number = i35; call system_info_$rs_name (rs_number, rs_name, ec); if ec ^= 0 then goto rs_nm_error; string = rtrim (ltrim (rs_name)); end; else do rs_number = 0 to max_rs_number; call system_info_$rs_name (rs_number, rs_name, ec); if ec ^= 0 then go to exit; if string ^= "" then string = string || " "; string = string || rtrim (rs_name); end; go to exit; case (19): /* max_rate_structure_number */ call system_info_$max_rs_number (rs_number); t1 = rs_number; go to cv_num; case (4): /* date_time_last_up */ call system_info_$timeup (tli); cv_date_time: /**** vp: phx19051; use the process date_time format rather than the concatenation of the process date and time for all keywords starting with date_time_** ****/ string = date_time_$format ("date_time",tli,"",""); go to exit; case (5): /* date_time_next_down */ call system_info_$next_shutdown (tli); if tli = 0 then go to notime; go to cv_date_time; case (6): /* date_time_next_up */ call system_info_$next_shutdown (time, dn, tli); if time = 0 then go to notime; if tli = 0 then go to notime; go to cv_date_time; case (3): /* date_time_last_down */ call system_info_$last_shutdown (tli); go to cv_date_time; case (7): /* date_time_shift_change */ call system_info_$next_shift_change (t1, tli, t2); go to cv_date_time; case (9): /* default_absentee_queue */ call system_info_$default_absentee_queue (default_q); t1 = default_q; go to cv_num; case (35): /* version_id */ call system_info_$version_id (dn); go to rtrim_string; exit: if all_switch then do; if string ^= "" then call ioa_ ("^a:^28t^a", item (switch), string); switch = switch + 1; if switch = hbound (item, 1) then return; else goto ok; end; else if nactsw then do; call ioa_ ("^a", string); return; end; call cu_$af_return_arg (j, ap, al, ec); if ec ^= 0 then go to er; answer = requote_string_ ((string)); end;  user.pl1 07/13/88 1113.9rew 07/13/88 0905.4 195984 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ user: procedure options (variable); /* USER - active function to return user parameters */ /****^ HISTORY COMMENTS: 1) change(86-03-01,Gilcrease), approve(86-03-27,MCR7370), audit(86-06-23,Lippard), install(86-06-30,MR12.0-1082): First comment for hcom. Modified April 1979 by T. Casey for MR7.0a to return "foreground" from [user abs_queue] in foreground job initial_term_(id type) added and term_(id type) changed to return current info. 09/12/79 S. Herbst Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures. (UNCA). Modified June 1981 by E. N. Kittlitz for UNCA rate structures Modified Augues 30 1981 by William M. York to add accounting keywords (limit, monthly_limit, cutoff_date, shift_limit, spending, monthly_spending, shift_spending, and limit_type), to clean up the code, and add comments to each action Modified October 1982 by E. N. Kittlitz for request_id Added 256K (256k) keyword 07/14/83 S. Herbst Added all keyword, printed in sorted list 10/3/83 C Spitzer Modified 1984-07-28 BIM to implement all in maintainable way, add auth_range, min_auth. Modified 1984-09-13 by JAFalksen, to utilize date_time_$format("date"|"time"|"date_time" Modified 1984-12-05 BIM: fixed dcl of user_info_$attributes Modified 1984-12-05 C Spitzer. fix subscriptrange errors 2) change(86-03-27,Gilcrease), approve(86-03-27,MCR7370), audit(86-06-23,Lippard), install(86-06-30,MR12.0-1082): Add the keywords absout_truncation, absentee_restarted for -truncate absout, SCP6297. 3) change(87-11-30,Parisek), approve(88-02-11,MCR7849), audit(88-03-07,Lippard), install(88-07-13,MR12.2-1047): Added the min_ring, max_ring, & ring_range keywords. SCP6367 END HISTORY COMMENTS */ dcl alp pointer; dcl ap ptr, /* ptr to argument */ al fixed bin (21), /* lth of argument */ all_switch bit (1) aligned, bchr char (al) based (ap) unal, /* argument */ answer char (al) varying based (ap); /* return argument */ dcl time fixed bin (71), nactsw bit (1), (got_login_data, got_auth, got_limits) bit (1) aligned, term_id_sw bit (1), K256_switch bit (2) aligned, switch fixed bin, ec fixed bin (35), attr char (300) varying, (nm, pj, ac, grp) char (32), f float bin, (an, sb, wt) fixed bin, (tli, ocpu) fixed bin (71), wd char (9), dn char (168), id char (8), (np, pf, pp) fixed bin, tt char (32), (i, n) fixed bin, b36 bit (36), (auth, max_auth) bit (72) aligned, auth_range (2) bit (72) aligned, rs_number fixed bin, string char (300) varying, auth_string char (644), (absolute_limit, absolute_spending, monthly_limit, monthly_spending) float bin, (shift_limits, shift_spendings) dimension (0:7) float bin, cutoff_date fixed bin (71), limit_type fixed bin, current_shift fixed bin, fb71 fixed bin (71), char19 char (19), (truncate, restarted) bit (1), rg_range (2) fixed bin, ring_string char (3); dcl process_type (0:3) char (12) static options (constant) init ("initializer", "interactive", "absentee", "daemon"); dcl service_type (0:7) char (8) static options (constant) init ("unknown", "login", "FTP", "MC", "slave", "type5", "autocall", "inactive"); %include line_types; %include iocbx; dcl 1 terminal_info aligned, 2 version fixed bin init (1), 2 id char (4) unaligned, 2 term_type char (32) unaligned, 2 line_type fixed bin, 2 baud_rate fixed bin, 2 reserved (4) fixed bin; dcl inarg char (24); /* The following 3 arrays MUST all be dimensioned at the same size. ITEM_ALPHA_ORDER indicates what order each data item is printed in when we find the "all" keyword (use a 0 for a place holder if it is not to be printed for "all"). item is the array of implemented keywords in no special order. New ones may be added on the end of the list. user_data indicates which of the 3 types of user_info_ data must be retrieved to implement the keyword. If none of them are correct, use a 0 as a place holder. */ dcl ITEM_ALPHA_ORDER (58) fixed bin int static options (constant) init (1, 2, 3, 4, 54, 5, 6, 7, 55, 8, 9, 0, 11, 12, 0, 53, 56, 57, 58, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 0, 28, 29, 0, 51, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49); dcl item (58) char (24) aligned int static options (constant) init ( "256k_switch", /* case 1 */ "abs_queue", /* case 2 */ "absentee", /* case 3 */ "absentee_request_id", /* case 4 */ "absin", /* case 5 */ "absout", /* case 6 */ "account", /* case 7 */ "anonymous", /* case 8 */ "attributes", /* case 9 */ "auth", /* case 10 */ "auth_long", /* case 11 */ "brief_bit", /* case 12 */ "charge_type", /* case 13 */ "cpu_secs", /* case 14 */ "cutoff_date", /* case 15 */ "device_channel", /* case 16 */ "group", /* case 17 */ "initial_term_id", /* case 18 */ "initial_term_type", /* case 19 */ "limit", /* case 20 */ "limit_type", /* case 21 */ "line_type", /* case 22 */ "log_time", /* case 23 */ "login_date", /* case 24 */ "login_time", /* case 25 */ "login_word", /* case 26 */ "max_auth", /* case 27 */ "max_auth_long", /* case 28 */ "monthly_limit", /* case 29 */ "monthly_spending", /* case 30 */ "n_processes", /* case 31 */ "name", /* case 32 */ "outer_module", /* case 33 */ "preemption_time", /* case 34 */ "process_id", /* case 35 */ "process_overseer", /* case 36 */ "process_type", /* case 37 */ "project", /* case 38 */ "protected", /* case 39 */ "rate_structure_name", /* case 40 */ "rate_structure_number", /* case 41 */ "secondary", /* case 42 */ "service_type", /* case 43 */ "shift_limit", /* case 44 */ "shift_spending", /* case 45 */ "spending", /* case 46 */ "term_id", /* case 47 */ "term_type", /* case 48 */ "weight", /* case 49 */ "min_auth", /* case 50 */ "min_auth_long", /* case 51 */ "auth_range", /* case 52 */ "auth_range_long", /* case 53 */ "absentee_restarted", /* case 54 */ "absout_truncation", /* case 55 */ "min_ring", /* case 56 */ "max_ring", /* case 57 */ "ring_range"); /* case 58 */ dcl user_data (58) fixed bin int static options (constant) init ((6) 0, 1, 1, 0, 2, 2, 0, 0, 0, 3, (4) 0, 3, 3, 0, (4) 1, 2, 2, 3, 3, 0, 1, (5) 0, 1, 0, 0, 0, 1, 0, 0, 3, 3, 0, 0, 1, (4) 0, 0, 0, 0, 0, 0); dcl item_synonyms (3) char (24) int static options (constant) init ("abs_rqid", "256k", "256K"); dcl item_synonyms_position (3) fixed bin int static options (constant) init (4, 1, 1); dcl error_table_$not_act_fnc fixed bin (35) ext; dcl error_table_$badopt fixed bin(35) ext static; dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl get_process_id_ entry () returns (bit (36)); dcl cu_$af_return_arg_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr); dcl active_fnc_err_ entry options (variable); dcl com_err_ entry options (variable); dcl ioa_ entry options (variable); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$user_io ptr external; dcl date_time_$format entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var); dcl requote_string_ entry (char (*)) returns (char (*)); dcl user_info_$authorization_range entry ((2) bit (72) aligned); dcl user_info_$login_data entry options (variable); dcl user_info_$absin entry (char (*)); dcl user_info_$absout entry (char (*)); dcl (user_info_$absout_truncation, user_info_$absentee_restarted) entry (bit(1)); dcl user_info_$outer_module entry (char (*)); dcl user_info_$attributes entry (char (*) varying); dcl user_info_$service_type entry (fixed bin); dcl user_info_$process_type entry (fixed bin); dcl user_info_$terminal_data entry options (variable); dcl user_info_$responder entry (char (*)); dcl user_info_$usage_data entry options (variable); dcl user_info_$load_ctl_info entry options (variable); dcl user_info_$absentee_queue entry (fixed bin); dcl user_info_$rs_name entry (char (*)); dcl user_info_$rs_number entry (fixed bin); dcl user_info_$limits entry (float bin, float bin, fixed bin (71), fixed bin, (0:7) float bin, float bin, float bin, (0:7) float bin); dcl user_info_$absentee_request_id entry (fixed bin (71)); dcl user_info_$ring_range entry ((2) fixed bin); dcl system_info_$next_shift_change entry (fixed bin, fixed bin (71), fixed bin, fixed bin (71)); dcl hcs_$get_usage_values entry (fixed bin, fixed bin (71), fixed bin); dcl hcs_$get_authorization entry (bit (72) aligned, bit (72) aligned); dcl hcs_$set_256K_switch entry (bit (2) aligned, bit (2) aligned, fixed bin (35)); dcl convert_access_class_$to_string entry (bit (72) aligned, char (*), fixed bin (35)); dcl convert_access_class_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35)); dcl convert_access_class_$to_string_range entry ((2) bit (72) aligned, character (*), fixed binary (35)); dcl convert_access_class_$to_string_range_short entry ((2) bit (72) aligned, character (*), fixed binary (35)); dcl request_id_ entry (fixed bin (71)) returns (char (19)); dcl ioa_$rsnnl entry options (variable); dcl (addr, clock, hbound, index, ltrim, rtrim) builtin; /* ======================================================= */ all_switch, nactsw, got_limits, got_auth, got_login_data = "0"b; call cu_$arg_list_ptr (alp); call cu_$af_arg_ptr (1, ap, al, ec); if ec = error_table_$not_act_fnc then do; call cu_$arg_ptr (1, ap, al, ec); nactsw = "1"b; end; if ec ^= 0 then do; er: if nactsw then call com_err_ (ec, "user", ""); else call active_fnc_err_ (ec, "user", ""); return; end; inarg = bchr; if inarg = "all" then all_switch = "1"b; else do; do switch = 1 to hbound (item, 1); if inarg = item (switch) then go to have_good_item; end; do switch = 1 to hbound (item_synonyms, 1); if inarg = item_synonyms (switch) then do; switch = item_synonyms_position (switch); goto have_good_item; end; end; if nactsw then call com_err_ (0, "user", "Invalid keyword: ^a", inarg); else call active_fnc_err_ (0, "user", "Invalid keyword: ^a", inarg); return; end; have_good_item: if all_switch & ^nactsw then do; call active_fnc_err_ (error_table_$badopt, "user", "The ""all"" keyword is invalid in an active function invocation."); return; end; if all_switch then do i = 1 to 3; call get_user_data (i); end; else call get_user_data (user_data (switch)); if all_switch then do i = 1 to hbound (ITEM_ALPHA_ORDER, 1); if ITEM_ALPHA_ORDER (i) ^= 0 then call process_one_item (ITEM_ALPHA_ORDER (i)); end; else call process_one_item (switch); return; get_user_data: proc (type); dcl type fixed bin; if type = 1 then call user_info_$login_data (nm, pj, ac, an, sb, wt, tli, wd); else if type = 2 then call hcs_$get_authorization (auth, max_auth); else if type = 3 then call user_info_$limits (monthly_limit, absolute_limit, cutoff_date, limit_type, shift_limits, monthly_spending, absolute_spending, shift_spendings); return; end get_user_data; process_one_item: procedure (switch) options (non_quick); declare switch fixed bin; declare i fixed bin; go to case (switch); case (32): /* name */ dn = nm; go to j1; case (38): /* project */ dn = pj; go to j1; case (7): /* account */ dn = ac; go to j1; case (25): /* login_time */ j3: string = date_time_$format ("time", tli, "", ""); go to exit; case (24): /* login_date */ string = date_time_$format ("date", tli, "", ""); go to exit; case (8): /* anonymous */ if an = 1 then string = "true"; else string = "false"; go to exit; case (42): /* secondary */ if sb = 1 then string = "true"; else string = "false"; go to exit; case (49): /* weight */ f = wt / 1e1; go to j2; case (26): /* login_word */ dn = wd; go to j1; case (23): /* log_time */ time = clock () - tli; f = time / 60e6; go to j2; case (36): /* process_overseer */ call user_info_$responder (dn); go to j1; case (18): /* initial_term_id */ iterm_id: call user_info_$terminal_data (id, tt); dn = id; go to j1; case (19): /* initial_term_type */ call user_info_$absentee_queue (n); if n ^= -1 then do; string = "Absentee"; go to exit; end; iterm_type: call user_info_$terminal_data (id, tt); string = rtrim (tt); go to exit; case (14): /* cpu_secs */ call user_info_$usage_data (np, ocpu); call hcs_$get_usage_values (pf, time, pp); time = time + ocpu; f = time / 1e6; j2: call ioa_$rsnnl ("^.1f", string, i, f); go to exit; case (16): /* device_channel */ call user_info_$terminal_data (id, tt, dn); /* get channel name */ j1: string = rtrim (dn); go to exit; case (31): /* n_processes */ call user_info_$usage_data (np, ocpu); call ioa_$rsnnl ("^d", string, i, np); go to exit; case (3): /* absentee */ call user_info_$absentee_queue (n); if n = -1 then string = "false"; else string = "true"; go to exit; case (2): /* abs_queue */ call user_info_$absentee_queue (n); if n = -1 then string = "interactive"; else if n = 0 then string = "foreground"; else call ioa_$rsnnl ("^d", string, i, n); go to exit; case (39): /* protected */ call user_info_$load_ctl_info (grp, sb, tli); string = "false"; if sb = 0 then if tli > clock () then string = "true"; go to exit; case (12): /* brief_bit */ call user_info_$attributes (attr); if index (attr, "brief") = 0 then string = "false"; else string = "true"; go to exit; case (17): /* group */ call user_info_$load_ctl_info (grp); dn = grp; go to j1; case (34): /* preemption_time */ call user_info_$load_ctl_info (grp, sb, tli); go to j3; case (9): /* attributes */ call user_info_$attributes (string); go to exit; case (5): /* absin */ call user_info_$absin (dn); go to j1; case (6): /* absout */ call user_info_$absout (dn); go to j1; case (33): /* outer_module */ call user_info_$outer_module (dn); go to j1; case (35): /* process_id */ b36 = get_process_id_ (); call ioa_$rsnnl ("^w", string, i, b36); go to exit; case (10): /* auth */ call convert_access_class_$to_string_short (auth, auth_string, ec); if ec ^= 0 then go to er; if auth_string = "" then string = "system_low"; else string = rtrim (auth_string); go to exit; case (11): /* auth_long */ call convert_access_class_$to_string (auth, auth_string, ec); if ec ^= 0 then go to er; if auth_string = "" then string = "system_low"; else string = rtrim (auth_string); go to exit; case (27): /* max_auth */ call convert_access_class_$to_string_short (max_auth, auth_string, ec); if ec ^= 0 then go to er; if auth_string = "" then string = "system_low"; else string = rtrim (auth_string); go to exit; case (28): /* max_auth_long */ call convert_access_class_$to_string (max_auth, auth_string, ec); if ec ^= 0 then go to er; if auth_string = "" then string = "system_low"; else string = rtrim (auth_string); go to exit; case (50): /* min_auth */ call user_info_$authorization_range (auth_range); call convert_access_class_$to_string_short (auth_range (1), auth_string, ec); if ec ^= 0 then go to er; if auth_string = "" then auth_string = "system_low"; string = rtrim (auth_string); go to exit; case (51): /* min_auth */ call user_info_$authorization_range (auth_range); call convert_access_class_$to_string (auth_range (1), auth_string, ec); if ec ^= 0 then go to er; if auth_string = "" then auth_string = "system_low"; string = rtrim (auth_string); go to exit; case (52): /* auth_range */ call user_info_$authorization_range (auth_range); call convert_access_class_$to_string_range_short (auth_range, auth_string, ec); if ec ^= 0 then go to er; if auth_string = "" then auth_string = "system_low"; string = rtrim (auth_string); go to exit; case (53): /* auth_range_long */ call user_info_$authorization_range (auth_range); call convert_access_class_$to_string_range (auth_range, auth_string, ec); if ec ^= 0 then go to er; if auth_string = "" then auth_string = "system_low"; string = rtrim (auth_string); go to exit; case (22): /* line_type */ call user_info_$terminal_data ((""), (0), (""), i); dn = line_types (i); goto j1; case (43): /* service_type */ call user_info_$service_type (i); dn = service_type (i); goto j1; case (37): /* process_type */ call user_info_$process_type (i); dn = process_type (i); goto j1; case (13): /* charge_type */ call user_info_$terminal_data ((""), (""), (""), (0), dn); go to j1; case (47): /* term_id */ term_id_sw = "1"b; get_term: call user_info_$process_type (i); if i > 1 then /* absentee or daemon process */ if term_id_sw then go to iterm_id; else if i = 2 then do; string = "Absentee"; go to exit; end; else go to iterm_type; /* Interactive or initializer process */ call iox_$control (iox_$user_io, "terminal_info", addr (terminal_info), ec); if ec ^= 0 then do; if term_id_sw then go to iterm_id; else go to iterm_type; end; if term_id_sw then string = rtrim (terminal_info.id); else string = rtrim (terminal_info.term_type); go to exit; case (48): /* term_type */ term_id_sw = "0"b; go to get_term; case (40): /* rate_structure_name */ call user_info_$rs_name (nm); string = nm; go to exit; case (41): /* rate_structure_number */ call user_info_$rs_number (rs_number); call ioa_$rsnnl ("^d", string, i, rs_number); go to exit; case (20): /* limit */ call ioa_$rsnnl ("^.2f", string, i, absolute_limit); goto exit; case (15): /* cutoff_date */ string = date_time_$format ("date_time", cutoff_date, "", ""); goto exit; case (29): /* monthly_limit */ call ioa_$rsnnl ("^.2f", string, i, monthly_limit); goto exit; case (44): /* shift_limit */ call system_info_$next_shift_change (current_shift, (0), (0), (0)); call ioa_$rsnnl ("^.2f", string, i, shift_limits (current_shift)); goto exit; case (46): /* spending */ call ioa_$rsnnl ("^.2f", string, i, absolute_spending); goto exit; case (30): /* monthly_spending */ call ioa_$rsnnl ("^.2f", string, i, monthly_spending); goto exit; case (45): /* shift_spending */ call system_info_$next_shift_change (current_shift, (0), (0), (0)); call ioa_$rsnnl ("^.2f", string, i, shift_spendings (current_shift)); goto exit; case (21): /* limit_type */ if limit_type = 0 then string = "absolute"; else if limit_type = 1 then string = "day"; else if limit_type = 2 then string = "month"; else if limit_type = 3 then string = "year"; else if limit_type = 4 then string = "calendar_year"; else if limit_type = 5 then string = "fiscal_year"; goto exit; case (4): /* absentee_request_id */ /* abs_rqid */ call user_info_$absentee_request_id (fb71); if fb71 ^= 0 then do; char19 = request_id_ (fb71); string = char19; end; else string = "0"; go to exit; case (1): /* 256k_switch (allow 256K segments) */ /* 256k */ /* 256K */ call hcs_$set_256K_switch ("00"b, K256_switch, (0)); if K256_switch = "11"b then string = "true"; else string = "false"; go to exit; case (54): /* absentee_restarted */ call user_info_$absentee_restarted (restarted); if restarted then string = "true"; else string = "false"; go to exit; case (55): /* absout_truncation */ call user_info_$absout_truncation (truncate); if truncate then string = "true"; else string = "false"; case (56): /* min_ring */ call user_info_$ring_range (rg_range); call ioa_$rsnnl ("^d", ring_string, (0), rg_range (1)); string = rtrim(ring_string); go to exit; case (57): /* max ring */ call user_info_$ring_range (rg_range); call ioa_$rsnnl ("^d", ring_string, (0), rg_range (2)); string = rtrim(ring_string); go to exit; case (58): /* ring range (lowest and highest) */ call user_info_$ring_range (rg_range); call ioa_$rsnnl ("^d:^d", ring_string, (0), rg_range (1), rg_range (2)); string = rtrim(ring_string); go to exit; /* End of moby CASE statement */ /* Common return point for many actions */ exit: if all_switch then do; if string ^= "" then call ioa_ ("^a:^24t^a", item (switch), ltrim (string)); end; else if nactsw then call ioa_ ("^a", string); else do; call cu_$af_return_arg_rel (i, ap, al, (0), alp); answer = requote_string_ ((string)); end; return; end process_one_item; end user; 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