answer.pl1 04/16/84 1436.8r 04/16/84 1435.6 184752 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Provides a canned answer when any question is asked during the execution of a command or request line */ /* Created: by THVV after R. Lamson */ /* Rewritten: 20 March 1978 by G. Palter */ /* Partially rewriten: 2 June 1978 by S.Herbst */ /* Modified: July 1978 by J. C. Whitmore to use new command_query_info structure */ /* Modified: 3 October 1979 by S. Herbst to fix usage message */ /* Modified: 18 February 1980 by S. Herbst to add -call */ /* Modified: 5 June 1981 by S. Herbst to add -match/-exclude and a warning for non-yes/no answer */ /* Modified: 16 February 1982 by G. Palter to add ssu_answer_request_ and convert to a standalone invocation */ /* Modified: 8 September 1982 by G. Palter to propogate subsystem/request line aborts */ /* Modified: 27 March 1984 by S. Herbst to fix "Ignoring response FOO" message with -call */ /* format: style4,delnl,insnl,ifthenstmt,ifthen */ answer: procedure () options (variable); dcl P_sci_ptr pointer parameter; /* ssu_answer_request_: -> SCI of the subsystem */ dcl P_info_ptr pointer parameter; /* ssu_answer_request_: -> subsystem's internal data */ dcl sci_ptr pointer; dcl 1 answer_node aligned based (answer_node_ptr), /* holds one answer */ 2 query_sw bit (1), 2 call_sw bit (1), 2 call_ptr pointer, 2 call_len fixed binary (21), 2 times fixed binary, 2 next_ptr pointer, 2 answer_len fixed binary (21), 2 answer character (arg_len refer (answer_node.answer_len)); dcl answer_node_ptr pointer; dcl 1 match_node aligned based (match_node_ptr), 2 exclude_sw bit (1), 2 regexp_sw bit (1), 2 next_ptr pointer, 2 match_len fixed binary (21), 2 match_str character (arg_len refer (match_node.match_len)) unaligned; dcl match_node_ptr pointer; %include cp_active_string_types; dcl arg character (arg_len) based (arg_ptr) unaligned; dcl based_answer character (answer_max_len) based; dcl (arg_ptr, first_match_ptr, first_node_ptr, next_node_ptr, old_node_ptr, temp_ptr) pointer; dcl area area based (area_ptr); dcl area_ptr pointer; dcl (standalone_invocation, brief_sw, call_opt_sw, found_first_answer, is_yes_or_no, yes_no) bit (1) aligned; dcl (arg_count, arg_index, n) fixed binary; dcl (answer_max_len, arg_len) fixed binary (21); dcl code fixed binary (35); dcl error_table_$bad_conversion fixed binary (35) external; dcl error_table_$badopt fixed binary (35) external; dcl ssu_et_$null_request_line fixed binary (35) external; dcl ssu_et_$subsystem_aborted fixed binary (35) external; dcl iox_$user_io pointer external; dcl iox_$user_output pointer external; dcl request_sw bit (1) aligned; dcl request_line character (request_len) aligned based (request_ptr); dcl request_ptr pointer; dcl (request_len, request_start, start) fixed binary (21); dcl com_err_ entry () options (variable); dcl command_query_ entry () options (variable); dcl condition_ entry (character (*), entry); dcl cu_$arg_list_ptr entry () returns (pointer); dcl cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35)); dcl get_system_free_area_ entry () returns (pointer); dcl search_file_ entry (pointer, fixed binary (21), fixed binary (21), pointer, fixed binary (21), fixed binary (21), fixed binary (21), fixed binary (21), fixed binary (35)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$abort_subsystem entry () options (variable); dcl ssu_$arg_count entry (pointer, fixed binary); 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_$evaluate_active_string entry (pointer, pointer, character (*), fixed binary, character (*) varying, 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_$get_temp_segment entry (pointer, character (*), pointer); dcl ssu_$print_message entry () options (variable); dcl ssu_$release_temp_segment entry (pointer, pointer); dcl ssu_$standalone_invocation entry (pointer, character (*), character (*), pointer, entry, fixed binary (35)); dcl (addr, binary, index, min, null, substr) builtin; dcl (cleanup, command_question) condition; %page; %include query_info_; %page; %include condition_info_header; %include command_question_info; %page; /* Multics answer command */ /* answer: entry () options (variable); */ standalone_invocation = "1"b; /* must create a standalone subsystem to do this */ call ssu_$standalone_invocation (sci_ptr, "answer", "1.0", cu_$arg_list_ptr (), abort_answer_command, code); if code ^= 0 then do; call com_err_ (code, "answer", "Can not establish standalone subsystem invocation."); return; end; go to COMMON; /* Standard subsystem answer request */ ssu_answer_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: area_ptr = get_system_free_area_ (); answer_node_ptr, match_node_ptr, request_ptr, first_match_ptr, first_node_ptr, temp_ptr = null (); on condition (cleanup) call clean_up (); call ssu_$arg_count (sci_ptr, arg_count); if arg_count = 0 then /* abort_line never returns */ USAGE: call ssu_$abort_line (sci_ptr, 0, "Usage: ^a string {-control_args} ^[command^;request^] line", ssu_$get_request_name (sci_ptr), standalone_invocation); call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_len); call add_answer_node (); first_node_ptr = answer_node_ptr; brief_sw, call_opt_sw = "0"b; found_first_answer = ""b; /* this will be set when first answer is found */ request_sw = "0"b; request_start = 0; request_len = 0; do arg_index = 1 to arg_count; call ssu_$arg_ptr (sci_ptr, arg_index, arg_ptr, arg_len); if ^request_sw then /* haven't begun imbedded request line yet */ if substr (arg, 1, 1) = "-" then if arg = "-brief" | arg = "-bf" then brief_sw = "1"b; /* don't print question & answer */ else if arg = "-times" then do; if ^found_first_answer then /* this is only defined after some answer */ no_first: call ssu_$abort_line (sci_ptr, 0, "First answer missing before ""^a"".", arg); arg_index = arg_index + 1; if arg_index > arg_count then NO_CONTROL_VALUE: call ssu_$abort_line (sci_ptr, 0, "No value specified for ""^a"".", arg); call ssu_$arg_ptr (sci_ptr, arg_index, arg_ptr, arg_len); n = cv_dec_check_ (arg, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, error_table_$bad_conversion, "-times ""^a""", arg); answer_node.times = n; end; else if arg = "-call" then do; /* expand active function to get answer */ call_opt_sw = "1"b; arg_index = arg_index + 1; if arg_index > arg_count then go to NO_CONTROL_VALUE; call ssu_$arg_ptr (sci_ptr, arg_index, arg_ptr, arg_len); if found_first_answer then call add_answer_node (); else found_first_answer = "1"b; answer_node.call_sw = "1"b; answer_node.call_ptr = arg_ptr; answer_node.call_len = arg_len; end; else if arg = "-exclude" | arg = "-ex" then do; arg_index = arg_index + 1; if arg_index > arg_count then go to NO_CONTROL_VALUE; call ssu_$arg_ptr (sci_ptr, arg_index, arg_ptr, arg_len); call add_match_node (); match_node.exclude_sw = "1"b; MATCH_ARG: if substr (arg, 1, 1) = "/" & substr (arg, arg_len, 1) = "/" then do; match_node.regexp_sw = "1"b; match_node.match_len = arg_len - 2; match_node.match_str = substr (arg, 2, arg_len - 2); end; else do; /* starname */ match_node.regexp_sw = "0"b; match_node.match_str = arg; end; end; else if arg = "-match" then do; arg_index = arg_index + 1; if arg_index > arg_count then go to NO_CONTROL_VALUE; call ssu_$arg_ptr (sci_ptr, arg_index, arg_ptr, arg_len); call add_match_node (); match_node.exclude_sw = "0"b; go to MATCH_ARG; end; else if arg = "-query" then do; if found_first_answer then /* node is there for first answer */ call add_answer_node (); answer_node.query_sw = "1"b; found_first_answer = "1"b; /* we have an answer now */ end; else if arg = "-then" then do; if ^found_first_answer then go to no_first; arg_index = arg_index + 1; if arg_index > arg_count then go to NO_CONTROL_VALUE; call ssu_$arg_ptr (sci_ptr, arg_index, arg_ptr, arg_len); call add_answer_node (); answer_node.answer = arg; end; else call ssu_$abort_line (sci_ptr, error_table_$badopt, """^a""", arg); else do; if ^found_first_answer then do; /* this must be the first answer */ answer_node.answer = arg; found_first_answer = "1"b; /* say we got it */ end; else do; /* otherwise this is the start of request line */ request_sw = "1"b; /* begin request line */ request_start = arg_index; /* remember where it started */ request_len = arg_len + 1; /* start computing length */ end; end; else request_len = request_len + arg_len + 1; end; if request_len = 0 then go to USAGE; answer_node_ptr = first_node_ptr; if call_opt_sw then call ssu_$get_temp_segment (sci_ptr, "answer", temp_ptr); call condition_ ("command_question", answer_handler); /* setup handler */ allocate request_line in (area) set (request_ptr); request_line = ""; start = 1; /* build request line */ do arg_index = request_start to arg_count; call ssu_$arg_ptr (sci_ptr, arg_index, arg_ptr, arg_len); substr (request_line, start, arg_len) = arg; start = start + arg_len + 1; end; call ssu_$execute_line (sci_ptr, addr (request_line), start - 2, code); /* execute request line */ if ^standalone_invocation & (code ^= 0) & (code ^= ssu_et_$null_request_line) then if code = ssu_et_$subsystem_aborted then call ssu_$abort_subsystem (sci_ptr); else call ssu_$abort_line (sci_ptr); RETURN: call clean_up (); return; /* Internal procedure invoked by ssu_$abort_line if answer was invoked as a Multics command (stanalone invocation) */ abort_answer_command: procedure (); go to RETURN; /* message has been printed: now we can punt */ end abort_answer_command; %page; /* This internal procedure supplies the answer when command_question is signalled. */ answer_handler: procedure (mcptr, name, coptr, infoptr, continue_sw); dcl (mcptr, coptr, infoptr) pointer parameter; dcl name character (*) parameter; dcl continue_sw bit (1) aligned parameter; %include query_info; dcl 1 as aligned based (inp), /* version 2 answer structure */ 2 version fixed binary, /* ... always 2 */ 2 status_code fixed binary (35), /* errorcode */ 2 query_code fixed binary, 2 question_sw bit (1) unaligned, /* 1 to print question */ 2 yes_or_no_sw bit (1) unaligned, /* 1 if must be yes/no */ 2 preset_sw bit (1) unaligned, /* 1 if we answered */ 2 answer_sw bit (1) unaligned, /* 1 if print answer */ 2 np pointer, /* ptr to asker name */ 2 nl fixed binary, /* len */ 2 question_ptr pointer, /* ptr to question */ 2 question_len fixed binary (21), /* len */ 2 max_question_len fixed binary (21), 2 answer_ptr pointer, /* ptr to answer */ 2 answer_len fixed binary (21), 2 max_answer_len fixed binary (21); declare 1 cqi aligned based (inp) like command_question_info; /* version 3 or 4 answer structure */ dcl inp pointer; dcl temp_answer character (4 * sys_info$max_seg_size - 4) varying based (temp_ptr); dcl sys_info$max_seg_size fixed binary (35) external; dcl question_string character (question_len) based (question_ptr); dcl buffer character (buffer_len) based (buffer_ptr); dcl (buffer_ptr, question_ptr) pointer; dcl buffer_len fixed binary (21); dcl question_len fixed binary (21); dcl length builtin; inp = infoptr; if as.version = 2 then do; question_ptr = as.question_ptr; question_len = as.question_len; end; else do; question_ptr = cqi.question_ptr; question_len = cqi.question_lth; end; if first_match_ptr ^= null () then do; /* some -match or -exclude args specified */ call process_selections (continue_sw, question_ptr, question_len); if continue_sw then return; /* don't answer this question */ end; if answer_node_ptr = null () /* have run out of answers */ | (as.version ^= 2 & cqi.version < 3) /* unsupported answer structure */ then do; continue_sw = "1"b; return; end; if answer_node.call_sw then do; /* answer -call ACTIVE_STRING */ buffer_ptr = answer_node.call_ptr; buffer_len = answer_node.call_len; on command_question system; call ssu_$evaluate_active_string (sci_ptr, null (), buffer, NORMAL_ACTIVE_STRING, temp_answer, code); if code ^= 0 then do; call ssu_$print_message (sci_ptr, code, "[^a]", buffer); query_info.suppress_name_sw = "1"b; if as.version = 2 then query_info.yes_or_no_sw = as.yes_or_no_sw; else query_info.yes_or_no_sw = cqi.yes_or_no_sw; call command_query_ (addr (query_info), temp_answer, ssu_$get_subsystem_and_request_name (sci_ptr), "Please type answer to the following question:^/^a", question_string); end; revert command_question; if as.version = 2 then yes_no = as.yes_or_no_sw; else yes_no = cqi.yes_or_no_sw; if temp_answer = "true" then temp_answer = "yes"; else if temp_answer = "false" then temp_answer = "no"; if temp_answer = "yes" | temp_answer = "y" | temp_answer = "no" | temp_answer = "n" then is_yes_or_no = "1"b; else is_yes_or_no = "0"b; answer_node.answer_len = length (temp_answer); go to SET_ANSWER; end; else if answer_node.query_sw then do; /* -query */ if cqi.version >= 4 then do; /* iocbp's are defined in version 4 */ cqi.question_iocbp = iox_$user_io; /* ask question on user i/o */ cqi.answer_iocbp = iox_$user_io; /* and get answer from same place */ end; continue_sw = "1"b; end; else do; if answer_node.answer = "yes" | answer_node.answer = "y" | answer_node.answer = "no" | answer_node.answer = "n" then is_yes_or_no = "1"b; else is_yes_or_no = "0"b; SET_ANSWER: if as.version = 2 then do; /* old version structure */ if as.yes_or_no_sw & ^is_yes_or_no then do; REJECT_NON_YES_NO: if answer_node.call_sw then call ssu_$print_message (sci_ptr, 0, "Ignoring response ""^a"" to yes-or-no question:^/^a", temp_answer, question_string); else call ssu_$print_message (sci_ptr, 0, "Ignoring response ""^a"" to yes-or-no question:^/^a", answer_node.answer, question_string); continue_sw = "1"b; /* continue to signal */ return; end; answer_max_len = as.max_answer_len; as.answer_len = min (answer_max_len, answer_node.answer_len); /* careful of string lth */ if answer_node.call_sw then substr (as.answer_ptr -> based_answer, 1, as.answer_len) = temp_answer; else substr (as.answer_ptr -> based_answer, 1, as.answer_len) = answer_node.answer; as.preset_sw = "1"b; /* preset answer given */ as.question_sw, as.answer_sw = ^brief_sw; end; /* print if ^brief */ else if cqi.version >= 3 then do; if cqi.yes_or_no_sw & ^is_yes_or_no then go to REJECT_NON_YES_NO; answer_max_len = cqi.max_answer_lth; cqi.answer_lth = min (answer_node.answer_len, answer_max_len); /* careful of string lth */ if answer_node.call_sw then substr (cqi.answer_ptr -> based_answer, 1, cqi.answer_lth) = temp_answer; else substr (cqi.answer_ptr -> based_answer, 1, cqi.answer_lth) = answer_node.answer; cqi.preset_sw = "1"b; /* preset answer */ cqi.question_sw, cqi.answer_sw = ^brief_sw; if cqi.version > 3 then /* if iocbp's are defined */ cqi.question_iocbp = iox_$user_output; end; /* print question and answer on user_output */ else do; /* don't handle other versions */ continue_sw = "1"b; return; end; end; answer_node.times = answer_node.times - 1; if answer_node.times = 0 then answer_node_ptr = answer_node.next_ptr; return; end answer_handler; %page; add_answer_node: procedure (); old_node_ptr = answer_node_ptr; allocate answer_node in (area) set (answer_node_ptr); answer_node.next_ptr = null (); /* this is the last node in the chain */ if old_node_ptr ^= null () then do; /* chain the nodes together */ old_node_ptr -> answer_node.next_ptr = answer_node_ptr; if old_node_ptr -> answer_node.times = -1 then old_node_ptr -> answer_node.times = 1; /* if -times not given, assume 1 */ end; answer_node.query_sw = "0"b; answer_node.call_sw = "0"b; answer_node.times = -1; /* mark as not given yet */ end add_answer_node; add_match_node: procedure (); old_node_ptr = match_node_ptr; allocate match_node in (area) set (match_node_ptr); match_node.next_ptr = null (); /* this is the last node in the chain */ if old_node_ptr ^= null () then /* thread onto last node */ old_node_ptr -> match_node.next_ptr = match_node_ptr; if first_match_ptr = null () then first_match_ptr = match_node_ptr; end add_match_node; clean_up: procedure (); if request_ptr ^= null () then free request_line in (area); if temp_ptr ^= null () then call ssu_$release_temp_segment (sci_ptr, temp_ptr); do answer_node_ptr = first_node_ptr repeat next_node_ptr while (answer_node_ptr ^= null ()); next_node_ptr = answer_node.next_ptr; free answer_node in (area); end; do match_node_ptr = first_match_ptr repeat next_node_ptr while (match_node_ptr ^= null ()); next_node_ptr = match_node.next_ptr; free match_node in (area); end; if standalone_invocation then /* we created the invocation for ourselves... */ call ssu_$destroy_invocation (sci_ptr); end clean_up; %page; process_selections: procedure (P_continue_sw, P_question_ptr, P_question_len); dcl P_continue_sw bit (1) aligned; /* ON = do not answer this question */ dcl P_question_ptr pointer; dcl P_question_len fixed binary (21); dcl (match_node_ptr, mp) pointer; match_node_ptr = first_match_ptr; if match_node_ptr -> match_node.exclude_sw then P_continue_sw = "0"b; /* excluding first: assume any question matches */ else P_continue_sw = "1"b; do mp = match_node_ptr repeat (mp -> match_node.next_ptr) while (mp ^= null ()); if mp -> match_node.exclude_sw then do; /* exclude_sw if it matches */ if ^P_continue_sw then /* only if still under consideration */ if match_one (mp, P_question_ptr, P_question_len) then P_continue_sw = "1"b; end; else if P_continue_sw then /* -match: include only if already excluded */ if match_one (mp, P_question_ptr, P_question_len) then P_continue_sw = "0"b; end; return; /* Returns "1"b if the question matches the given -match or -exclude string */ match_one: procedure (P_mp, P_ptr, P_len) returns (bit (1)); dcl P_mp pointer; /* ptr to the next match node */ dcl P_ptr pointer; /* ptr to the question being considered */ dcl P_len fixed binary (21); /* length of the question */ dcl question_string character (P_len) based (P_ptr); if P_mp -> match_node.regexp_sw then call search_file_ (addr (P_mp -> match_node.match_str), 1, P_mp -> match_node.match_len, P_ptr, 1, P_len, 0, 0, code); else code = binary ((index (question_string, P_mp -> match_node.match_str) = 0), 35, 0); /* yields 1 if matches, 0 otherwise */ return (code = 0); /* or vice-versa */ end match_one; end process_selections; end answer;  area_status.pl1 09/04/86 1311.5r w 09/04/86 1306.3 148887 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2,indcomtxt */ area_status: proc; /* 81-09-12. E. N. Kittlitz. call cv_ptr_$terminate on the segment cv_ptr_ originally got for us. */ /****^ HISTORY COMMENTS: 1) change(86-06-18,Kissel), approve(86-07-31,MCR7465), audit(86-08-01,Wong), install(86-09-04,MR12.0-1134): Added the get_block_data_info entry so that callers can walk through an area and look at each block. END HISTORY COMMENTS */ /* Parameters */ dcl a_area_infop ptr; dcl a_code fixed bin (35); dcl P_code fixed bin (35) parameter; dcl P_block_allocated_flag bit (1) parameter; dcl P_data_size fixed bin (18) parameter; dcl P_next_data_ptr ptr parameter; dcl P_output_area_ptr ptr parameter; dcl P_block_data_ptr ptr parameter; dcl P_next_ptr_flag bit (1) parameter; dcl P_area_ptr ptr parameter; /* Static */ dcl my_name char (12) static init ("area_status") options (constant); /* Automatic */ dcl area_copy_size fixed bin (18); dcl given_areap ptr; /* pointer returned by cv_ptr_ based on command args */ dcl have_name bit (1); dcl n_components fixed bin; dcl next_areap ptr; dcl ptrs (1) ptr; dcl steps fixed bin; dcl not_subr bit (1); dcl first bit (1); dcl free_count1 fixed bin; dcl total_free1 fixed bin; dcl total_virgin fixed bin; dcl used_count1 fixed bin; dcl total_used1 fixed bin; dcl nextp ptr; dcl offset fixed bin; dcl total_free fixed bin; dcl free_count fixed bin; dcl code fixed bin (35); dcl bp ptr; dcl trace bit (1); dcl long bit (1); dcl sb_n_allocated fixed bin; dcl sb_n_free fixed bin; dcl tp ptr; dcl tc fixed bin; dcl i fixed bin; /* Builtins */ dcl (addrel, bin, hbound, lbound, max, null, ptr, rel, size, string) builtin; /* Conditions */ dcl cleanup condition; /* External */ dcl ((error_table_$bad_segment, error_table_$bad_arg, error_table_$bad_conversion, error_table_$badopt, error_table_$end_of_info, error_table_$unimplemented_version, error_table_$wrong_no_of_args) fixed bin (35), sys_info$max_seg_size fixed bin (18), iox_$user_output ptr ) external static; /* Entries */ dcl cu_$arg_count entry returns (fixed bin); dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl dump_seg_ entry (ptr, ptr, fixed bin, fixed bin, bit (6) aligned); dcl com_err_ entry options (variable); dcl cv_oct_check_ entry (char (*), fixed bin (35), fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl ioa_ entry options (variable); dcl cv_ptr_ entry (char (*), fixed bin (35)) returns (ptr); dcl cv_ptr_$terminate entry (ptr); /* Based */ dcl targ char (tc) based (tp); dcl copy_area (area_copy_size) fixed bin based (ptrs (1)); /* */ tc = 0; not_subr = "1"b; have_name = "0"b; offset = 0; areap = null; given_areap = null; on cleanup call clean_up_seg; trace = "0"b; long = "0"b; do i = 1 to cu_$arg_count (); call cu_$arg_ptr (i, tp, tc, code); if targ = "-trace" then trace = "1"b; else if targ = "-long" | targ = "-lg" then trace, long = "1"b; else if targ = "-offset" | targ = "-ofs" then do /* obsolete control arg */ i = i + 1; call cu_$arg_ptr (i, tp, tc, code); if code ^= 0 then do; call com_err_ (code, my_name, "Offset not supplied."); call clean_up_seg; return; end; call cv_oct_check_ (targ, code, offset); if code ^= 0 then do; code = error_table_$bad_conversion; goto err; end; end; else if ^have_name then do; given_areap = cv_ptr_ (targ, code); if code ^= 0 then goto err; areap = given_areap; /* make working copy */ have_name = "1"b; end; else do; call com_err_ (error_table_$badopt, my_name, "^a", targ); call clean_up_seg; return; end; end; if areap = null then do; call com_err_ (error_table_$wrong_no_of_args, my_name, "Usage: area_status virtual_ptr {-control_args} control args: -trace, -long (-lg)"); return; end; if offset ^= 0 then areap = addrel (areap, offset); if area_header.version ^= area_version_1 then do; call com_err_ (error_table_$unimplemented_version, my_name, "^/while referencing the area at ^p.",areap); call clean_up_seg; return; end; if area_header.extend then areap = addrel (areap, area_header.extend_info) -> extend_block.first_area; /* Now get stats for the area */ if get_statistics () then do; call ioa_ ("Area format error."); call clean_up_seg; return; end; if sb_n_allocated ^= used_count1 then if long then call ioa_ ("Area header does not agree: blocks allocated is ^d; should be ^d", area_header.n_allocated, used_count1); if sb_n_free ^= free_count1 then if long then call ioa_ ("Area header does not agree: blocks free is ^d; should be ^d", area_header.n_free, free_count1); if total_free1 ^= total_free | free_count1 ^= free_count then do; call ioa_ ("Free list has ^d words in ^d blocks", total_free, free_count); call ioa_ ("Scan of area found ^d words in ^d free blocks", total_free1, free_count1); end; call ioa_ ("^/^16xBusy^6xFree^/"); call ioa_ ("Blocks^4x^10d^10d", used_count1, free_count1); call ioa_ ("Words^5x^10d^10d", total_used1, total_free1); call ioa_ ("^d words of virgin storage", total_virgin); if string (area_header.flags) then do; /* some control bits are ON */ if area_header.flags.extend then call ioa_ ("in ^d components.", n_components); if area_header.flags.zero_on_alloc then call ioa_ ("Zero on allocation in effect."); if area_header.flags.zero_on_free then call ioa_ ("Zero on free in effect."); if area_header.flags.dont_free then call ioa_ ("Freeing disabled."); if area_header.allocation_method = 1 then call ioa_ ("Blocks are packed -- no freeing allowed."); call ioa_ (" "); end; call clean_up_seg; return; /* */ get_statistics: proc returns (bit (1) aligned); dcl save_areap ptr; dcl print_areap ptr; /* This subroutine scans an area and accumulates statistics about the area. It makes a copy of the area in a temporary segment since it marks blocks for cross checking. */ save_areap = areap; sb_n_allocated = 0; sb_n_free = 0; total_virgin = 0; free_count = 0; total_free = 0; total_free1 = 0; free_count1 = 0; total_used1 = 0; used_count1 = 0; steps = 0; n_components = 0; on cleanup call release_temp_segments_ ("area_status", ptrs, code); call get_temp_segments_ ("area_status", ptrs, code); next_areap = areap; do areap = areap repeat next_areap while (next_areap ^= null); n_components = n_components + 1; if area_header.extend then next_areap = addrel (areap, area_header.extend_info) -> extend_block.next_area; else next_areap = null; if area_header.allocation_method = NO_FREEING_ALLOCATION_METHOD then go to end_loop; total_virgin = total_virgin + bin (area_header.last_usable, 18) - bin (area_header.next_virgin, 18); sb_n_allocated = sb_n_allocated + area_header.n_allocated; sb_n_free = sb_n_free + area_header.n_free; /* First scan the free list */ area_copy_size = max (bin (area_header.next_virgin, 18), bin (area_header.last_block, 18)); if area_copy_size + bin (rel (areap), 18) > sys_info$max_seg_size then area_copy_size = sys_info$max_seg_size - bin (rel (areap), 18); copy_area = areap -> copy_area; print_areap = areap; areap = ptrs (1); do i = lbound (areap -> area_header.freep, 1) to hbound (areap -> area_header.freep, 1); bp = addrel (areap, areap -> area_header.freep (i).relp); /* get ptr to first thing on free list */ if bp ^= areap then do; first = "1"b; do blockp = bp repeat addrel (areap, block.fp) while (blockp ^= bp | first); first = "0"b; block.marked = "1"b; total_free = total_free + bin (block.cur_size, 18); free_count = free_count + 1; if block.prev_busy = "0"b & not_subr then call ioa_ ("BLOCK AT ^p HAS PREVIOUS FREE", ptr(print_areap, rel(blockp))); if trace & not_subr then call ioa_ ("FREE SIZE ^4o AT ^p", bin (block.cur_size, 18)-2, ptr(print_areap, rel(blockp))); steps = steps + 1; if steps > 50000 then do; areap = save_areap; return ("1"b); end; end; end; end; /* Now scan all blocks in the area */ steps = 0; do blockp = addrel (areap, size (area_header)) repeat addrel (blockp, block.cur_size) while (bin (rel (blockp), 18) - bin (rel (areap), 18) < bin (areap -> area_header.next_virgin, 18)); if bin (rel (blockp), 18) = bin (rel (areap), 18) + bin (areap -> area_header.last_block, 18) then do; is_busy: if trace & not_subr then call ioa_ ("BUSY ^6o AT ^p", bin (block.cur_size, 18)-2, ptr(print_areap, rel(blockp))); used_count1 = used_count1 + 1; total_used1 = total_used1 + bin (block.cur_size, 18); if block.marked & not_subr then /* found on free list in first pass */ call ioa_ ("BLOCK AT ^p NOT FREE", ptr(print_areap, rel(blockp))); if long & not_subr then call dump_seg_ (iox_$user_output, addrel (blockp, 2), bin (rel (blockp), 18)+2, bin (block.cur_size, 18)-2, "110010"b); end; else do; nextp = addrel (blockp, block.cur_size); if nextp->block.prev_busy then go to is_busy; if trace & not_subr then call ioa_ (" ^6o AT ^p", bin (block.cur_size, 18), ptr(print_areap, rel(blockp))); free_count1 = free_count1 + 1; total_free1 = total_free1 + bin (block.cur_size, 18); if block.marked = "0"b & not_subr then /* not on free list */ call ioa_ ("FREE BLOCK AT ^p NOT ON FREE LIST", ptr(print_areap, rel(blockp))); end; steps = steps + 1; if steps > 50000 then do; areap = save_areap; return ("1"b); end; end; end_loop: end; call release_temp_segments_ ("area_status", ptrs, code); areap = save_areap; return ("0"b); end get_statistics; /* */ area_info_: entry (a_area_infop, a_code); area_infop = a_area_infop; if area_info.version ^= area_info_version_1 then do; a_code = error_table_$unimplemented_version; area_info.version_of_area = area_header.version; return; end; areap = area_info.areap; not_subr = "0"b; if get_statistics () then do; a_code = error_table_$bad_segment; return; end; string (area_info.control) = "0"b; area_info.zero_on_alloc = area_header.zero_on_alloc; area_info.zero_on_free = area_header.zero_on_free; area_info.dont_free = area_header.dont_free; area_info.system = area_header.system; if area_header.allocation_method = 1 then area_info.no_freeing = "1"b; if area_header.extend | area_header.defined_by_call then do; area_info.extend = area_header.extend; extend_blockp = addrel (areap, area_header.extend_info); area_info.owner = extend_block.name; area_info.n_components = n_components; end; else do; area_info.owner = ""; area_info.n_components = 1; end; area_info.size = bin (area_header.last_usable, 18); area_info.version_of_area = area_header.version; area_info.allocated_blocks = used_count1; area_info.free_blocks = free_count1; area_info.allocated_words = total_used1; area_info.free_words = total_free1; a_code = 0; return; /*****************************************************************************/ /* */ /* ENTRY: get_block_data_info */ /* */ /* This entry takes a pointer to an area, a flag, and a pointer to some */ /* data in the area. If the flag is not set, then the size of the block */ /* (in words) of the block holding the specified data is returned, along */ /* with a flag indicating whether the block is free or allocated. If the */ /* flag is set, then information about the block after the one pointed to */ /* by the input pointer is returned. A pointer to the area in which the */ /* returned data block exists is also returned. This will be the same as */ /* the input area pointer, unless the area is extensible and the next */ /* block is in the next area. */ /* */ /*****************************************************************************/ get_block_data_info: entry (P_area_ptr, P_next_ptr_flag, P_block_data_ptr, P_output_area_ptr, P_next_data_ptr, P_data_size, P_block_allocated_flag, P_code); areap = P_area_ptr; /* Initialize the outputs in case of error. */ P_output_area_ptr = areap; P_next_data_ptr = null (); P_data_size = 0; P_block_allocated_flag = "0"b; P_code = 0; call Set_get_block_data_info_Args (P_code); /*** We should try the next area in some cases. */ if code = error_table_$end_of_info & area_header.flags.extend & P_next_ptr_flag then do; areap = addwordno (areap, bin (area_header.extend_info, 18)); call Set_get_block_data_info_Args (P_code); end; return; clean_up_seg: proc; if given_areap ^= null then call cv_ptr_$terminate (given_areap); end; err: call com_err_ (code, my_name, targ); return; /*****************************************************************************/ /* */ /* PROCEDURE: Set_get_block_data_info_Args */ /* */ /* This procedure uses all of the global variables and parameters of the */ /* get_block_data_info entry, except for the return code. It sets the */ /* output parameters if it can and returns a code. The code is */ /* error_table_$end_of_info if everything is all right, but the block */ /* requested is in virgin storage. Otherwise, the code indicates some */ /* problem with the area. */ /* */ /*****************************************************************************/ Set_get_block_data_info_Args: proc (P_code); dcl P_code fixed bin (35) parameter; /* Make sure the area pointer is OK. */ if areap = null () then P_code = error_table_$bad_arg; /* The area pointer is OK. */ else do; /*** Check the area format. */ if area_header.version ^= area_version_1 | area_header.allocation_method = NO_FREEING_ALLOCATION_METHOD then code = error_table_$unimplemented_version; /*** The area is OK, keep going. */ else do; /*** Initialize the block pointer. */ if P_block_data_ptr = null () then blockp = addwordno (areap, size (area_header)); else blockp = addwordno (P_block_data_ptr, -alloc_blkhdrsz); if P_next_ptr_flag then blockp = addwordno (blockp, bin (block.cur_size, 18)); /*** Skip the extend block if we happened to get it. */ if wordno (blockp) + alloc_blkhdrsz = bin (area_header.extend_info, 18) then blockp = addwordno (blockp, bin (block.cur_size, 18)); /*** Easy case, everything is in this area. */ if wordno (blockp) - wordno (areap) < bin (area_header.next_virgin, 18) then do; P_next_data_ptr = addwordno (blockp, alloc_blkhdrsz); P_data_size = bin (block.cur_size, 18); if wordno (blockp) = wordno (areap) + bin (area_header.last_block, 18) then P_block_allocated_flag = "1"b; else do; if addwordno (blockp, bin (block.cur_size, 18)) -> block.prev_busy then P_block_allocated_flag = "1"b; else P_block_allocated_flag = "0"b; end; end; /*** No block here, let our caller know. */ else P_code = error_table_$end_of_info; end; end; /* Output args are either at their initial values, or we set them above. */ return; end Set_get_block_data_info_Args; %include area_structures; %include area_info; end area_status;  change_error_mode.pl1 11/04/82 1946.6rew 11/04/82 1624.8 14805 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ change_error_mode: cem: procedure; /* This command allows one to change the verbosity of the messages from default_error_handler_ */ /* initially coded by M. Weaver 6 July 1971 */ /* Modified 761025 by PG to convert to Version 2 PL/I */ /* automatic */ dcl (alng, code, lng) fixed bin; dcl aptr ptr; /* based */ dcl arg char (alng) based (aptr); /* entries */ dcl default_error_handler_$change_error_message_mode_ entry (fixed bin); dcl cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin); dcl com_err_ entry options (variable); /* external static */ dcl error_table_$badopt fixed bin (35) external static; /* program */ call cu_$arg_ptr (1, aptr, alng, code); /* find out what user wants */ if code ^= 0 then lng = 1; /* reset to "normal" length */ else do; if arg = "-bf" | arg = "-brief" then lng = 0; else if arg = "-lg" | arg = "-long" then lng = 2; else do; call com_err_ (error_table_$badopt, "change_error_mode", "^a", arg); return; end; end; call default_error_handler_$change_error_message_mode_ (lng); /* put value in deh's int static */ return; end;  create_area.pl1 11/04/82 1946.6rew 11/04/82 1625.0 40941 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ create_area: proc; /* This command either creates or innitializes an area */ /* coded 76/11/01 by M. Weaver */ dcl (i, alng, segid_type) fixed bin; dcl aptr ptr; dcl arg char (alng) based (aptr); dcl dir char (168); dcl ent char (32); dcl code fixed bin (35); dcl me char (12) aligned init ("create_area") static options (constant); dcl fatal bit (1) aligned; dcl cu_$arg_count entry () returns (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl (ioa_, com_err_) entry options (variable); dcl cv_ptr_ entry (char (*), fixed bin (35)) returns (ptr); dcl cv_ptr_$terminate entry (ptr); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl define_area_ entry (ptr, fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (18)); dcl get_group_id_ entry () returns (char (32) aligned); dcl error_table_$noarg fixed bin (35) ext; dcl error_table_$badopt fixed bin (35) ext; dcl sys_info$max_seg_size fixed bin (18) ext; dcl (addr, null, string, substr) builtin; dcl 1 info aligned like area_info; %include area_info; /* first initialize the area info structure */ info.version = area_info_version_1; string (info.control) = "0"b; info.owner = get_group_id_ (); info.size = sys_info$max_seg_size; info.areap = null; segid_type = 0; fatal = "0"b; /* now overwrite portions of the structure according to the arguments */ do i = 1 to cu_$arg_count (); call cu_$arg_ptr (i, aptr, alng, code); if substr (arg, 1, 1) = "-" then do; if arg = "-extend" then info.control.extend = "1"b; else if arg = "-zero_on_alloc" then info.control.zero_on_alloc = "1"b; else if arg = "-zero_on_free" then info.control.zero_on_free = "1"b; else if arg = "-dont_free" then info.control.dont_free = "1"b; else if arg = "-no_freeing" then info.control.no_freeing = "1"b; else if arg = "-size" then do; i = i + 1; call cu_$arg_ptr (i, aptr, alng, code); if code ^= 0 then do; call com_err_ (code, me, "size"); fatal = "1"b; end; else do; info.size = cv_oct_check_ (arg, code); if code ^= 0 then do; fatal = "1"b; call com_err_ (0, me, "Size ^a should be an octal number.", arg); end; end; end; else if arg = "-id" then do; i = i + 1; call cu_$arg_ptr (i, aptr, alng, code); if code ^= 0 then do; call com_err_ (error_table_$noarg, me, "ID string"); fatal = "1"b; end; else info.owner = arg; end; else do; call com_err_ (error_table_$badopt, me, arg); fatal = "1"b; end; end; /* end of control argument group */ else do; /* must have address */ if segid_type ^= 0 then do; /* this is not the first address */ call com_err_ (0, me, "Only 1 virtual address is allowed."); fatal = "1"b; end; else do; /* first address */ segid_type = 1; info.areap = cv_ptr_ (arg, code); /* get ptr to area, if it exists */ if code ^= 0 then do; /* null ptr given meane create temp */ segid_type = 2; /* don't want to call cv_ptr_$terminate */ call expand_pathname_ (arg, dir, ent, code); if code ^= 0 then do; path_error: call com_err_ (code, me, arg); fatal = "1"b; end; else do; call hcs_$make_seg (dir, ent, "", 01010b, info.areap, code); if info.areap = null then goto path_error; end; end; end; end; end; if fatal then do; if segid_type = 1 then call cv_ptr_$terminate (info.areap); return; end; if segid_type = 0 then do; /* no name was given */ call com_err_ (error_table_$noarg, me, "virtual address"); return; end; call define_area_ (addr (info), code); if code ^= 0 then call com_err_ (code, me); else call ioa_ ("area pointer = ^p", info.areap); if segid_type = 0 then call cv_ptr_$terminate (info.areap); return; end;  display_timers.pl1 11/14/86 1030.9rew 11/14/86 1030.0 46368 /****^ *********************************************************** * * * 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-11-12,Fawcett), approve(86-11-12,PBF7473), audit(86-11-13,Gilcrease), install(86-11-14,MR12.0-1218): Changed to work with version 3 of timere_manager_schedule.incl.pl1. END HISTORY COMMENTS */ /* format: style1,^inddcls,ifthenstmt,ifthendo,ifthen,indcomtxt,dclind5 */ display_timers: proc; /* This command prints a list of the timer_manager_ timers scheduled to occur in the process. Written in 1980 by C. D. Tavares Modified 8 September 1982 by Richard Lamson to work with version 2 schedule */ /* AUTOMATIC */ dcl (code fixed bin (35), date_time_string char (24), dirname char (168), ename char (32), i fixed bin, strp pointer) automatic; /* STATIC */ dcl sys_area_p pointer initial (null); /* BASED */ dcl sys_area area (sys_info$max_seg_size) based (sys_area_p); /* EXTERNAL STATIC */ dcl (error_table_$improper_data_format, error_table_$unimplemented_version, sys_info$max_seg_size) ext fixed bin (35) static; /* ENTRIES */ dcl com_err_ entry options (variable), date_time_ entry (fixed bin (71), char (*)), get_control_point_id_ entry () returns (bit (36)), get_system_free_area_ entry () returns (ptr), hcs_$fs_get_path_name entry (pointer, char (*), fixed bin, char (*), fixed bin (35)), interpret_ptr_ entry (pointer, pointer, pointer), ioa_ entry options (variable), ioa_$rsnnl entry options (variable), timer_manager_$get_schedule entry (pointer, pointer, fixed bin (35)); /* BUILTINS */ dcl (addr, clock, codeptr, environmentptr, min, null, unspec, vclock) builtin; /* CONDITIONS */ dcl cleanup condition; %page; %include interpret_ptr_struc; %page; %include timer_manager_schedule; %page; if sys_area_p = null then sys_area_p = get_system_free_area_ (); schedule_ptr = null; on cleanup call cleaner_up; call timer_manager_$get_schedule (sys_area_p, schedule_ptr, code); if code ^= 0 then call crump (code, "Obtaining timers."); if schedule.version < timer_manager_schedule_version_1 | schedule.version > timer_manager_schedule_version_3 then call crump (error_table_$unimplemented_version, ""); call date_time_ (clock (), date_time_string); call ioa_ ("^[No timers^s^;1 timer^s^;^d timers^] scheduled. Current time is ^a; current CPU usage is ^.2f^/", min (schedule.n_timers + 1, 3), schedule.n_timers, date_time_string, vclock () / 1e6); do i = 1 to schedule.n_timers; if schedule.version < timer_manager_schedule_version_2 then timer (i).data_ptr_provided = "0"b; if timer.call (i) then do; call hcs_$fs_get_path_name (codeptr (timer.routine (i)), dirname, 0, ename, code); if code ^= 0 then call crump (code, "Interpreting a timer's entry variable."); call interpret_ptr_ (codeptr (timer.routine (i)), environmentptr (timer.routine (i)), addr (strbuf)); end; else if ^timer (i).wakeup then call crump (error_table_$improper_data_format, "Timer neither call nor wakeup."); if timer.alarm (i) then call date_time_ (timer.time (i), date_time_string); else if timer.cpu (i) then call ioa_$rsnnl ("^6.3f CPU seconds", date_time_string, 0, timer.time (i) / 1e6); else call crump (error_table_$improper_data_format, "Timer neither alarm nor CPU."); call ioa_ ("Timer ^2d is ^[inhibited ^;^]^[alarm^;CPU^] timer scheduled at ^a ^9xto ^[^scall ^a^a ^[(^p)^;^s^]^/^9x(^a>^a|^a; ^a)^;wakeup on channel ^24.3b^].", i, timer.inhibit (i), timer.alarm (i), date_time_string, timer.call (i), unspec (timer.channel (i)), strbuf.segment, strbuf.entryn, timer (i).data_ptr_provided, timer (i).data_ptr, dirname, ename, strbuf.offset, strbuf.compiler); if schedule.version >= timer_manager_schedule_version_3 then do; if timer (i).control_point_id ^= get_control_point_id_ () then call ioa_ ("^9xfor control_point ^w", timer.control_point_id); end; end; returner: call cleaner_up; return; %skip (2); cleaner_up: proc; if schedule_ptr ^= null then free schedule in (sys_area); end cleaner_up; %skip (2); crump: proc (code, reason); dcl code fixed bin (35), reason char (*); call com_err_ (code, "display_timers", reason); goto returner; end crump; end display_timers;  get_external_variable_.pl1 11/20/86 1404.2r w 11/20/86 1145.0 19593 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ get_external_variable_: proc (vname, vptr, vsize, vdesc_ptr, code); /* This procedure will locate the specified external variable and return information about the variable. The information returned includes the location and size (in words) of the data and an optional descriptor pointer. Note: At present the descriptor is not available for external variables and the vdesc_ptr will always be null (). Written 5/6/80 by Michael R. Jordan Modified: 82-11-19, T Oke to change vsize from fb (19) to fb (24) for VLA. */ /* PARAMETERS */ dcl vname char (*); /* the variable name (Input) */ dcl vptr ptr; /* pointer to the data (Output) */ dcl vsize fixed bin (24); /* size (in words) of the data (Output) */ dcl vdesc_ptr ptr; /* location of descriptor (Output) */ dcl code fixed bin (35); /* a standard error code */ /* CONSTANTS */ /* AUTOMATIC */ dcl node_ptr ptr; /* pointer to variable node */ /* BASED */ /* EXTERNAL ENTRIES */ dcl set_ext_variable_$locate entry (char (*), ptr, ptr, fixed bin (35)); /* ERROR CODES */ /* BUILTINS */ dcl null builtin; dcl stackbaseptr builtin; vptr = null (); /* initialize vptr */ vsize = 0; /* and vsize */ vdesc_ptr = null (); /* oh, and don't forget the descriptor ptr */ code = 0; /* no error yet */ call set_ext_variable_$locate (vname, stackbaseptr (), node_ptr, code); if code ^= 0 then return; vptr = node_ptr -> variable_node.vbl_ptr; /* return location */ vsize = node_ptr -> variable_node.vbl_size; /* and size */ return; /* and thats all we can do */ %include system_link_names; end get_external_variable_;  list_external_variables.pl1 11/20/86 1404.2r w 11/20/86 1145.0 53613 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ list_external_variables: lev: proc; /* This command prints information about selected external variables (*system link targets). */ /* coded October 1976 by M. Weaver */ /* modified December 1976 by M. Weaver to adjust ioa_control bounds */ /* Modified November 1982 by T. Oke to change format for longer VLA sizes */ /* Modified December 1983 by M. Weaver to print sizes in decimal */ dcl (i, j, n, alng, nnames, nprinted, nchars) fixed bin; dcl code fixed bin (35); dcl (hdrsw, lgsw, allsw, fatal) bit (1) aligned; dcl (tp, np, aptr, vptr, alp) ptr; dcl arg char (alng) based (aptr); dcl vname char (65); dcl date char (24); dcl me char (23) aligned init ("list_external_variables") static options (constant); dcl ioa_control (0:3) char (30) var static options (constant) init ( "^30a ^3o ^6o ^8d ^16a ^p", /* short name -lg */ "^a^/^31x^3o ^6o ^8d ^16a ^p", /* long name -lg */ "^30a ^3o ^6o ^8d", /* short name -bf */ "^a^/^31x^3o ^6o ^8d"); /* long name -bf */ dcl (error_table_$badopt, error_table_$too_many_args, error_table_$bigarg) ext fixed bin (35); dcl (addr, baseno, bin, fixed, hbound, lbound, null, ptr, rel, substr) builtin; dcl (com_err_, ioa_) entry options (variable); dcl cu_$arg_count entry () returns (fixed bin); dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr); dcl cu_$arg_list_ptr entry () returns (ptr); dcl date_time_ entry (fixed bin (71), char (*)); %include system_link_names; %include stack_header; /* find out if there are any external variables */ sb = ptr (addr (nnames), 0); tp = sb -> stack_header.sys_link_info_ptr; if tp = null then do; no_variables: call com_err_ (0, me, "There are no external variables."); return; end; if tp -> variable_table_header.cur_num_of_variables < 1 then goto no_variables; hdrsw = "1"b; lgsw = "0"b; allsw = "0"b; fatal = "0"b; nnames = 0; nprinted = 0; alp = cu_$arg_list_ptr(); n = cu_$arg_count (); begin; dcl 1 list (n) aligned, 2 name char (65), 2 nsize fixed bin (17) unal, 2 found bit (1) unal, 2 pad bit (17) unal; /* process all the arguments */ do i = 1 to n; call cu_$arg_ptr_rel (i, aptr, alng, code, alp); if code ^= 0 then do; call com_err_ (code, me, arg); fatal = "1"b; end; else if substr (arg, 1, 1) = "-" then do; if arg = "-unlabelled_common" | arg = "-uc" then do; nnames = nnames + 1; list (nnames).name = "blnk*com"; list (nnames).nsize = 8; list (nnames).found = "0"b; end; else if arg = "-long" | arg = "-lg" then lgsw = "1"b; else if arg = "-all" | arg = "-a" then allsw = "1"b; else if arg = "-no_header" | arg = "-nhe" then hdrsw = "0"b; else do; call com_err_ (error_table_$badopt, me, arg); fatal = "1"b; end; end; else do; nnames = nnames + 1; if nnames > hbound (list, 1) then do; call com_err_ (error_table_$too_many_args, me, "^d names maximum", hbound (list, 1)); return; end; if alng > 31 then do; call com_err_ (error_table_$bigarg, me, arg); fatal = "1"b; end; list (nnames).name = arg; list (nnames).nsize = alng; list (nnames).found = "0"b; end; end; if fatal then return; if nnames = 0 then allsw = "1"b; /* print all by default */ if hdrsw then do; if lgsw then call ioa_ ( "^/NAME^-^- SEGMENT OFFSET SIZE ALLOCATED INIT_PTR^/"); else call ioa_ ("^/NAME^-^- SEGMENT OFFSET SIZE^/"); end; /* loop through system name list, printing info for desired variables */ do i = 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 (i) repeat np -> variable_node.forward_thread while (np ^= null); if allsw then call print_it; else do j = 1 to nnames; /* see if this name matches any on list */ if ^list (j).found then do; if list (j).nsize = np -> variable_node.name_size then if list (j).name = np -> variable_node.name then do; call print_it; list (j).found = "1"b; nprinted = nprinted + 1; if nprinted = nnames then return; go to next_name; end; end; end; next_name: end; end; if allsw then return; call ioa_ ("^/The following variables were not found:"); do i = 1 to nnames; if ^list (i).found then do; if list (i).name = "blnk*com" then vname = "unlabelled common"; else vname = list (i).name; call ioa_ ("^a", vname); end; end; end; /* of begin block */ return; print_it: proc; if np -> variable_node.name = "blnk*com" then vname = "unlabelled common"; else vname = np -> variable_node.name; vptr = np -> variable_node.vbl_ptr; if lgsw then do; call date_time_ (np -> variable_node.time_allocated, date); aptr = np -> variable_node.init_ptr; call ioa_ (ioa_control (bin ((np -> variable_node.name_size > 31), 1)), vname, fixed (baseno (vptr), 15), bin (rel (vptr), 18), np -> variable_node.vbl_size, substr (date, 1, 16), aptr); end; else call ioa_ (ioa_control (bin ((np -> variable_node.name_size > 31), 1)+2), vname, fixed (baseno (vptr), 15), bin (rel (vptr), 18), np -> variable_node.vbl_size); return; end; /* of print_it */ end;  on.pl1 07/04/90 1024.1rew 07/04/90 1023.3 136323 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(90-05-23,Gray), approve(90-05-23,MCR8175), audit(90-06-21,Huen), install(90-07-04,MR12.4-1019): Added cleanup handler to the condition handler to fix case where the condition command does a non-local goto. END HISTORY COMMENTS */ on: procedure () options (variable); /* This command/active function provides the capability to trap conditions during the execution of a command line. The user may specify a command line to be invoked on detection of the condition. Usage: on conditions action_line {-control_args} subject_line */ /* Rewritten 24 April 1978 by G. Palter */ /* Modified 12/16/80, W. Olin Sibert, to add -retry_command_line control argument */ /* Modified 83-06-16, T. Oke, to only trim whitespace from the software msg. */ dcl argument character (argument_lth) based (argument_ptr); dcl argument_lth fixed binary (21); dcl argument_ptr pointer; dcl return_value character (return_value_lth) varying based (return_value_ptr); dcl return_value_lth fixed binary (21); dcl return_value_ptr pointer; dcl active_function bit (1) aligned; dcl get_arg entry (fixed binary (21), pointer, fixed binary (21), fixed binary (35)) variable; dcl complain entry () options (variable) variable; dcl code fixed binary (35); dcl argument_count fixed binary (21); dcl (have_condlist, have_action, in_command, restart_sw, retry_sw, call_cl_sw, call_cp_sw, long_sw, brief_sw) bit (1) aligned; dcl subject character (subject_lth) aligned based (subject_ptr); dcl subject_lth fixed binary (21); dcl subject_ptr pointer; dcl subject_used fixed binary (21); dcl first_subject character (256) aligned; dcl new_subject character (new_subject_lth) aligned based (new_subject_ptr); dcl new_subject_lth fixed binary (21); dcl new_subject_ptr pointer; dcl condlist character (condlist_lth) based (condlist_ptr); dcl condlist_lth fixed binary (21); dcl condlist_ptr pointer; dcl action character (action_lth) based (action_ptr); dcl action_lth fixed binary (21); dcl action_ptr pointer; dcl exclude character (exclude_lth) based (exclude_ptr); dcl exclude_lth fixed binary (21); dcl exclude_ptr pointer; dcl system_area area based (system_area_ptr); dcl system_area_ptr pointer; dcl (idx, idx2, name_lth) fixed binary (21); dcl invocation_depth fixed binary; dcl WHITESPACE character (5) static options (constant) initial (" "); /* NL SP HT VT FF */ dcl PUNCTUATION character (2) static options (constant) initial (" ,"); dcl NL character (1) static options (constant) initial (" "); dcl (error_table_$badopt, error_table_$inconsistent, error_table_$not_act_fnc, error_table_$wrong_no_of_args) fixed binary (35) external; dcl iox_$user_io pointer external; dcl active_fnc_err_ entry () options (variable); dcl com_err_ entry () options (variable); dcl condition_ entry (character (*), entry); dcl condition_interpreter_ entry (pointer, pointer, fixed binary (21), fixed binary, pointer, character (*), pointer, pointer); dcl cu_$af_arg_ptr entry (fixed binary (21), pointer, fixed binary (21), fixed binary (35)); dcl cu_$af_return_arg entry (fixed binary (21), pointer, fixed binary (21), fixed binary (35)); dcl cu_$arg_count entry (fixed binary (21)); dcl cu_$arg_ptr entry (fixed binary (21), pointer, fixed binary (21), fixed binary (35)); dcl cu_$cl entry () options (variable); dcl cu_$cp entry (pointer, fixed binary (21), fixed binary (35)); dcl get_system_free_area_ entry () returns (pointer); dcl ioa_$ioa_switch entry () options (variable); dcl (any_other, cleanup) condition; dcl (addr, empty, index, length, max, null, search, substr, verify) builtin; /* Initialization */ call cu_$af_return_arg (argument_count, return_value_ptr, return_value_lth, code); if code = 0 then do; /* invoked as an active function */ active_function = "1"b; get_arg = cu_$af_arg_ptr; complain = active_fnc_err_; return_value = "false"; /* assume nothin raised */ end; else if code = error_table_$not_act_fnc then do; /* command */ active_function = "0"b; call cu_$arg_count (argument_count); get_arg = cu_$arg_ptr; complain = com_err_; end; else do; /* strange error */ call com_err_ (code, "on"); return; end; have_condlist, /* seen list of conditions to trap */ have_action, /* seen action to perfom */ in_command = "0"b; /* fetching subject line */ subject_ptr = addr (first_subject); /* use automatic space */ subject_lth = length (first_subject); first_subject = ""; subject_used = 0; /* empty at the moment */ condlist_ptr, action_ptr, exclude_ptr = null (); condlist_lth, action_lth, exclude_lth = 0; /* list of conditions to exclude */ restart_sw, /* automatic restart */ retry_sw, /* retry the command line if the condition occurs */ call_cl_sw, /* invoke the listener */ call_cp_sw, /* have some action to perform */ long_sw, /* print long message */ brief_sw = "0"b; /* print no messages */ system_area_ptr = get_system_free_area_ (); on cleanup begin; if subject_ptr ^= addr (first_subject) then free subject in (system_area); /* free storage */ end; /* Process argument list */ do idx = 1 to argument_count; call get_arg (idx, argument_ptr, argument_lth, code); if code ^= 0 then do; call complain (code, "on", "Fetching argument #^d", idx); go to RETURN; end; if in_command then do; /* in subject command line */ CLARG: if subject_used + argument_lth + 1 > subject_lth then do; /* must allocate more room for command line */ new_subject_lth = max ((2 * subject_lth), (subject_lth + argument_lth)); allocate new_subject in (system_area) set (new_subject_ptr); new_subject = subject; if subject_ptr ^= addr (first_subject) then free subject in (system_area); /* free old copy */ subject_ptr = new_subject_ptr; subject_lth = new_subject_lth; end; substr (subject, (subject_used + 1), argument_lth) = argument; subject_used = subject_used + argument_lth + 1; end; else do; /* process options, conditions, etc */ if substr (argument, 1, 1) = "-" then do; /* an option */ if (argument = "-restart") | (argument = "-rt") then if retry_sw then do; call complain (error_table_$inconsistent, "on", """-restart"" and ""-retry_command_line""."); goto RETURN; end; else restart_sw = "1"b; else if argument = "-cl" then if active_function then do; /* -cl not allowed for active function */ call complain (error_table_$badopt, "on", "Active function may not use ""-cl""."); go to RETURN; end; else call_cl_sw = "1"b; else if (argument = "-exclude") | (argument = "-ex") then do; idx = idx + 1; /* -exclude takes a list of conditions */ call get_arg (idx, argument_ptr, argument_lth, code); if code ^= 0 then do; call complain (code, "on", "Condition list for ""-exclude""."); go to RETURN; end; if exclude_ptr ^= null () then do; call complain (error_table_$wrong_no_of_args, "on", """-exclude"" may only be used once."); go to RETURN; end; exclude_ptr = argument_ptr; exclude_lth = argument_lth; end; else if (argument = "-long") | (argument = "-lg") then if brief_sw then do; /* -brief and -long */ call complain (error_table_$inconsistent, "on", """-long"" and ""-brief""."); go to RETURN; end; else long_sw = "1"b; else if (argument = "-brief") | (argument = "-bf") then if long_sw then do; /* -brief and -long */ call complain (error_table_$inconsistent, "on", """-long"" and ""-brief""."); go to RETURN; end; else brief_sw = "1"b; else if (argument = "-retry_command_line") | (argument = "-rcl") then if restart_sw then do; call complain (error_table_$inconsistent, "on", """-restart"" and ""-retry_command_line""."); goto RETURN; end; else retry_sw = "1"b; else do; call complain (error_table_$badopt, "on", """^a"".", argument); go to RETURN; end; end; else do; /* condition list, action, or start of subject */ if ^have_condlist then do; have_condlist = "1"b; condlist_ptr = argument_ptr; condlist_lth = argument_lth; end; else if ^have_action then do; have_action = "1"b; action_ptr = argument_ptr; action_lth = argument_lth; end; else do; in_command = "1"b; go to CLARG; end; end; end; end; if subject_used = 0 then do; call complain (0, "on", "Usage: on conditions action {-control_args} subject"); go to RETURN; end; subject_used = subject_used - 1; /* elimintate trailing space */ if action_lth ^= 0 then if verify (action, WHITESPACE) ^= 0 then call_cp_sw = "1"b; /* actually something to do */ /* Set up handlers and invoke the subject line */ idx = 1; do while (substr (condlist, idx) ^= ""); /* while something left */ name_lth = search (substr (condlist, idx), PUNCTUATION) - 1; if name_lth < 0 then name_lth = length (condlist) - idx + 1; /* rest of list */ call condition_ ((substr (condlist, idx, name_lth)), handler); idx = idx + name_lth; idx2 = verify (substr (condlist, idx), PUNCTUATION) - 1; if idx2 > 0 then idx = idx + idx2; end; RETRY_COMMAND: invocation_depth = 0; /* nothing raised yet */ call cu_$cp (addr (subject), subject_used, (0)); RETURN: if subject_ptr ^= addr (first_subject) then free subject in (system_area); return; handler: procedure (mc_ptr, condition_name, wc_ptr, info_ptr, continue_sw); /* This internal procedure is invoked to handle any of the conditions being trapped. It process all control arguments. */ dcl mc_ptr pointer; /* machine conditions */ dcl condition_name character (*); /* the conditions raised */ dcl wc_ptr pointer; /* wall crossing */ dcl info_ptr pointer; /* software information */ dcl continue_sw bit (1); /* ON if the condition should continue up */ %include condition_info_header; dcl 1 software_data aligned like condition_info_header based (info_ptr); dcl small_area area; dcl (idx, idx2, idx3) fixed binary (21); dcl name_lth fixed binary (21); dcl error_msg character (error_msg_lth) based (error_msg_ptr); dcl error_msg_lth fixed binary (21); dcl error_msg_ptr pointer; dcl old_invocation_depth fixed binary; dcl software_msg character (256) varying; dcl length builtin; /* Scan exclude list to see if we should ignore this condition */ if exclude_lth ^= 0 then do; idx = 1; do while (substr (exclude, idx) ^= ""); name_lth = search (substr (exclude, idx), PUNCTUATION) - 1; if name_lth < 0 then name_lth = length (exclude) - idx + 1; /* rest of list */ if condition_name = substr (exclude, idx, name_lth) then do; continue_sw = "1"b; /* give it to superiors */ return; end; idx = idx + name_lth; idx2 = verify (substr (exclude, idx), PUNCTUATION) - 1; if idx2 > 0 then idx = idx + idx2; end; end; /* Print a message if requested */ if ^brief_sw then do; software_msg = ""; if info_ptr ^= null then if software_data.version >= 1 then if length (software_data.info_string) > 0 then do; software_msg = software_data.info_string; if verify (substr (software_msg, length (software_msg), 1), WHITESPACE) = 0 then software_msg = substr (software_msg, 1, length (software_msg) - 1); end; call ioa_$ioa_switch (iox_$user_io, "on: Condition ""^a"" raised. ^a", condition_name, software_msg); end; /* Check for recursive signalling */ old_invocation_depth = invocation_depth; on cleanup invocation_depth = old_invocation_depth; invocation_depth = invocation_depth + 1; if invocation_depth > 2 then go to RETURN; /* bad loop */ else if invocation_depth > 1 then do; call ioa_$ioa_switch (iox_$user_io, "on: Recursive signalling of ""^a"".", condition_name); go to RETURN; end; /* If an active function, indicate a condition was trapped */ if active_function then return_value = "true"; /* Print detailed information if requested */ if long_sw then do; call condition_interpreter_ (addr (small_area), error_msg_ptr, error_msg_lth, 3, mc_ptr, condition_name, wc_ptr, info_ptr); idx = 1; idx2 = index (error_msg, "Error"); /* trim the message somewhat */ if (idx2 > 0) & (idx2 < 4) then idx = idx2 + 6; idx2 = verify (substr (error_msg, idx), " "); if idx2 > 0 then idx = idx + idx2 - 1; idx2 = idx; do idx3 = idx to error_msg_lth; if substr (error_msg, idx3, 1) = NL then do; call ioa_$ioa_switch (iox_$user_io, "^a", substr (error_msg, idx2, idx3 - idx2)); idx2 = idx3 + 1; end; end; end; /* no need to free it as the area is in automatic */ /* Invoke the action command line, call the listener, and restart */ if call_cp_sw then call cu_$cp (action_ptr, action_lth, (0)); invocation_depth = old_invocation_depth; if call_cl_sw then do; on any_other system; call cu_$cl ((36)"0"b); revert any_other; end; if restart_sw then if info_ptr = null () then return; /* can probably restart */ else if software_data.cant_restart then call ioa_$ioa_switch (iox_$user_io, "on: Can not restart ""^a"".", condition_name); else return; if retry_sw then /* Try the command line again */ goto RETRY_COMMAND; go to RETURN; /* abort */ end handler; end on;  prepare_mc_restart_.pl1 11/04/82 1946.6rew 11/04/82 1625.1 56439 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ prepare_mc_restart_: proc (amcptr, code); /* PREPARE_MC_RESTART_ - Modify machine conditions and insure that control unit can be restored. This program has four entry points: prepare_mc_restart_ Just check machine conditions. prepare_mc_restart_$retry Make faulting instruction retry from the beginning. prepare_mc_restart_$replace Replace faulting instruction with argument, then . continue in sequence. prepare_mc_restart_$tra Restart execution at some other location in virtual memory. THVV */ /* parameters */ dcl amcptr ptr, /* ptr to machine conditions */ code fixed bin (35); /* err code */ /* automatic */ dcl dummy ptr; /* Temporary ptr for $tra check */ dcl (high, low) fixed bin; /* Current segment number maxima */ /* based */ dcl 1 dum aligned based (addr (dummy)), /* Overlay for a pointer. */ 2 xxw bit (3) unal, 2 segno bit (15) unal, /* .. segment number */ 2 ring bit (3) unal, /* .. ring number */ 2 xxx bit (9) unal, 2 its bit (6) unal, /* .. ITS modifier */ 2 offset bit (18) unal, /* .. segment address */ 2 xxy bit (3) unal, 2 bit_offset bit (6) unal, /* .. bit offset */ 2 xxz bit (3) unal, 2 mod bit (6) unal; /* .. further indirection */ /* external static */ dcl error_table_$bad_arg_acc fixed bin (35) ext, /* Return if bad mcptr */ error_table_$no_restart fixed bin (35) ext, /* Return if mc are illegal. */ error_table_$bad_ptr fixed bin (35) ext; /* Return if restart loc is unlegal. */ /* entries */ dcl hcs_$high_low_seg_count entry (fixed bin, fixed bin); /* Obtain size of address space from KST */ dcl get_ring_ entry () returns (fixed bin); /* Obtain current execution ring. */ /* builtins */ dcl (addr, fixed, null) builtin; /* include files */ %include mc; /* ======================================================= */ call check_mc; /* All he wants is a check of mach cond. */ if code ^= 0 then return; /* If there is an error. */ return; /* Restart is plausible. */ /* ------------------------------------------------------ */ retry: entry (amcptr, code); call check_mc; /* Check machine cond. */ if code ^= 0 then return; /* Give up if no good. */ scu.rfi = "1"b; /* Refetch the instruction. */ scu.if = "1"b; /* ... */ return; /* ------------------------------------------------------ */ replace: entry (amcptr, new_instr, code); dcl new_instr bit (36); /* The instruction to replace faulting instr. */ call check_mc; /* Make sure valid machine cond. */ if code ^= 0 then return; /* Die if no good. */ scu.rfi = "0"b; /* No refetch instruction. */ scu.if = "0"b; /* Fault not in instruction fetch (so I buffer is good) */ scu.even_inst = new_instr; /* Replace instruction */ return; /* ------------------------------------------------------ */ tra: entry (amcptr, newppr, code); dcl newppr ptr; /* New execution point desired. */ call check_mc; /* Validate machine conditions. */ if code ^= 0 then return; /* Error if no good. */ dummy = newppr; /* Copy pointer. */ if fixed (dum.segno, 15) > low + high then do; /* Check segment which is target of transfer. */ ilret: code = error_table_$bad_ptr; /* Nasty. This would cause a segment fault. */ return; end; if dum.its ^= "100011"b then go to ilret; /* Our argument should be a regular pointer. */ if dum.ring ^= scu.ppr.prr then go to ilret; /* Don't change rings. */ if dum.bit_offset then go to ilret; /* Silly, can't start in middle of a word. */ if dum.mod then go to ilret; /* This program does not handle further indirection. */ scu.ppr.psr = dum.segno; /* Copy segment number. */ scu.ilc = dum.offset; /* Copy offset. */ scu.rfi = "1"b; /* Invalidate I buffer, so next instruction will be */ scu.if = "1"b; /* .. pulled from memory. */ return; /* ======================================================= */ check_mc: proc; dcl i fixed bin; mcp = amcptr; /* Copy user machine cond ptr. */ code = error_table_$bad_arg_acc; /* Assume failure. */ if mcp = null then return; /* Die right away if he has no machine cond. */ scup = addr (mc.scu); /* Get ptr to SCU data. */ code = error_table_$no_restart; /* Assume mc are garbage. */ call hcs_$high_low_seg_count (low, high); /* Get address space range. */ do i = 0 to 7; /* First check the PR's. */ dummy = prs (i); /* Each should be an ITS */ if dum.its ^= "100011"b then return; /* ... */ if dum.mod then return; /* .. and have no junk. */ end; if fixed (dum.segno, 15) > low + high then return; /* Validate SB */ if fixed (scu.ppr.prr, 3) ^= get_ring_ () then return; /* Forbid ring switches. */ if ^(scu.cu.rpt|scu.cu.rd) then go to ok1; /* Check repeat-double bits. Must have 0 or 1 */ if ^(scu.cu.rpt|scu.cu.rl) then go to ok1; /* .. */ if ^(scu.cu.rd|scu.cu.rl) then go to ok1; /* .. */ return; /* Bad. Has two repeat bits on at once. CPU wd hang. */ ok1: if scu.cu.xde then if scu.cu.xdo then return; /* Cannot have both XDE and XDO. Hangs CPU */ if scu.cu.pot then if scu.cu.pon then return; /* Similarly here. No IT with returns. */ if scu.ir.abs then return; /* No absolute mode. */ if scu.ppr.p then return; /* No return into privileged procedure. */ if scu.ir.parm then return; /* User not to mask parity. */ if fixed (scu.ppr.psr, 15) > low + high then return; /* Validate ppr. */ if fixed (scu.tpr.tsr, 15) > low + high then return; /* Validate tpr. */ code = 0; /* Success. Machine conditions look pretty good. */ end check_mc; end prepare_mc_restart_;  program_interrupt.pl1 09/15/88 1347.5rew 09/15/88 1340.4 38979 /****^ *********************************************************** * * * 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(88-08-29,TLNguyen), approve(88-08-29,MCR7961), audit(88-09-13,Parisek), install(88-09-15,MR12.2-1110): Call the cu_$af_return_arg to report error when users attempt to run the program_interrupt as an active function. END HISTORY COMMENTS */ /* format: style2 */ program_interrupt: pi: procedure; /* initially coded in February 1970 by V. Voydock */ /* modified on February 8, 1970 at 3:50 P. M. by V. Voydock */ /* Modified 761026 by PG to convert to Version 2 PL/I */ /* Changed to use info structure by B. Margulies, July, 1981 */ /* the purpose of this program is to allow users of editors, subsystems and other complicated programs to "interrupt" that program and re-enter it at a known place. To make use of program_interrupt, a program must establish a condition handler for the condition "program_interrupt". When the user wishes to "interrupt" a program he presses the "quit" button and types "program_interrupt" or "pi". For example, suppose qedx had a handler for "program_interrupt" which when it was entered, stopped whatever the editor was doing and looked for a request from the console. Then a user of qedx who inadvertantly typed "1,$p" could kill this printout by hitting "quit" and then typing "pi" */ %include condition_info_header; %include program_interrupt_info; /* entries */ dcl (active_fnc_err_, com_err_) entry () options (variable); dcl cu_$af_return_arg entry (fixed bin, pointer, fixed bin (21), fixed bin (35)); dcl signal_ entry () options (variable); dcl start entry options (variable); /* automatic */ dcl code fixed bin (35); declare 1 pi_info aligned like program_interrupt_info automatic; /* builtin */ declare (addr, currentsize, null,string) builtin; pi_info.version = program_interrupt_info_version_1; pi_info.length = currentsize (pi_info); string (pi_info.action_flags) = ""b; /* We expect the default handler to have a special case for this condition, that sets the "default_handler_restarted" bit and then returns. just in case this gets signalled under a handler that does not grok this protocol, we set neither default restart nor quiet restart, so that the user gets up to level 2, as today. */ pi_info.info_string = ""; /* avoid spurious messages */ pi_info.status_code = 0; pi_info.default_handler_restarted_this_signal = "0"b; code = 0; call cu_$af_return_arg ((0), null (), (0), code); /* report an error when the pi command is invoked as an active function */ if code = 0 then do; call active_fnc_err_ (code, program_interrupt_condition_name, "This command cannot be invoked as an active function."); return; end; call signal_ (program_interrupt_condition_name, null () /* no mc */, addr (pi_info)); /* the program_interrupt protocol allowed programs to restart the signal, after noting that it had gone by, rather than doing a nonlocal go to from the handler. To compatably support this, we depend on the default handler to set a bit saying that no user program caught and restarted the signal. If one did, then we call the start command, to kick things off again. */ if ^pi_info.default_handler_restarted_this_signal then call start; /* this does not return! */ call com_err_ (0, "program_interrupt", "There is no suspended invocation of a subsystem that supports the use of this command."); return; end program_interrupt;  progress.pl1 02/06/84 1044.2r 02/06/84 1041.6 66861 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ progress: pg: proc; /* The progress command concatenates its arguments, and executes them as a command line. While executing it, progress (pg) prints out the progress of the process - the cpu time used since starting, and percent of real time. It also gives an indication of paging activity (page faults per second of cpu time). Originally written Jan 1973 by Dan Bricklin. Modified by M.A.Meer Oct 1975 to fix brief bug and allow long command lines. Modified 761026 by PG to switch to iox_. */ dcl addr builtin, arg char (arglen) based (argp) unaligned, arg_list_ptr ptr, arglen fixed bin, argno fixed bin, argp ptr, briefsw bit (1), cleanup condition, clock_ entry returns (fixed bin (71)), code fixed bin (35), com_err_ entry options (variable), cpu_delta1 float bin, cpu_delta2 float bin, cpu_percent1 float bin, cpu_percent2 float bin, cpu_sw bit (1) int static init ("1"b), cpu_time_and_paging_ entry (fixed bin, fixed bin (71), fixed bin), cput1 fixed bin (71), cput2 fixed bin (71), cput3 fixed bin (71), cu_$arg_list_ptr entry (ptr), cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)), cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr), cu_$cp entry (ptr, fixed bin, fixed bin (35)), cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)), divide builtin, error_table_$badopt fixed bin (35) ext, farg fixed bin, i fixed bin, io_switch ptr int static init (null), ioa_$ioa_switch entry options (variable), iox_$look_iocb entry (char (*), ptr, fixed bin (35)), iox_$user_io ptr external static, len fixed bin, line char (256) init (" "), line_len fixed bin, max builtin, null builtin, on_sw bit (1) int static init ("1"b), pf_per_sec float bin, pf1 fixed bin, pf2 fixed bin, pf3 fixed bin, pp1 fixed bin, pp2 fixed bin, pp3 fixed bin, real_delta1 float bin, real_delta2 float bin, realt1 fixed bin (71), realt2 fixed bin (71), realt3 fixed bin (71), (index, substr) builtin, time_between_calls fixed bin (71) int static init (10000000), timer_manager_$alarm_call entry (fixed bin (71), bit (2), entry), timer_manager_$cpu_call entry (fixed bin (71), bit (2), entry), timer_manager_$reset_alarm_call entry (entry), timer_manager_$reset_cpu_call entry (entry); /* program */ briefsw = "0"b; /* we don't start in brief, usually */ if io_switch = null then io_switch = iox_$user_io; call cu_$arg_ptr (1, argp, arglen, code); /* see if we have any options */ if code = 0 then if index (arg, "-") = 1 then do; if arg = "-brief" | arg = "-bf" then do; briefsw = "1"b; argno = 1; go to common; end; if arg = "-increment" | arg = "-ic" then go to get_delta; if arg = "-os" | arg = "-output_switch" | arg = "-output_stream" then do; call cu_$arg_ptr (2, argp, arglen, code); if code ^= 0 then do; call com_err_ (code, "progress", "Switchname missing."); return; end; call iox_$look_iocb (arg, io_switch, code); if code ^= 0 then do; call com_err_ (code, "progress", "^a", arg); return; end; return; end; if arg = "-on" then do; on_sw = "1"b; return; end; if arg = "-off" then do; on_sw = "0"b; return; end; if arg = "-cput" then do; cpu_sw = "1"b; go to get_delta; end; if arg = "-realt" then do; cpu_sw = "0"b; go to get_delta; end; call com_err_ (error_table_$badopt, "progress", arg); return; end; argno = 0; common: on_sw = "1"b; /* print interval messages */ on cleanup call cleanup_handler; /* what to do on cleanup */ line_len = 0; farg = argno + 1; /* keep index of first non option arg */ loop: argno = argno + 1; call cu_$arg_ptr (argno, argp, arglen, code); if code = 0 then do; line_len = line_len + arglen + 1; go to loop; end; call cu_$arg_list_ptr (arg_list_ptr); begin; /* allow long line */ dcl line char (line_len) aligned init (""); len = 1; /* index to insert chars */ do i = farg to argno - 1; call cu_$arg_ptr_rel (i, argp, arglen, code, arg_list_ptr); substr (line, len, arglen) = arg; len = len + arglen + 1; end; call cpu_time_and_paging_ (pf1, cput1, pp1); /* get initial time values */ realt1 = clock_ (); pf2 = pf1; cput2 = cput1; pp2 = pp1; realt2 = realt1; if ^briefsw then if cpu_sw then call timer_manager_$cpu_call (cput1 + time_between_calls, "00"b, interval); else call timer_manager_$alarm_call (realt1 + time_between_calls, "00"b, interval); call cu_$cp (addr (line), line_len, code); if ^briefsw then if cpu_sw then call timer_manager_$reset_cpu_call (interval); else call timer_manager_$reset_alarm_call (interval); call cpu_time_and_paging_ (pf3, cput3, pp3); realt3 = clock_ (); cpu_delta1 = float (cput3 - cput1)/1000000.0; real_delta1 = float (realt3 - realt1)/1000000.0; cpu_percent1 = float (100 * cpu_delta1)/real_delta1; pf_per_sec = float (pf3 - pf1)/cpu_delta1; call ioa_$ioa_switch (io_switch, "finished: ^.2f/^.2f = ^.2f% (^.2f (^f))", cpu_delta1, real_delta1, cpu_percent1, pf_per_sec, pf3-pf1); end; return; /* this option changes the time between calls */ get_delta: call cu_$arg_ptr (2, argp, arglen, code); if code ^= 0 then do; call com_err_ (code, "progress", "This argument is the time interval in seconds."); return; end; i = cv_dec_check_ (arg, code); if code ^= 0 then do; call com_err_ (0, "progress", "Bad number: ^a", arg); return; end; time_between_calls = 1000000 * i; return; cleanup_handler: proc; if cpu_sw then call timer_manager_$reset_cpu_call (interval); else call timer_manager_$reset_alarm_call (interval); return; end; interval: proc; call cpu_time_and_paging_ (pf3, cput3, pp3); realt3 = clock_ (); cpu_delta1 = float (cput3 - cput1)/1000000.0; real_delta1 = float (realt3 - realt1)/1000000.0; cpu_percent1 = float (100 * cpu_delta1)/real_delta1; cpu_delta2 = float (cput3 - cput2)/1000000.0; real_delta2 = float (realt3 - realt2)/1000000.0; cpu_percent2 = float (100 * cpu_delta2)/real_delta2; pf_per_sec = float (pf3 - pf2)/cpu_delta2; if on_sw then call ioa_$ioa_switch (io_switch, "^.2f/^.2f = ^.2f%, ^.2f/^.2f = ^.2f% (^.2f (^f))", cpu_delta1, real_delta1, cpu_percent1, cpu_delta2, real_delta2, cpu_percent2, pf_per_sec, pf3-pf2); cput2 = cput3; pf2 = pf3; realt2 = realt3; pp2 = pp3; if cpu_sw then call timer_manager_$cpu_call (cput3 + time_between_calls, "00"b, interval); else call timer_manager_$alarm_call (realt3 + time_between_calls, "00"b, interval); return; end; end;  ready.pl1 11/04/82 1946.6rew 11/04/82 1625.1 13959 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ ready: rdy: procedure; /* Changed to print usage if called with args 06/10/80 S. Herbst */ /* automatic */ dcl 1 flags aligned, 2 ready_sw bit (1) unaligned, 2 pad bit (35) unaligned; /* builtins */ dcl string builtin; /* entries */ dcl com_err_$suppress_name entry options (variable); dcl cu_$arg_count entry returns (fixed bin); dcl (cu_$ready_proc, cu_$set_ready_mode) entry (1 aligned, 2 bit (1) unaligned, 2 bit (35) unaligned); /* program */ call check_usage ("ready"); string (flags) = "1"b; call cu_$ready_proc (flags); RETURN: return; ready_on: rdn: entry; call check_usage ("ready_on"); string (flags) = "1"b; call cu_$set_ready_mode (flags); return; ready_off: rdf: entry; call check_usage ("ready_off"); string (flags) = "0"b; call cu_$set_ready_mode (flags); return; /* */ check_usage: proc (A_name); dcl A_name char (*); if cu_$arg_count () > 0 then do; call com_err_$suppress_name (0, A_name, "Usage: ^a", A_name); go to RETURN; end; end check_usage; end ready;  reprint_error.pl1 11/04/82 1946.6rew 11/04/82 1625.1 52182 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ reprint_error: re: procedure; /* This procedure looks back in the stack for frames belonging to default_error_handler_ and calls default_error_handler_ with the argument list it has then. It would normally be used if one wanted his messages in a diferent mode (long instead of brief, etc.) */ /* initially coded by M. Weaver 13 July 1971 */ /* modified by M. Weaver 17 August 1971 */ /* modified by M. Weaver 28 January 1974 for change to condition frames */ /* Modified 761026 by PG to convert to iox_ */ /* modified 14 November 1979 by M. Weaver to make -depth work again */ /* conditions */ dcl cleanup condition; /* based */ dcl arg char (alng) based (aptr); /* so we can refer to our arguments */ dcl message char (mlng) based (mptr); /* to refer to message from condition_interpreter_ */ dcl sys_area area (1000) based (areap); /* to use in free statement */ /* automatic */ dcl (lngsw, depth, nd, i) fixed bin; dcl code fixed bin (35); dcl (alng, mlng) fixed bin (21); dcl argdh (100) fixed bin aligned; /* holds values */ dcl (allsw, depsw) bit (1) aligned init ("0"b); dcl (aptr, areap) ptr; dcl mptr ptr init (null); dcl verb char (3) aligned; dcl suf char (1) aligned; /* to distinguish singular error message */ /* entries */ dcl com_err_ entry options (variable); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl default_error_handler_$reprint_error_message_ entry (ptr, ptr, fixed bin (21), fixed bin, fixed bin, fixed bin (35)); dcl get_system_free_area_ entry (ptr); dcl ioa_$nnl entry options (variable); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); /* external static */ dcl ( iox_$user_output ptr, error_table_$badopt fixed bin (35) ) external static; /* internal static */ dcl me char (13) internal static init ("reprint_error") options (constant); /* builtin */ dcl (null, substr) builtin; /* program */ lngsw = 1; /* normal length message */ depth = 1; /* default is most recent frame */ nd = 1; argdh (1) = 1; i = 0; read: i = i + 1; call cu_$arg_ptr (i, aptr, alng, code); if code ^= 0 then go to process; /* have finished reading in args */ if substr (arg, 1, 1) = "-" then do; /* possible option */ if arg = "-brief" | arg = "-bf" then lngsw = 2; /* want brief message */ else if arg = "-long" | arg = "-lg" then lngsw = 3; else if arg = "-all" | arg = "-a" then allsw = "1"b; /* look at all deh frames */ else if arg = "-depth" | arg = "-dh" then do; /* process (one) depth count */ if depsw then do; /* don't allow more than 1 */ call com_err_ (0, me, "Only one depth may be specified at a time."); return; end; depsw = "1"b; /* indicate that we have found depth option */ i = i + 1; /* get next arg specially */ call cu_$arg_ptr (i, aptr, alng, code); /* get depth number */ if code ^= 0 then do; call com_err_ (code, me, "Missing depth number."); return; end; argdh (1) = cv_dec_check_ (arg, code); /* convert arg to numerical depth */ if code ^= 0 then do; call com_err_ (0, me, "Non-decimal digit in position ^d of ""^a"".", code, arg); return; end; end; else do; err: call com_err_ (error_table_$badopt, me, "^a", arg); return; end; go to read; /* get next argument */ end; else go to err; /* don't recognize numbers by themselves */ process: if allsw then do; /* want all depths; fill array as if they had been typed */ nd = 100; /* current maximum */ do i = 1 to 100; argdh (i) = i; end; end; call get_system_free_area_ (areap); /* get area for message */ on condition (cleanup) begin; if mptr ^= null then free message in (sys_area); /* always clean up area */ end; do i = 1 to nd; /* if depths are not given in monotonically increasing order, and not all of them exist, some messages may not get printed */ call default_error_handler_$reprint_error_message_ (areap, mptr, mlng, lngsw, argdh (i), code); if code = 0 then do; /* default_error_handler_ has no active frames */ call com_err_ (0, me, "There are no active condition frames."); return; end; else if code < argdh (i) then do; if code = -1 then go to end_loop; /* couldn't get info for this depth */ if ^allsw then do; if code = 1 then do; verb = "is"; suf = " "; end; else do; verb = "are"; suf = "s"; end; call com_err_ (0, me, "There ^a only ^d condition frame^a.", verb, code, suf); end; return; end; call ioa_$nnl ("^/depth ^d:^/", argdh (i)); /* print out depth number */ call iox_$put_chars (iox_$user_output, mptr, mlng, code); free message in (sys_area); /* clear to make room for the next */ mptr = null; /* so wont try to free before it gets reset */ end_loop: end; return; end;  reset_external_variables.pl1 11/20/86 1404.2rew 11/20/86 1142.4 96678 /****^ *********************************************************** * * * 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-11-12,Zwick), install(86-11-20,MR12.0-1222): change the parameters of list init END HISTORY COMMENTS */ reset_external_variables: rev: proc; /* This command resets or deletes selected external variables (*system link targets). */ /* coded October 1976 by M. Weaver */ /* modified October 1977 by Melanie Weaver to handle links snapped directly */ /* Modified November 12 1982 by T Oke to cleanup and handle Very Large Arrays */ /* Modified April 22 1983 by M. Weaver to remove references to init_info_ptr */ /* Modified October 26 1984 by M. Mabey to explicitly zero a variable that is initialized with list templates. This has to be done in reponse to a change in list_init_ which no longer zeros skipped over data. */ dcl (i, j, n, whox, alng, nnames, nprocessed, high_seg, hcscnt, nchars) fixed bin; dcl vsize fixed bin (35); dcl code fixed bin (35); dcl (fatal, deleted) bit (1) aligned; dcl (tp, np, aptr, vptr, lotptr, tnp, old_np, alp) ptr; dcl arg char (alng) based (aptr); dcl vname char (65); dcl me (2) char (25) static options (constant) init ("reset_external_variables", "delete_external_variables"); dcl variable (vsize) bit (36) based; dcl do_it entry () variable; dcl ( error_table_$badopt, error_table_$too_many_args, error_table_$bigarg ) ext fixed bin (35); dcl error_table_$noarg ext fixed bin (35); dcl (addr, addrel, baseno, bin, bit, fixed, hbound, lbound, null, ptr, rel, substr, stackbaseptr, unspec, empty) builtin; dcl (com_err_, ioa_) entry options (variable); dcl cu_$arg_count entry () returns (fixed bin); dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr); dcl cu_$arg_list_ptr entry () returns (ptr); dcl hcs_$high_low_seg_count entry (fixed bin, fixed bin); dcl delete_$ptr entry (ptr, bit (6), char (*), fixed bin (35)); dcl fortran_storage_manager_$free entry (ptr); 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 sys_info$max_seg_size fixed bin (35) external; whox = 1; do_it = reset_it; /* find out if there are any external variables */ join: code = 0; sb = ptr (addr (nnames), 0); tp = sb -> stack_header.sys_link_info_ptr; if tp = null then do; no_variables: call com_err_ (0, me (whox), "There are no external variables."); return; end; if tp -> variable_table_header.cur_num_of_variables < 1 then goto no_variables; lotptr = sb -> stack_header.lot_ptr; fatal = "0"b; nnames = 0; nprocessed = 0; alp = cu_$arg_list_ptr (); n = cu_$arg_count (); begin; dcl 1 list (n) aligned, 2 name char (65), 2 nsize fixed bin (17) unal, 2 found bit (1) unal, 2 pad bit (17) unal; /* process all the arguments */ do i = 1 to n; call cu_$arg_ptr_rel (i, aptr, alng, code, alp); if code ^= 0 then do; call com_err_ (code, me (whox), arg); fatal = "1"b; end; else if substr (arg, 1, 1) = "-" then do; if arg = "-unlabelled_common" | arg = "-uc" then do; nnames = nnames + 1; list (nnames).name = "blnk*com"; list (nnames).nsize = 8; list (nnames).found = "0"b; end; else do; call com_err_ (error_table_$badopt, me (whox), arg); fatal = "1"b; end; end; else do; nnames = nnames + 1; if nnames > hbound (list, 1) then do; call com_err_ (error_table_$too_many_args, me (whox), "^d names maximum", hbound (list, 1)); return; end; if alng > 65 then do; call com_err_ (error_table_$bigarg, me (whox), arg); fatal = "1"b; end; list (nnames).name = arg; list (nnames).nsize = alng; list (nnames).found = "0"b; end; end; if fatal then return; if nnames = 0 then do; call com_err_ (error_table_$noarg, me (whox)); return; end; /* loop through system name list, printing info for desired variables */ do i = lbound (tp -> variable_table_header.hash_table, 1) to hbound (tp -> variable_table_header.hash_table, 1); old_np = addr (tp -> variable_table_header.hash_table (i)); tnp = tp -> variable_table_header.hash_table (i); do while (tnp ^= null); deleted = "0"b; np = tnp; tnp = np -> variable_node.forward_thread; /* update now in case node gets deleted */ do j = 1 to nnames; /* see if this name matches any on list */ if ^list (j).found then do; if list (j).nsize = np -> variable_node.name_size then if list (j).name = np -> variable_node.name then do; call do_it; list (j).found = "1"b; nprocessed = nprocessed + 1; if nprocessed = nnames then return; go to next_name; end; end; end; next_name: if ^deleted then old_np = np; /* current node didn't get deleted */ end; end; call ioa_ ("^/The following variables were not found:"); do i = 1 to nnames; if ^list (i).found then do; if list (i).name = "blnk*com" then vname = "unlabelled common"; else vname = list (i).name; call ioa_ ("^a", vname); end; end; end; /* of begin block */ return; delete_external_variables: dev: entry; whox = 2; do_it = delete_it; call hcs_$high_low_seg_count (high_seg, hcscnt); goto join; /* */ reset_it: proc; dcl code fixed bin (35); %include system_link_init_info; dcl based_vbl_area area (vsize) based; code = 0; if (np -> variable_node.init_type = TEMPLATE_INIT) & (np -> variable_node.init_ptr = null) then do; /* this will not happen with blank common */ call com_err_ (0, me (whox), "External variable ^a could not be reset.", np -> variable_node.name); return; end; vsize = np -> variable_node.vbl_size; if np -> variable_node.init_type = NO_INIT then call list_init_ (np -> variable_node.vbl_ptr, null (), vsize,stackbaseptr(),null(), code); else if np -> variable_node.init_type = EMPTY_AREA_INIT then np -> variable_node.vbl_ptr -> based_vbl_area = empty; else if np -> variable_node.init_type = LIST_TEMPLATE_INIT then do; /* First the variable is zeroed. */ call list_init_ (np -> variable_node.vbl_ptr, null (), vsize, stackbaseptr(),null(), code); /* Then it is initialized. */ call list_init_$variable_already_zero ( np -> variable_node.vbl_ptr, addr (np -> variable_node.init_ptr -> list_init_info.template), vsize, stackbaseptr(), np ->variable_node.seg_ptr, code); end; else unspec (np -> variable_node.vbl_ptr -> variable) = unspec (np -> variable_node.init_ptr -> init_info.init_template); if code ^= 0 then call com_err_ (code,me," while referencing ^a", np->variable_node.name); return; end; /* of reset_it */ /* */ delete_it: proc; dcl based_ptr ptr based; dcl based_area area based; dcl based_double bit (72) aligned based; dcl block_end bit (18) aligned; dcl code fixed bin (35); dcl (headptr, defstartptr, linkstartptr, itsptr, vlp, lptr) ptr; dcl segno fixed bin; %include its; %include lot; code = 0; vptr = np -> variable_node.vbl_ptr; /* get value links would have */ do segno = hcscnt + 1 to hcscnt + high_seg; if rel (lotptr -> lot.lp (segno)) ^= "0"b then do; headptr = lotptr -> lot.lp (segno); defstartptr = headptr -> header.def_ptr; /* pointer to beginning of def section */ linkstartptr = addrel (headptr, headptr -> header.stats.begin_links); /* pointer to beginning of 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 end of block are the same */ do itsptr = linkstartptr repeat (addrel (itsptr, 2)) /* loop through all links */ while (bin (rel (itsptr), 18) < bin (block_end, 18)); if itsptr -> its.its_mod = "100011"b then do; /* see if link is snapped */ lptr = itsptr -> based_ptr; /* do ptr copy to pick up any indirection */ if lptr = vptr then do; 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; 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 */ then call delete_$ptr (np -> variable_node.vbl_ptr, "010100"b, me (whox), code); else free np -> variable_node.vbl_ptr -> variable in (sb -> stack_header.user_free_ptr -> based_area); tp -> variable_table_header.total_allocated_size = tp -> variable_table_header.total_allocated_size - vsize; nchars = np -> variable_node.name_size; /* set so that free will work correctly */ old_np -> variable_node.forward_thread = tnp; /* thread around node to be deleted */ free np -> variable_node in (sb -> stack_header.system_free_ptr -> based_area); tp -> variable_table_header.cur_num_of_variables = tp -> variable_table_header.cur_num_of_variables - 1; deleted = "1"b; return; end; /* of delete_it */ %page; /* Include Files */ %include system_link_names; %page; %include stack_header; %page; %include linkdcl; end;  resolve_linkage_error.pl1 02/06/84 0949.6r 02/06/84 0948.4 42885 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ resolve_linkage_error: rle: proc; /* RESOLVE_LINKAGE_ERROR - satisfy a linkage_error with a specified pointer. THVV 2/77, after Max Smith */ /* Usage message added 11/02/79 S. Herbst */ /* Modified 7 Nov 83 by C Spitzer. use cv_ptr_ if cv_entry_ fails. Maybe not an object segment */ dcl argl fixed bin, /* length of arg */ bchr char (argl) based (tp) unal, /* for looking at argument */ argno fixed bin, /* steps thru argument list to command */ stackp ptr, /* pointer to rle's stack frame */ p ptr, /* ptr to user proc */ entry_to_use entry variable, link_pair_ptr ptr, /* ptr to linkage fault */ faultsp ptr, tp ptr, /* work pointer */ got_entry bit (1), ec fixed bin (35); /* system error code */ dcl (addr, baseno, baseptr, null, ptr, rel) builtin; dcl 1 instr (0:1) based aligned, 2 address bit (18) unal, 2 op_code bit (12) unal, 2 mod bit (6) unal; dcl 1 condinfo aligned, /* return struc from find_condition_info_ */ 2 mcptr ptr, 2 version fixed bin, 2 condition_name char (32) var, 2 infoptr ptr, 2 wcptr ptr, 2 loc_ptr ptr, 2 flags, 3 crawlout bit (1) unal, 3 pad1 bit (35) unal, 2 user_loc_ptr ptr, 2 pad (4) bit (36); dcl 1 link based (link_pair_ptr) aligned, 2 tbr bit (18) unal, 2 xx bit (12) unal, 2 ft bit (6) unal, 2 ca bit (18) unal, 2 xx1 bit (18) unal; dcl 1 based_entry_overlay based (addr (entry_to_use)) aligned, 2 procedure_ptr ptr, 2 stack_ptr ptr; dcl error_table_$no_linkage fixed bin(35) ext static; dcl (com_err_, com_err_$suppress_name) entry options (variable), find_condition_frame_ entry (ptr) returns (ptr), cv_entry_ entry (char (*), ptr, fixed bin (35)) returns (entry), cv_ptr_ entry (char(*), fixed bin(35)) returns(ptr), prepare_mc_restart_ entry (ptr, fixed bin (35)), find_condition_info_ entry (ptr, ptr, fixed bin (35)), cu_$stack_frame_ptr entry (ptr), cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); /* ======================================================= */ call cu_$stack_frame_ptr (stackp); /* get current stack pointer */ condinfo.version = 1; ec = 0; got_entry = "0"b; do argno = 1 by 1 while (ec = 0); call cu_$arg_ptr (argno, tp, argl, ec); /* look at all arguments */ if ec = 0 then do; if got_entry then do; USAGE: call com_err_$suppress_name (0, "resolve_linkage_error", "Usage: resolve_linkage_error virtual_entry"); return; end; got_entry = "1"b; entry_to_use = cv_entry_ (bchr, null, ec); if ec ^= 0 then do; if ec = error_table_$no_linkage then do; p = cv_ptr_ (bchr, ec); if ec ^= 0 then goto nent; end; else do; nent: call com_err_ (ec, "resolve_linkage_error", "cannot locate ^a", bchr); return; end; end; else do; p = based_entry_overlay.procedure_ptr; if p = null then go to nent; end; end; end; if ^got_entry then go to USAGE; loop: faultsp = find_condition_frame_ (stackp); /* Search for fault frame. */ if faultsp = null then do; /* .. error if not found */ call com_err_ (0, "resolve_linkage_error", "no linkage fault on stack"); return; end; call find_condition_info_ (faultsp, addr (condinfo), ec); /* Decode the frame */ if condinfo.condition_name = "linkage_error" then do; scup = addr (condinfo.mcptr -> mc.scu); /* Found linkage error. */ link_pair_ptr = ptr (baseptr ("000"b || scu.tpr.tsr), scu.ca); /* Locate link */ if link.ft ^= "46"b3 then do; /* Check that it's really a link fault */ call com_err_ (0, "resolve_linkage_error", "Link pair at ^p lacks FT2 modifier. No change.", link_pair_ptr); return; end; link.tbr = baseno (p); /* Patch link to be entry found above */ link.ca = rel (p); link.ft = "43"b3; /* Over-write fault tag 2 */ call prepare_mc_restart_ (condinfo.mcptr, ec); /* Check that MC are restartable */ if ec ^= 0 then call com_err_ (ec, "resolve_linkage_error", ""); return; /* Success */ end; stackp = faultsp; /* Wrong fault frame */ go to loop; %include mc; end resolve_linkage_error;  set_severity_indicator.pl1 11/20/86 1404.2r w 11/20/86 1142.6 42246 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ set_severity_indicator: ssi: proc (); /* This command sets a specified severity indicator. Usage: ssi severity_indicator indicator_value where severity_indicator is the name of the severity indicator to be set to the indicator value specified. Written 5/6/80 by Michael R. Jordan Modified for installation 5/81 by Michael R. Jordan. */ /* CONSTANTS */ dcl ME char (22) static options (constant) init ("set_severity_indicator"); /* STATIC DATA */ /* AUTOMATIC */ dcl found bit (1) aligned; /* ON => variable was found */ dcl node_ptr ptr; /* ptr to variable node */ dcl code fixed bin (35); /* error code */ dcl nargs fixed bin; /* number of command arguments supplied */ dcl arg_ptr ptr; /* ptr to arg */ dcl arg_len fixed bin; /* length of arg */ dcl indicator_name char (22); /* severity indicator name */ dcl 1 my_init_info like init_info_single_word; /* BASED */ dcl arg char (arg_len) based (arg_ptr); /* a command line argument */ dcl severity_indicator fixed bin (35) aligned based; /* EXTERNAL ENTRIES */ dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl set_ext_variable_ entry (char (*), ptr, ptr, bit (1) aligned, ptr, fixed bin (35)); dcl com_err_ entry options (variable); /* ERROR CODES */ dcl error_table_$bad_arg fixed bin (35) ext; dcl error_table_$wrong_no_of_args fixed bin (35) ext; dcl error_table_$bigarg fixed bin (35) ext; /* BUILTINS and CONDITIONS */ dcl addr builtin; dcl length builtin; dcl rtrim builtin; dcl stackbaseptr builtin; my_init_info.size = 1; my_init_info.type = TEMPLATE_INIT; my_init_info.init_template (1) = 0; /* Make sure there are the proper number of arguments. */ call cu_$arg_count (nargs); /* get number of args */ if nargs ^= 2 then do; code = error_table_$wrong_no_of_args; USAGE: call com_err_ (code, ME, "^/Usage: ^a indicator_name indicator_value", ME); return; end; /* First we must get the severity indicator name. We should also make sure it is a valid severity indicator name. */ call cu_$arg_ptr (1, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (code, ME, "Cannot get argument #1."); return; end; indicator_name = arg; if indicator_name ^= arg /* name too long */ then do; call com_err_ (error_table_$bigarg, ME, "^a^/The maximum length for a severity indicator name is ^d characters.", arg, length (indicator_name)); return; end; /* Next we should get the new value for the indicator. It must be a valid decimal integer. */ call cu_$arg_ptr (2, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (code, ME, "cannot get argument #2."); return; end; my_init_info.init_template (1) = cv_dec_check_ (arg, code); if code ^= 0 /* bad indicator value */ then do; call com_err_ (error_table_$bad_arg, ME, "^/Severity indicator value must be a decimal integer."); return; end; /* And, at last, we can attempt to create and set the indicator. If the indicator already exists we can try to reset it. If the data type 'seems' incompatible we will complain. (Note that in the current implementation the only check we can make is that the indicator is a one word value.) */ call set_ext_variable_ (rtrim (indicator_name) || "_severity_", addr (my_init_info), stackbaseptr (), found, node_ptr, code); if code ^= 0 then do; call com_err_ (code, ME, "^/Error setting the severity indicator ^a.", indicator_name); return; end; if found /* in this case we must reset the indicator */ then do; if node_ptr -> variable_node.vbl_size ^= 1 then do; call com_err_ (0b, ME, "Severity indicator ^a is not a single word variable.", indicator_name); return; end; node_ptr -> variable_node.vbl_ptr -> severity_indicator = my_init_info.init_template (1); end; return; %include system_link_init_info; %include system_link_names; end set_severity_indicator;  set_storage_ptrs.pl1 11/05/86 1215.9r w 11/04/86 1033.7 28098 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ set_storage_ptrs: proc; /* The entries in this command set area pointers in the stack header */ /* coded November 1976 by Melanie Weaver */ /* modified December 1976 by Melanie Weaver to check code properly after trying to set ptr */ /* Modified July 1979 by C. Hornig to add -create option. */ dcl address char (*); dcl whox fixed bin; dcl new_ptr ptr; dcl code fixed bin (35); dcl 1 ai aligned like area_info; dcl me (2) char (20) aligned options (constant) static init ("set_system_storage", "set_user_storage"); dcl com_err_ entry options (variable); dcl cu_$arg_count entry () returns (fixed bin); dcl cv_ptr_ entry (char (*), fixed bin (35)) returns (ptr); dcl cv_ptr_$terminate entry (ptr); dcl define_area_ entry (pointer, fixed bin (35)); dcl set_system_free_area_ entry (pointer); dcl set_user_free_area_ entry (pointer); dcl error_table_$noarg fixed bin (35) ext; dcl error_table_$badcall fixed bin (35) ext; dcl sys_info$max_seg_size fixed bin (19) ext; dcl (addr, null, ptr, stackframeptr) builtin; %include stack_header; %include area_info; %include area_structures; set_user_storage: entry (address); whox = 2; goto join; set_system_storage: entry (address); whox = 1; join: if cu_$arg_count () ^= 1 then do; call com_err_ (0, me (whox), "Usage: ^a {-create | -system | {pointer}}", me (whox)); return; end; sb = ptr (stackframeptr (), 0); /* get ptr to base of stack */ if address = "-system" then new_ptr = sb -> stack_header.clr_ptr; else if address = "-create" then do; ai.version = area_info_version_1; string (ai.control) = ""b; ai.control.extend = "1"b; ai.control.zero_on_free = "1"b; ai.control.system = "1"b; ai.owner = me (whox); ai.size = sys_info$max_seg_size; ai.areap = null (); call define_area_ (addr (ai), code); if code ^= 0 then do; call com_err_ (code, me (whox), "Creating area."); return; end; new_ptr = ai.areap; end; else do; new_ptr = cv_ptr_ (address, code); if new_ptr = null then do; /* perhaps system entry should accept null */ if code = 0 then code = error_table_$badcall; call com_err_ (code, me (whox), address); return; end; if ^(new_ptr -> area_header.flags.zero_on_alloc | new_ptr -> area_header.flags.zero_on_free) then do; call com_err_ (0, me (whox), "Area must be either zero_on_free or zero_on_alloc."); call cv_ptr_$terminate (new_ptr); return; end; end; if whox = 2 then call set_user_free_area_ (new_ptr); else call set_system_free_area_ (new_ptr); return; end;  signal.pl1 02/06/84 1044.2r 02/06/84 1042.4 44064 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* a real command interface for signal. Finally. */ /* format: style2 */ signal: procedure options (variable); /* Coded 12/81 Benson I. Margulies */ declare signal_ entry (character (*), pointer, pointer, pointer); declare com_err_ entry () options (variable); declare cu_$arg_count entry (fixed bin, fixed bin (35)); declare cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); declare cv_ptr_ entry (character (*), fixed binary (35)) returns (pointer); declare cv_ptr_$terminate entry (pointer); declare argument_count fixed bin; declare argument_ptr pointer; declare argument_length fixed bin (21); declare argument character (argument_length) based (argument_ptr); declare argx fixed bin; declare error_ptr pointer; declare error_name character (256); declare based_error_code fixed bin (35) based (error_ptr); %include condition_info_header; declare 1 cih aligned like condition_info_header; declare condition_name character (256); declare code fixed bin (35); declare ( error_table_$badopt, error_table_$too_many_args, error_table_$noarg ) fixed bin (35) external static; declare ME character (32) init ("signal") internal static options (constant); declare cleanup condition; declare (unspec, substr, null, currentsize) builtin; call cu_$arg_count (argument_count, code); if code ^= 0 then do; call com_err_ (code, ME); return; end; if argument_count = 0 then do; call com_err_ (0, ME, "Usage: signal CONDITION -control_args"); return; end; error_ptr = null; on cleanup begin; if error_ptr ^= null then call cv_ptr_$terminate (error_ptr); end; condition_name = ""; unspec (cih) = ""b; cih.version = 1; cih.info_string = " "; cih.length = currentsize (cih); do argx = 1 to argument_count; call cu_$arg_ptr (argx, argument_ptr, argument_length, (0)); if substr (argument, 1, 1) ^= "-" then do; if condition_name ^= "" then do; call com_err_ (error_table_$too_many_args, ME, "Only one condition name may be given.") ; return; end; condition_name = argument; end; else if argument = "-info_string" then do; if cih.info_string ^= "" /* -info_string "" -info_string foo will work, which is likely wrong */ then do; call com_err_ (error_table_$too_many_args, ME, "Only one info_string may be given."); go to RETURN; end; if argx = argument_count then do; nostring: call com_err_ (error_table_$noarg, ME, "An info string must be supplied with -info_string."); go to RETURN; end; argx = argx + 1; call cu_$arg_ptr (argx, argument_ptr, argument_length, (0)); if substr (argument, 1, 1) = "-" then go to nostring; cih.info_string = argument; end; else if argument = "-code" then do; if argx = argument_count then do; nocode: call com_err_ (error_table_$noarg, ME, "An error table code must be supplied with -code."); go to RETURN; end; argx = argx + 1; call cu_$arg_ptr (argx, argument_ptr, argument_length, (0)); if substr (argument, 1, 1) = "-" then goto nocode; if index (argument, "$") = 0 then error_name = "error_table_$" || argument; else error_name = argument; error_ptr = cv_ptr_ (error_name, code); if code ^= 0 then do; call com_err_ (code, ME, "^a", error_name); return; end; cih.status_code = based_error_code; end; else if argument = "-cant_restart" then cih.cant_restart = "1"b; else if argument = "-default_restart" then cih.default_restart = "1"b; else if argument = "-quiet_restart" then cih.quiet_restart = "1"b; else if argument = "-support_signal" then cih.support_signal = "1"b; else do; call com_err_ (error_table_$badopt, ME, "^a", argument); go to RETURN; end; end; /* the loop */ if condition_name = "" then do; call com_err_ (error_table_$noarg, ME, "A condition name must be given."); RETURN: if error_ptr ^= null then call cv_ptr_$terminate (error_ptr); return; end; call signal_ (condition_name, null, addr (cih), null); go to RETURN; end signal;  system_type.pl1 11/04/82 1946.6rew 11/04/82 1624.8 25056 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ system_type: procedure () options (variable); /* * SYSTEM_TYPE * * Simple command/AF to canonicalize system type names, or return the * name for the type of the current system. * * 03/23/81, W. Olin Sibert */ dcl code fixed bin (35); dcl arg_count fixed bin; dcl arg char (arg_lth) based (arg_ptr); dcl arg_ptr pointer; dcl arg_lth fixed bin (21); dcl ret_str char (rs_lth) varying based (rs_ptr); dcl rs_ptr pointer; dcl rs_lth fixed bin (21); dcl af_sw bit (1) aligned; dcl input_name char (32); dcl output_name char (32); dcl type fixed bin; dcl active_fnc_err_ entry options (variable); dcl com_err_ entry options (variable); dcl cu_$af_return_arg entry (fixed bin, pointer, fixed bin (21), fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, pointer, fixed bin (21), fixed bin (35)); dcl ioa_ entry options (variable); dcl system_type_ entry (char (*), char (*), fixed bin, fixed bin (35)); dcl error_table_$too_many_args fixed bin (35) external static; dcl WHOAMI char (32) internal static options (constant) init ("system_type"); /* */ call cu_$af_return_arg (arg_count, rs_ptr, rs_lth, code); af_sw = (code = 0); if af_sw then ret_str = ""; if arg_count > 1 then do; if af_sw then call active_fnc_err_ (error_table_$too_many_args, WHOAMI, "^/Usage:^-[^a {SystemName}]", WHOAMI); else call com_err_ (error_table_$too_many_args, WHOAMI, "^/Usage:^-^a {SystemName}", WHOAMI); return; /* Nothing more to do here */ end; if arg_count = 1 then do; /* Canonicalize a specified name */ call cu_$arg_ptr (1, arg_ptr, arg_lth, (0)); input_name = arg; end; else input_name = ""; /* Otherwise, depend on system_type_ for the default */ call system_type_ (input_name, output_name, type, code); if code ^= 0 then do; if af_sw then call active_fnc_err_ (code, WHOAMI, """^a""", input_name); else call com_err_ (code, WHOAMI, """^a""", input_name); return; end; if ^af_sw then /* Print it out */ if (input_name = "") then call ioa_ ("Current system:^-^a", output_name); else call ioa_ ("Canonical name:^-^a", output_name); else ret_str = output_name; /* Otherwise, just return it */ return; end system_type;  system_type_.pl1 11/04/82 1946.6rew 11/04/82 1625.2 25056 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ system_type_: proc (P_name, P_canonical_name, P_type, P_code); /* * SYSTEM_TYPE_ * * This is the subroutine used to canonicalize the values of the operands of * the "-target" control argument, and of the ALM "decor" pseudo-op. * * 03/23/81, W. Olin Sibert */ dcl P_name char (*) parameter; /* Input: user-specified system type name */ dcl P_canonical_name char (*) parameter; /* Output: canonical name for this system type */ dcl P_type fixed bin parameter; /* Output: integer value of this system type */ dcl P_code fixed bin (35) parameter; /* Output: error code */ dcl name char (32); dcl type fixed bin; dcl sys_info$system_type fixed bin external static; dcl error_table_$invalid_system_type fixed bin (35) external static; dcl LC_ALPHA char (26) internal static options (constant) init ("abcdefghijklmnopqrstuvwxyz"); dcl UC_ALPHA char (26) internal static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); dcl translate builtin; /* */ name = translate (P_name, LC_ALPHA, UC_ALPHA); if (name = "") then type = sys_info$system_type; /* Default */ else if (name = "l68") then type = L68_SYSTEM; /* Various names for Level 68 */ else if (name = "dps") then type = L68_SYSTEM; else if (name = "dps2") then type = L68_SYSTEM; else if (name = "level68") then type = L68_SYSTEM; else if (name = "level_68") then type = L68_SYSTEM; else if (name = "6180") then type = L68_SYSTEM; else if (name = "6880") then type = L68_SYSTEM; else if (name = "68/80") then type = L68_SYSTEM; else if (name = "dpse") then type = L68_SYSTEM; /* DPS-8 is the same as Level 68 */ else if (name = "dps8") then type = L68_SYSTEM; else if (name = "dps-8") then type = L68_SYSTEM; else if (name = "8/70") then type = L68_SYSTEM; else if (name = "dps8/70") then type = L68_SYSTEM; else if (name = "dps-8/70") then type = L68_SYSTEM; else if (name = "adp") then type = ADP_SYSTEM; /* The Next Generation */ else if (name = "orion") then type = ADP_SYSTEM; else do; P_canonical_name = "???"; P_type = -1; P_code = error_table_$invalid_system_type; return; end; P_canonical_name = SYSTEM_TYPE_NAME (type); P_type = type; P_code = 0; return; %page; %include system_types; end system_type_; 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