



		    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
