



		    command_query_.pl1              11/11/89  1108.2r w 11/11/89  0804.2      240777



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

command_query_:
     procedure (qip, varying_answer);

/* BEGIN DESCRIPTION */

/* function: */

/* The standard procedure to ask a question and read the user's answer: the question is formatted and the condition
   "command_question" is signalled allowing for programs like "answer" to supply answers automatically; the
   "repeat_query" command is also contained herein to reask the last question */

/* history: */

/* Created:  September 1971 by Jerry Stern */
/* Modified: 15 September 1971 by Jerry Stern */
/* Modified: 20 November 1975 by Steve Herbst to add the repeat_query command */
/* Modified: 26 October 1976 by Paul Green to switch to iox_ (get it?) */
/* Modified: 13 June 1978 by Steve Herbst to add the temporary entry point user_io */
/* Modified: July 1978 by J. C. Whitmore to remove user_io entry in favor of extended info structures */
/* Modified: 11 August 1978 by W. O. Sibert to add cu_$cp escape feature and set_allow_cp_escape entrypoint */
/* Modified: 23 January 1979 by William M. York to fix overlength substr assignment bug (see MCR 3661), lengthen the
             internal buffers, and call iox_$put_chars directly, avoiding the 256 char ioa_ restriction */
/* Modified: 7 September 1979 by Steve Herbst to signal command_query_error for bad answers in absentee */
/* Modified: 8 May 1981 by Steve Herbst to add command_query_$yes_no, the explanantion feature, and to accept y/n */
/* Modified: June 1981 by Benson Margulies to set the quiet_restart bit in condition structure */
/* Modified: 6 August 1981 by Richard Lamson to fix out-of-range version numbers in query_info structure */
/* Modified: 11 March 1982 by G. Palter to issue reset_more control order before asking questions */
/* Modified: 12/15/82 by S. Herbst to add literal_sw, prompt_after_explanation, and cp_escape_control value "01"b */
/* Modified: 02/08/84 by S. Herbst to check whether called with varying or nonvarying answer arg */
/* Modified: 02/08/84 by S. Herbst to change length fields in command_question_info.incl.pl1 from fixed to fixed (21) */
/* Modified: 03/27/84 by S. Herbst to say "Answer yes, no, or ? for an explanation" */
/* Modified: 06/14/84 by S. Herbst to call sub_err_ if error from iox_ writing question/reading answer */

/****^  HISTORY COMMENTS:
  1) change(85-03-01,Backs), approve(85-01-09,MCR7134),
     audit(85-03-01,RBarstad), install(86-03-05,MR12.0-1028):
     Changed command_query_ to accept case insensitive yes or no.
  2) change(88-09-14,Beattie), approve(88-10-06,MCR8006),
     audit(88-10-06,Farley), install(88-10-10,MR12.2-1155):
     Remove setting of answer variable length. It was trashing word in front
     of fixed length answer variables.  This is taken care of in the
     set_answer internal procedure. Check length of big_str before testing it
     from within a substr.
                                                   END HISTORY COMMENTS */

/* format: style4,delnl,insnl,ifthenstmt,ifthen */

%page;
/* PARAMETERS */

dcl  varying_answer character (*) varying parameter;
dcl  qip pointer parameter;
dcl  yes_sw bit (1) parameter;
dcl  A_query_code fixed binary (35) parameter;


/* CONSTANTS */

dcl  GRIPE1 character (27) static options (constant) initial
	("Please answer yes or no.   ");
dcl  GRIPE2 character (50) static options (constant) initial
	("Please answer yes, no, or ? for an explanation.   ");

dcl  NL character (1) static options (constant) initial ("
");
dcl  WHITE character (5) static options (constant) initial (/* SP HT VT FF NL */ " 	
");

dcl  LOWERCASE_YN character (5) static options (constant) initial ("yesno");
dcl  UPPERCASE_YN character (5) static options (constant) initial ("YESNO");

/* BASED */

dcl  alloc_str character (alloc_len) based (alloc_ptr);
dcl  big_str character (big_len) based (big_ptr);
dcl  callername character (question_info.name_lth) based (question_info.name_ptr);
dcl  explanation character (query_info.explanation_len) based (query_info.explanation_ptr);
dcl  fixed_answer char (fixed_answer_len) based (fixed_answer_ptr);
dcl  question character (question_info.question_lth) based (question_info.question_ptr);
dcl  nchars fixed binary (21) based;
dcl  area area based (area_ptr);

dcl  1 input_info aligned based (qip) like query_info;

/* AUTOMATIC */

dcl  1 question_info aligned like command_question_info;

dcl  retstring character (1000);
dcl  buffer character (1000) aligned;
dcl  output_buffer character (1004) aligned;
dcl  yn_answer character (500) aligned varying;
dcl  error_string character (100) aligned;

dcl  (alloc_sw, allow_cp_escape, fixed_answer_sw, interpret_cp_escape) bit (1) aligned;
dcl  (packed, saved_rflag, timer_set, yn_entry_sw) bit (1) aligned;

dcl  (alloc_ptr, area_ptr, alp, big_ptr, fixed_answer_ptr) pointer;

dcl  (abs_queue, arg_count, bi, callername_index, control_string_index, ndims, scale, type) fixed binary;
dcl  (alloc_len, big_len, fixed_answer_len, fixed21, len) fixed binary (21);
dcl  code fixed binary (35);

dcl  saved_rlabel label variable;

/* BUILTINS */

dcl  (addr, addrel, bin, bit, index, length, ltrim, max, maxlength, min, null, rtrim, size, substr, translate, unspec) builtin;

/* CONDITIONS */

dcl  cleanup condition;

/* EXTERNAL STATIC */

dcl  iox_$user_input pointer external;
dcl  iox_$user_io pointer external;
dcl  iox_$user_output pointer external;

dcl  error_table_$long_record fixed binary (35) external;

/* INTERNAL STATIC */

dcl  repeat_label label variable static;
dcl  repeat_flag bit (1) aligned initial ("0"b) static;

dcl  first_call bit (1) static initial ("1"b);
dcl  static_allow_cp_escape bit (1) aligned static initial ("0"b);

/* ENTRIES */

dcl  com_err_ entry () options (variable);
dcl  convert_status_code_ entry (fixed binary (35), character (8) aligned, character (100) aligned);
dcl  cu_$arg_count entry (fixed binary);
dcl  cu_$arg_list_ptr entry (pointer);
dcl  cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
dcl  cu_$cp entry (pointer, fixed binary (21), fixed binary (35));
dcl  decode_descriptor_
	entry (pointer, fixed binary, fixed binary, bit (1) aligned, fixed binary, fixed binary, fixed binary);
dcl  get_group_id_ entry () returns (character (32));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  ioa_$general_rs
	entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21), bit (1) aligned, bit (1) aligned);
dcl  ioa_$ioa_switch entry () options (variable);
dcl  ioa_$ioa_switch_nnl entry () options (variable);
dcl  iox_$control entry (pointer, character (*), pointer, fixed binary (35));
dcl  iox_$get_line entry (pointer, pointer, fixed binary (21), fixed binary (21), fixed binary (35));
dcl  iox_$put_chars entry (pointer, pointer, fixed binary (21), fixed binary (35));
dcl  signal_ entry (character (*), pointer, pointer, pointer);
dcl  sub_err_ entry () options (variable);
dcl  timer_manager_$alarm_call entry (fixed binary (71), bit (2) aligned, entry);
dcl  timer_manager_$reset_alarm_call entry (entry);
dcl  user_info_$absentee_queue entry (fixed binary);

%page;
/* BEGIN */

/* command_query_: entry (qip, varying_answer); */

	query_info.version = input_info.version;
	if query_info.version < 1 | query_info.version > 6 then do;
						/* Old programs are grandfathered */
	     query_info.version = 2;			/* Harmless version number */
	end;

	yn_entry_sw = "0"b;
	callername_index = 3;
	control_string_index = 4;
	query_info.yes_or_no_sw = input_info.yes_or_no_sw;/* copy the input data */
	query_info.suppress_name_sw = input_info.suppress_name_sw;
	query_info.status_code = input_info.status_code;
	query_info.query_code = input_info.query_code;

	if query_info.version >= 3 then do;		/* if more is defined, use it */
	     if query_info.version >= 4 then do;	/* use new bits */
		query_info.cp_escape_control = input_info.cp_escape_control;
		query_info.suppress_spacing = input_info.suppress_spacing;
		if query_info.version >= 5 then do;
		     query_info.explanation_len = input_info.explanation_len;
		     if query_info.explanation_len ^= 0 then query_info.explanation_ptr = input_info.explanation_ptr;
		     if query_info.version >= 6 then do;
			query_info.literal_sw = input_info.literal_sw;
			query_info.prompt_after_explanation = input_info.prompt_after_explanation;
		     end;
		end;
	     end;
	     query_info.question_iocbp = input_info.question_iocbp;
	     query_info.answer_iocbp = input_info.answer_iocbp;
	     query_info.repeat_time = input_info.repeat_time;
	end;

	if query_info.literal_sw | query_info.cp_escape_control = "01"b then do;
	     allow_cp_escape = "1"b;
	     interpret_cp_escape = "0"b;
	end;
	else if query_info.cp_escape_control = "11"b then allow_cp_escape, interpret_cp_escape = "1"b;
	else if query_info.cp_escape_control = "10"b then allow_cp_escape, interpret_cp_escape = "0"b;
	else allow_cp_escape, interpret_cp_escape = static_allow_cp_escape;

	go to COMMON;


/* format: off */
/* An easy-to-use entry which requires a yes/no answer:
	call command_query_$yes_no (yes_sw, status_code, callername, explanation, control_string, args...) */
/* format: on */

yes_no:
     entry (yes_sw, A_query_code);

	yn_entry_sw = "1"b;
	callername_index = 3;
	control_string_index = 5;
	unspec (query_info) = "0"b;
	query_info.yes_or_no_sw = "1"b;
	query_info.query_code = A_query_code;
	query_info.question_iocbp, query_info.answer_iocbp = null;
	allow_cp_escape, interpret_cp_escape = static_allow_cp_escape;


COMMON:
	if first_call then do;			/* be sure the labels are correctly defined */
	     repeat_label = ASK;			/* basis for saved label */
	     repeat_flag = "0"b;
	     first_call = "0"b;			/* done for this process */
	end;
	saved_rflag = repeat_flag;			/* save the state of any previous invocation */
	saved_rlabel = repeat_label;
	repeat_label = ASK;				/* redefine question repeat label to this block */
	repeat_flag = "0"b;				/* but a repeat is not defined yet */
	timer_set = "0"b;				/* no repeat timer set for this block */

	call cu_$arg_count (arg_count);
	call cu_$arg_list_ptr (alp);			/* get arglist ptr */

	if ^yn_entry_sw then do;			/* find out if answer arg is varying or non */
	     call decode_descriptor_ (alp, 2, type, packed, ndims, 0, scale);
	     fixed_answer_sw = (type = char_dtype);
	     if fixed_answer_sw then call cu_$arg_ptr (2, fixed_answer_ptr, fixed_answer_len, 0);
	end;

	call cu_$arg_ptr (callername_index, question_info.name_ptr, fixed21, 0);
	question_info.name_lth = fixed21;
	call decode_descriptor_ (alp, callername_index, type, packed, ndims, question_info.name_lth, scale);
						/* get data type & length of callername */
	if type = varying_char_dtype then		/* varying string, must get current length */
	     question_info.name_lth = addrel (question_info.name_ptr, -1) -> nchars;
						/* the kludge shows its face */

/* get callername */

	bi = 1;
	if ^query_info.suppress_name_sw then
	     if question_info.name_lth ^= 0 then do;	/* put caller name in buffer */
		buffer = rtrim (callername);
		if buffer ^= "" then do;
		     bi = length (rtrim (buffer)) + 3;
		     substr (buffer, bi - 2, 2) = ": ";
		end;
	     end;

/* Get query_code message and verbose explanation of question for $yes_no */

	if yn_entry_sw then do;
	     if A_query_code ^= 0 then do;
		call convert_status_code_ (A_query_code, "", error_string);
		buffer = substr (buffer, 1, bi - 1) || error_string;
		bi = bi + length (rtrim (error_string)) + 1;
		substr (buffer, bi - 1, 1) = " ";
	     end;
	     call cu_$arg_ptr (callername_index + 1, query_info.explanation_ptr, query_info.explanation_len, code);
	     if code ^= 0 | query_info.explanation_len = 0 then query_info.explanation_ptr = null;
	end;

/* get user message */

	if arg_count >= control_string_index then do;
	     call ioa_$general_rs (alp, control_string_index, control_string_index + 1, retstring, len, "0"b, "0"b);
	     len = min (len, length (buffer) - bi + 1);
	     substr (buffer, bi, len) = substr (retstring, 1, len);
	     bi = bi + len;
	end;

/* fill in question_info...which will be passed to the handler of the command_question condition. */

get_ready_to_signal:
	question_info.length = size (question_info);
	question_info.version = cq_info_version_7;
	question_info.action_flags.cant_restart = "0"b;
	question_info.action_flags.default_restart = "1"b;
	question_info.action_flags.quiet_restart = "1"b;
	question_info.status_code = query_info.status_code;
	question_info.query_code = query_info.query_code;
	question_info.question_sw = "1"b;		/* by default, print the question */
	question_info.yes_or_no_sw = query_info.yes_or_no_sw;
	question_info.preset_sw = "0"b;		/* don't expect a preset answer */
	question_info.answer_sw = "1"b;		/* but if one comes, print it by default */
	question_info.allow_cp_escape = allow_cp_escape;	/* computed earlier */
	question_info.suppress_spacing = query_info.suppress_spacing;
	question_info.interpret_cp_escape = interpret_cp_escape;
	question_info.literal_sw = query_info.literal_sw;
	question_info.prompt_after_explanation = query_info.prompt_after_explanation;
	question_info.max_question_lth = size (buffer);
	question_info.question_ptr = addr (buffer);
	question_info.question_lth = bi - 1;
	question_info.info_string = substr (buffer, 1, question_info.question_lth);
	if yn_entry_sw then do;
	     question_info.answer_ptr, big_ptr = addrel (addr (yn_answer), 1);
	     question_info.max_answer_lth = maxlength (yn_answer);
	end;
	else do;
	     if fixed_answer_sw then do;
		question_info.answer_ptr, big_ptr = fixed_answer_ptr;
		question_info.max_answer_lth = fixed_answer_len;
	     end;
	     else do;				/* varying answer, skip the length word */
		question_info.answer_ptr, big_ptr = addrel (addr (varying_answer), 1);
		question_info.max_answer_lth = maxlength (varying_answer);
	     end;
	end;
	question_info.question_iocbp = query_info.question_iocbp;
						/* give handler caller's output switch */
	question_info.answer_iocbp = query_info.answer_iocbp;
						/* and input switch */
	question_info.repeat_time = query_info.repeat_time;
						/* and also caller's repeat time */
	question_info.explanation_ptr = query_info.explanation_ptr;
	question_info.explanation_len = query_info.explanation_len;

	alloc_ptr = null;

/* signal command_question */

SIGNAL:
	call signal_ ("command_question", null, addr (question_info), null);

	on cleanup call clean_up;

	if question_info.question_sw & ^question_info.preset_sw then
	     repeat_flag = "1"b;			/* if asking a question */
	else repeat_flag = "0"b;

	if question_info.question_iocbp = null then	/* if no output switch defined by caller or handler */
	     if question_info.preset_sw then
		question_info.question_iocbp = iox_$user_output;
						/* put question in file?? */
	     else question_info.question_iocbp = iox_$user_io;
						/* if really asking, go to the terminal */

	if question_info.answer_iocbp = null then	/* if no input switch defined by caller or handler */
	     question_info.answer_iocbp = iox_$user_input;/* set the default input switch */

ASK:
	if question_info.question_sw then do;		/* do we print the question? */
	     if ^question_info.preset_sw then		/* and if we need a reply ... */
		call iox_$control (question_info.question_iocbp, "reset_more", null (), (0));
						/* ... make sure the user sees the question */
	     call print_question;
	end;

/* process the answer */

	alloc_sw = "0"b;

	if question_info.preset_sw then		/* kludge in the current length */
	     big_len = question_info.answer_lth;
	else do;					/* read the answer from the user's terminal */
READ_ANSWER:
	     if repeat_flag & question_info.repeat_time >= 30 then do;
						/* put 30 second lower limit on repeats */
		call timer_manager_$alarm_call (question_info.repeat_time, "11"b, repeat_query);
		timer_set = "1"b;			/* indicate that a timer is pending */
	     end;

GET_LINE:
	     call iox_$get_line (question_info.answer_iocbp, addr (retstring), length (retstring), len, code);

	     if code = error_table_$long_record then do;
		if ^alloc_sw | big_len + len > alloc_len then do;
						/* need more room */
		     if ^alloc_sw then do;
			alloc_len = length (retstring) * 4;
			area_ptr = get_system_free_area_ ();
		     end;
		     else alloc_len = max (2 * alloc_len, big_len + len);
		     alloc_ptr = null;

		     allocate alloc_str in (area) set (alloc_ptr);

		     if alloc_sw then do;
			substr (alloc_ptr -> big_str, 1, big_len) = substr (big_ptr -> big_str, 1, big_len);
			free big_ptr -> big_str in (area);
		     end;
		     else big_len = 0;

		     big_ptr = alloc_ptr;
		     alloc_sw = "1"b;
		end;

		substr (big_ptr -> big_str, big_len + 1, length (retstring)) = retstring;
		big_len = big_len + length (retstring);
		code = 0;
		go to GET_LINE;
	     end;

	     else if code ^= 0 then do;
ANSWER_ERROR:
		call sub_err_ (code, callername, ACTION_CAN_RESTART, null, 0, "Reading answer.");
		go to GET_LINE;
	     end;

	     if alloc_sw then do;
		if big_len + len > alloc_len then do;
		     alloc_len = big_len + len;

		     allocate alloc_str in (area) set (alloc_ptr);

		     substr (alloc_ptr -> big_str, 1, big_len) = substr (big_ptr -> big_str, 1, big_len);
		     free big_ptr -> big_str in (area);
		     big_ptr = alloc_ptr;
		end;
		substr (big_ptr -> big_str, big_len + 1, len) = substr (retstring, 1, len);
		big_len = big_len + len;
	     end;
	     else do;
		big_ptr = addr (retstring);
		big_len = len;
	     end;

	     if timer_set then call timer_manager_$reset_alarm_call (repeat_query);
	end;

	if ^query_info.literal_sw & index (WHITE, substr (big_str, 1, 1)) ^= 0 then
	     big_str = ltrim (big_str, WHITE);		/* strip leading white space from answer */

	if big_len > 1 then
	if substr (big_str, 1, 2) = ".." then do;	/* command processor escape */
	     if ^allow_cp_escape then do;
		call com_err_ (0, callername, "No command processor escape allowed for this question.");
		if question_info.preset_sw then
		     go to SIGNAL;
		else go to ASK;
	     end;

	     if interpret_cp_escape then do;

		call cu_$cp (addr (substr (big_str, 3, 1)), max (0, big_len - 2), code);

		if alloc_sw then do;
		     alloc_sw = "0"b;
		     free alloc_str in (area);
		     alloc_ptr = null;
		end;

		if question_info.preset_sw then
		     go to SIGNAL;
		else do;
		     call iox_$control (question_info.question_iocbp, "reset_more", null (), (0));
		     call ioa_$ioa_switch_nnl (question_info.question_iocbp, "Answer: ");
		     go to READ_ANSWER;		     	/* brief prompt */
		end;
	     end;
	end;

	if ^query_info.literal_sw then big_len = length (rtrim (big_str, WHITE));

	if question_info.preset_sw & question_info.answer_sw then
						/* if preset answer exists & should be printed */
	     if question_info.question_sw | ^(big_str = "")
						/* and if the question was already printed */
	     then call ioa_$ioa_switch (question_info.question_iocbp, "^a", big_str);
						/* print answer and NL */

	if big_str = "?" & query_info.explanation_ptr ^= null & query_info.explanation_len > 0 then do;
						/* asking for an explanation and there is one */
	     call expand_explanation ();

	     call iox_$control (question_info.question_iocbp, "reset_more", null (), (0));
						/* let the user see the explanation */
PRINT_EXPLANATION:
	     if query_info.suppress_spacing then
		call iox_$put_chars (question_info.question_iocbp, addr (retstring), len, code);
	     else do;
		substr (output_buffer, 1, 1) = NL;
		substr (output_buffer, 2, len + 3) = substr (retstring, 1, len);
		call iox_$put_chars (question_info.question_iocbp, addr (output_buffer), len + 4, code);
	     end;
	     if code ^= 0 then do;
		call sub_err_ (code, callername, ACTION_CAN_RESTART, null, 0, "Writing explanation.");
		go to PRINT_EXPLANATION;
	     end;

	     if query_info.prompt_after_explanation then call print_question;

	     go to READ_ANSWER;
	end;

	if query_info.yes_or_no_sw then do;		/* answer must be "yes" or "no" */

	                                                  /* Translate any uppercase letters to lowercase before testing */
	     big_str = translate (big_str, LOWERCASE_YN, UPPERCASE_YN);

	     if big_str ^= "yes" & big_str ^= "y" & big_str ^= "no" & big_str ^= "n" then
		if question_info.preset_sw then do;	/* the handler returned a bum answer */
		     call signal_ ("command_query_error", null, null, null);
		     go to get_ready_to_signal;	/* control may return here if a "start" command is issued */
		end;
		else do;				/* the user has given a bum answer */
		     if get_group_id_ () = "Initializer.SysDaemon.z" then
			abs_queue = -1;
		     else call user_info_$absentee_queue (abs_queue);
		     if abs_queue ^= -1 then do;	/* running in absentee */
			call com_err_ (0, "command_query_", "Invalid answer to question above.");
			call signal_ ("command_query_error", null, null, null);
			return;
		     end;
		     call iox_$control (question_info.question_iocbp, "reset_more", null (), (0));
PRINT_GRIPE:
		     if query_info.explanation_ptr ^= null & query_info.explanation_len > 0 then
			call iox_$put_chars (question_info.question_iocbp,
			     addr (GRIPE2), length (GRIPE2), code);
		     else call iox_$put_chars (question_info.question_iocbp,
			addr (GRIPE1), length (GRIPE1), code);

		     if code ^=0 then do;
			call sub_err_ (code, callername, ACTION_CAN_RESTART, null, 0, "Writing question.");
			go to PRINT_GRIPE;
		     end;
						/* complain */
		     call iox_$control (question_info.answer_iocbp, "resetread", null, code);
						/* flush any read-ahead */
		     if alloc_sw then do;
			alloc_sw = "0"b;
			free alloc_str in (area);
			alloc_ptr = null;
		     end;

		     go to READ_ANSWER;
		end;

	     if yn_entry_sw then yes_sw = (big_str = "yes" | big_str = "y");
	     else if big_str = "y" then call set_answer ("yes");
	     else if big_str = "n" then call set_answer ("no");
	     else call set_answer (big_str);
	end;

	else call set_answer (big_str);

	repeat_flag = saved_rflag;
	repeat_label = saved_rlabel;

	if alloc_sw then free alloc_str in (area);
	return;

%page;
/* INTERNAL PROCEDURES */

set_answer: proc (P_str);

dcl P_str char (*);

	if fixed_answer_sw then fixed_answer = P_str;
	else varying_answer = P_str;

end set_answer;
%page;
clean_up:
     procedure ();

	if timer_set then call timer_manager_$reset_alarm_call (repeat_query);
	repeat_flag = saved_rflag;
	repeat_label = saved_rlabel;

	if alloc_ptr ^= null then free alloc_ptr -> alloc_str in (area);

     end clean_up;

%page;
/* Substitutes arugments into explanation control string and builds retstring */

expand_explanation:
     procedure ();

dcl  1 arg_list aligned based (alp),
       2 arg_count fixed bin (17) unaligned unsigned,
       2 code bit (19) unaligned,
       2 desc_count fixed bin (17) unaligned unsigned,
       2 mbz bit (19) unaligned,
       2 arg_ptrs (arg_count) ptr,
       2 display_ptr (bin ((arg_list.code & bit (10, 19)) ^= ""b), 1) ptr,
       2 desc_ptrs (arg_count) ptr;

/* For $yes_no, explanation is an argument */

	if yn_entry_sw then
	     call ioa_$general_rs (alp, control_string_index - 1, control_string_index + 1, retstring, len, "0"b, "0"b);

/* Otherwise, have to build an argument list containing it */

	else begin;

dcl  1 new_arg_list aligned,
       2 arg_count fixed bin (17) unaligned unsigned,
       2 code bit (19) unaligned,
       2 desc_count fixed bin (17) unaligned unsigned,
       2 mbz bit (19) unaligned,
       2 arg_ptrs (arg_list.arg_count) ptr,
       2 display_ptr (bin ((arg_list.code & bit (10, 19)) ^= ""b), 1) ptr,
       2 desc_ptrs (arg_list.arg_count) ptr;

%include descriptor;

dcl  desc_size fixed bin (24) unaligned unsigned based (addr (desc_.scale_));

	     new_arg_list = arg_list;			/* replace question arg with explanation arg */
	     desc_.version2_ = "1"b;
	     desc_.type_ = char_dtype;
	     desc_.pack_ = "1"b;
	     desc_.dimension_ = "0"b;

	     desc_size = length (explanation);

	     new_arg_list.desc_ptrs (control_string_index) = addr (desc_);
	     new_arg_list.arg_ptrs (control_string_index) = addr (explanation);

	     call ioa_$general_rs (addr (new_arg_list), control_string_index, control_string_index + 1, retstring, len,
		"0"b, "0"b);

	end;

     end expand_explanation;

%page;
print_question: proc;

PRINT_QUESTION:
	     if query_info.suppress_spacing then do;
		call iox_$put_chars (question_info.question_iocbp, question_info.question_ptr,
		     (question_info.question_lth), code);
		if code ^= 0 then do;
QUESTION_ERROR:
		     call sub_err_ (code, callername, ACTION_CAN_RESTART, null, 0, "Writing question.");
		     go to PRINT_QUESTION;
		end;
	     end;
	     else do;
		substr (output_buffer, 1, 1) = NL;
		substr (output_buffer, 2, (bi - 1) + 3) = question;
		call iox_$put_chars (question_info.question_iocbp, addr (output_buffer), (bi - 1) + 4, code);
		if code ^= 0 then go to QUESTION_ERROR;
	     end;

end print_question;
%page;

/* Repeat the last question and ask for the answer again */

repeat_query:
rq:
     entry () options (variable);

	if first_call then do;			/* be sure the labels are correctly defined */
	     repeat_label = ASK;			/* basis for saved label */
	     repeat_flag = "0"b;
	     first_call = "0"b;			/* done for this process */
	end;

	if repeat_flag then
	     go to repeat_label;
	else call com_err_ (0, "repeat_query", "No pending query.");

	return;

%page;
/* ENTRYPOINT */

/* Enable/disable use of the command processor escape */

set_cp_escape_enable:
     entry (new_allow_cp_escape, old_allow_cp_escape);

dcl  new_allow_cp_escape bit (1) aligned parameter;	/* whether it is enabled now */
dcl  old_allow_cp_escape bit (1) aligned parameter;	/* was it enabled before? */

	old_allow_cp_escape = static_allow_cp_escape;
	static_allow_cp_escape = new_allow_cp_escape;

	return;

%page;
/* INCLUDE FILES */

%include query_info;
%page;
%include command_question_info;
%page;
%include condition_info_header;
%page;
%include std_descriptor_types;
%page;
%include sub_err_flags;

end command_query_;




		    convert_access_class_.pl1       11/11/89  1108.2rew 11/11/89  0804.6      187344



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


/* format: style4,delnl,insnl,ifthenstmt,ifthen */

convert_access_class_:
     procedure;

/* CONVERT_ACCESS_CLASS_
   program to convert Multics AIM authorizations between their
   character and binary representations.

   PG 740801
   Modified 740823 by PG for $minimum and $test_cva entries.
   Modified 740917 by PG for $to_string_short entry.
   Modified 740930 by PG to allow only level-0 name to be null.
   Modified 741119 by PG to add "system_high" and "system_low" keywords.
   Modified 741213 by PG to call aim_check_ instead of using inline code.
   Modified 750316 by PG (per DAM) to fix bugs in calculation of name lengths in $to_string
   Modified 750604 by PG to allow leading blanks on keywords in $from_string
   Modified 10/05/78 by CDT to add "range" entrypoints.
   Modified: 7 July 1982 by G. Palter to make it recompile again
   Modified 84-03-22 BIM to recognize and present system_high on output.
   Modified 84-12-21 by Lee A. Newcomb:  Changed $encode to output "system_low"
   instead of a null string for that access class, and to
   have $decode accept that string in addition to the null
   string to imply system_low.
*/


/****^  HISTORY COMMENTS:
  1) change(87-02-19,Farley), approve(87-07-20,MCR7691),
     audit(87-03-11,Fawcett), install(87-08-04,MR12.1-1055):
     Added maximum entry point to compute the max authorization of an array of
     authorizations.
                                                   END HISTORY COMMENTS */


/* parameters */

declare  (
         bv_authorization_array dimension (*) bit (72) aligned,
         bv_authorization_binary bit (72) aligned,
         bv_authorization_string char (*),
         bv_code fixed bin (35),
         bv_maximum_authorization bit (72) aligned,
         bv_minimum_authorization bit (72) aligned,
         bv_n_authorizations fixed bin
         ) parameter;

/* automatic */

declare  sensitivity_level_undefined bit (1) aligned,
         category_set_undefined bit (36) aligned,
         (i, k, lb, hb, output_index, string_index) fixed bin,
         (next_level, sensitivity_level) fixed bin (18),
         (next_category_set, category_set) bit (36) aligned,
         (max_length, name_length) fixed bin,
         name char (32) aligned,
         (bad_authorization, more_names, short) bit (1) aligned,
         temp_string bit (72),
         comma char (2) varying,
         colon char (3) varying,
         second_string_ptr pointer,
         second_string_len fixed bin (21);

/* based */

declare  second_string_based char (second_string_len) based (second_string_ptr),
         based_char_array (output_index) char (1) unaligned based;

/* internal static initial */

declare  (
         initialized bit (1) aligned initial ("0"b),
         system_directory char (168) initial (">system_control_1"),
         ip ptr init (null)
         ) internal static;

/* external static */

declare  (
         error_table_$smallarg,
         error_table_$ai_above_allowed_max,
         error_table_$ai_invalid_string,
         error_table_$ai_invalid_range,
         error_table_$ai_invalid_binary
         ) fixed bin (35) external static;

/* entries */

declare  aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned),
         aim_check_$greater entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned),
         aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned),
         hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
         unique_chars_ entry (bit (*)) returns (char (15)),
         unique_chars_$bits entry (char (15)) returns (bit (70));

/* builtin */

declare  (addr, hbound, index, lbound, length, null, rtrim, string, substr, unspec, verify) builtin;

/* include files */

%include aim_template;
%include installation_parms;

/* program */

from_string:
     entry (bv_authorization_binary, bv_authorization_string, bv_code);

	bv_code = 0;
	call from_string_internal (bv_authorization_binary, bv_authorization_string, bv_code);
	return;

from_string_range:
     entry (bv_authorization_range, bv_authorization_string, bv_code);

declare  bv_authorization_range (2) bit (72) aligned parameter;

declare  colon_idx fixed bin (21);

	bv_code = 0;
	colon_idx = index (bv_authorization_string, ":");

	if colon_idx = 0 then do;
	     call from_string_internal (bv_authorization_range (1), bv_authorization_string, bv_code);
	     bv_authorization_range (2) = bv_authorization_range (1);
	     return;
	end;

	call from_string_internal (bv_authorization_range (1), substr (bv_authorization_string, 1, colon_idx - 1),
	     bv_code);
	if bv_code = error_table_$ai_above_allowed_max then bv_code = 0;
						/* we can afford to ignore this-- if LOW bound
						   is above max, either high bound will be too
						   or we will generate ai_invalid_range. */
	if bv_code ^= 0 then return;

	call from_string_internal (bv_authorization_range (2), substr (bv_authorization_string, colon_idx + 1), bv_code)
	     ;
	if bv_code ^= 0 then
	     if bv_code ^= error_table_$ai_above_allowed_max then return;

	if ^aim_check_$greater_or_equal (bv_authorization_range (2), bv_authorization_range (1)) then
	     bv_code = error_table_$ai_invalid_range;

	return;


from_string_internal:
     proc (bv_authorization_binary, bv_authorization_string, bv_code);

declare  (
         bv_authorization_binary bit (72) aligned,
         bv_authorization_string char (*),
         bv_code fixed bin (35)
         ) parameter;

	if ^initialized then do;
	     call initialize_me (bv_code);
	     if bv_code ^= 0 then return;
	end;

/* strip leading blanks. If input is all blank, treat same as "system_low" */

	string_index = verify (bv_authorization_string, " ");

	if string_index = 0 then do;
	     if installation_parms.level_names (0) ^= ""	/* If neither level-0 name is blank, invalid */
		& installation_parms.short_level_names (0) ^= "" then
		bv_code = error_table_$ai_invalid_string;
	     else bv_code = 0;
	     bv_authorization_binary = ""b;		/* input is all blank */
	     return;
	end;

	if substr (bv_authorization_string, string_index) = "system_low" then do;
	     bv_authorization_binary = ""b;
	     bv_code = 0;
	     return;
	end;

	if substr (bv_authorization_string, string_index) = "system_high" then do;
	     bv_authorization_binary = installation_parms.access_authorization_ceiling;
	     bv_code = 0;
	     return;
	end;

	more_names = "1"b;				/* not a trivial case, must parse input */

	sensitivity_level_undefined = "1"b;
	category_set_undefined = (36)"1"b;

	sensitivity_level = 0;
	category_set = (36)"0"b;

	output_index = 1;

	do while (more_names);
	     name_length = index (substr (bv_authorization_string, string_index), ",") - 1;
	     if name_length = -1			/* if last name on line */
		then
		name_length = length (bv_authorization_string) - string_index + 1;

	     name = substr (bv_authorization_string, string_index, name_length);
	     string_index = string_index + name_length + 1;

	     if string_index > length (bv_authorization_string) then more_names = "0"b;
						/* done if no more input left */

	     lb = lbound (installation_parms.level_names (*), 1);
	     hb = hbound (installation_parms.level_names (*), 1);

	     do i = lb to hb while (installation_parms.level_names (i) ^= name);
						/* try long level names. */
	     end;

	     if i = hb + 1				/* not a long level name, try short level names. */
		then
		do i = lb to hb while (installation_parms.short_level_names (i) ^= name);
	     end;

	     if i <= hb				/* is a (long or short) level name */
		then
		if sensitivity_level_undefined then do;
		     sensitivity_level = i;
		     sensitivity_level_undefined = "0"b;
		end;
		else do;
		     bv_code = error_table_$ai_invalid_string;
		     return;
		end;
	     else do;				/* not a level name, try category names */
		lb = lbound (installation_parms.category_names (*), 1);
		hb = hbound (installation_parms.category_names (*), 1);

		do i = lb to hb while (installation_parms.category_names (i) ^= name);
		end;

		if i = hb + 1			/* not a long category name, try short category name. */
		     then
		     do i = lb to hb while (installation_parms.short_category_names (i) ^= name);
		end;

		if i <= hb			/* is a (long or short) category name */
		     then
		     if substr (category_set_undefined, i, 1) then do;
			substr (category_set, i, 1) = "1"b;
			substr (category_set_undefined, i, 1) = "0"b;
		     end;
		     else do;
			bv_code = error_table_$ai_invalid_string;
			return;
		     end;
		else do;
		     bv_code = error_table_$ai_invalid_string;
		     return;
		end;
	     end;

/* strip leading blanks on next name */

	     if more_names then do;
		k = verify (substr (bv_authorization_string, string_index), " ") - 1;

		if k = -1 then
		     more_names = "0"b;		/* rest of input is blank */
		else string_index = string_index + k;	/* step over k blanks */
	     end;
	end;

	addr (bv_authorization_binary) -> aim_template.categories = category_set;
	addr (bv_authorization_binary) -> aim_template.level = sensitivity_level;
	string (addr (bv_authorization_binary) -> aim_template.privileges) = ""b;

/* Authorization has been converted. See if it is greater than the authorization ceiling.
   This is a non-fatal error; the converted value will still be returned. */

	if ^aim_check_$greater_or_equal (installation_parms.access_authorization_ceiling, bv_authorization_binary) then
	     bv_code = error_table_$ai_above_allowed_max;
	else bv_code = 0;

	return;
     end from_string_internal;

/* ---------- */

/* Entry to convert the binary form of an authorization/access class to the character string form.
   Works properly for null names. */

to_string:
     entry (bv_authorization_binary, bv_authorization_string, bv_code);

	bv_code = 0;
	short = "0"b;				/* use long names */
	comma = ", ";				/* make output a little prettier */

	call to_string_internal (bv_authorization_binary, bv_authorization_string, bv_code);
	return;


/* Entry to convert binary form to the character string form, using the short names. */

to_string_short:
     entry (bv_authorization_binary, bv_authorization_string, bv_code);

	bv_code = 0;
	short = "1"b;				/* use short names */
	comma = ",";				/* put names close together */

	call to_string_internal (bv_authorization_binary, bv_authorization_string, bv_code);
	return;


/* Entry to convert pair of binary forms to character string form. */

to_string_range:
     entry (bv_authorization_range, bv_authorization_string, bv_code);

	bv_code = 0;
	short = "0"b;				/* use long names */
	comma = ", ";				/* make output a little prettier */
	colon = " : ";
	goto to_range_common;


/* Entry to convert pair of binary forms to the character string form, using the short names. */

to_string_range_short:
     entry (bv_authorization_range, bv_authorization_string, bv_code);

	bv_code = 0;
	short = "1"b;				/* use short names */
	comma = ",";				/* put names close together */
	colon = ":";

to_range_common:
	call to_string_internal (bv_authorization_range (1), bv_authorization_string, bv_code);
	if bv_code ^= 0 then return;

	if bv_authorization_string = "" then bv_authorization_string = "system_low";

	if bv_authorization_range (1) = bv_authorization_range (2) then return;

	output_index = length (rtrim (bv_authorization_string, " ")) + 1;
	if output_index + length (colon) + 1 > length (bv_authorization_string) then do;
	     bv_code = error_table_$smallarg;
	     return;
	end;

	substr (bv_authorization_string, output_index, length (colon)) = colon;
	output_index = output_index + length (colon);

	second_string_ptr = addr (addr (bv_authorization_string) -> based_char_array (output_index));
	second_string_len = length (substr (bv_authorization_string, output_index));

	call to_string_internal (bv_authorization_range (2), second_string_based, bv_code);
	if bv_code ^= 0 then return;

	if ^aim_check_$greater_or_equal (bv_authorization_range (2), bv_authorization_range (1)) then
	     bv_code = error_table_$ai_invalid_range;

	if second_string_based = "" then
	     if bv_code = 0 then
		if short then
		     bv_authorization_string = "";
		else bv_authorization_string = "system_low";
	     else do;
		second_string_based = "system_low";
		if second_string_based ^= "system_low" then bv_code = error_table_$smallarg;
	     end;

	return;

to_string_internal:
     proc (bv_authorization_binary, bv_authorization_string, bv_code);

declare  (
         bv_authorization_binary bit (72) aligned,
         bv_authorization_string char (*),
         bv_code fixed bin (35)
         ) parameter;

	if ^initialized then do;
	     call initialize_me (bv_code);
	     if bv_code ^= 0 then return;
	end;

	bad_authorization = "0"b;

	if short then
	     max_length = length (installation_parms.short_level_names (1));
	else max_length = length (installation_parms.level_names (1));

	if aim_check_$greater (installation_parms.access_authorization_ceiling, ""b)
						/* is system_high greater than system_low? */
	     then
	     if aim_check_$equal (bv_authorization_binary, installation_parms.access_authorization_ceiling) then do;
		bv_authorization_string = "system_high";
		return;
	     end;

	sensitivity_level = addr (bv_authorization_binary) -> aim_template.level;
	category_set = addr (bv_authorization_binary) -> aim_template.categories;

/* Sensitivity level name comes first (may be null string). */

	if sensitivity_level <= hbound (installation_parms.level_names (*), 1)
	     & sensitivity_level >= lbound (installation_parms.level_names (*), 1) then do;
	     if short then
		name_length = length (rtrim (installation_parms.short_level_names (sensitivity_level), " "));
	     else name_length = length (rtrim (installation_parms.level_names (sensitivity_level), " "));

/* only level 0 can have a null name */

	     if name_length = 0 then
		if sensitivity_level ^= 0 then bad_authorization = "1"b;

/* copy in level name, and set rest of output string to blanks */

	     if short then
		bv_authorization_string = installation_parms.short_level_names (sensitivity_level);
	     else bv_authorization_string = installation_parms.level_names (sensitivity_level);

	     output_index = name_length + 1;
	end;
	else do;
	     bad_authorization = "1"b;
	     output_index = 1;			/* level was bad, but still try to convert categories */
	     bv_authorization_string = "";
	end;

/* Category names follow level name. */
/* (we assume max_length of category names is same as max_length of level names). */

	do i = lbound (installation_parms.category_names (*), 1) to hbound (installation_parms.category_names (*), 1);

	     if substr (category_set, i, 1) then do;
		if short then
		     name_length = length (rtrim (installation_parms.short_category_names (i), " "));
		else name_length = length (rtrim (installation_parms.category_names (i), " "));

/* null category names are not allowed */

		if name_length = 0 then bad_authorization = "1"b;

/* make sure comma, optional space, and whole name will fit */

		if output_index + name_length + length (comma) - 1 > length (bv_authorization_string) then do;
		     bv_code = error_table_$smallarg;
		     return;
		end;

		if output_index > 1			/* if there is a preceding name */
		then do;
		     substr (bv_authorization_string, output_index, length (comma)) = comma;
		     output_index = output_index + length (comma);
		end;

		if short then
		     substr (bv_authorization_string, output_index, name_length) =
			installation_parms.short_category_names (i);
		else substr (bv_authorization_string, output_index, name_length) =
			installation_parms.category_names (i);

		output_index = output_index + name_length;
	     end;
	end;

	if i <= length (category_set) then
	     if substr (category_set, i)		/* if any bits are on in unused category bits */
		then
		bad_authorization = "1"b;

/* we do not check that the aim_template.privileges field is all zero. */
/* (so that programs who call us don't have to worry about exception bits stored there). */

	if bad_authorization then
	     bv_code = error_table_$ai_invalid_binary;
	else bv_code = 0;
	return;
     end to_string_internal;

/* Entry to compute the max reduction of a vector of authorizations.
   The result has a sensitivity level greater than or equal to each input level,
   and a category set which is a (possibly improper) superset of all input category sets. */

maximum:
     entry (bv_authorization_array, bv_n_authorizations, bv_maximum_authorization);

	sensitivity_level = addr (bv_authorization_array (1)) -> aim_template.level;
	category_set = addr (bv_authorization_array (1)) -> aim_template.categories;

	do i = 2 to bv_n_authorizations;		/* even works for n = 1 */
	     next_level = addr (bv_authorization_array (i)) -> aim_template.level;
	     next_category_set = addr (bv_authorization_array (i)) -> aim_template.categories;

	     if sensitivity_level < next_level then sensitivity_level = next_level;

	     category_set = category_set | next_category_set;
	end;

	addr (bv_maximum_authorization) -> aim_template.level = sensitivity_level;
	addr (bv_maximum_authorization) -> aim_template.categories = category_set;
	string (addr (bv_maximum_authorization) -> aim_template.privileges) = ""b;
	return;

/* Entry to compute the min reduction of a vector of authorizations.
   The result has a sensitivity level less than or equal to each input level,
   and a category set which is a (possibly improper) subset of all input category sets. */

minimum:
     entry (bv_authorization_array, bv_n_authorizations, bv_minimum_authorization);

	sensitivity_level = addr (bv_authorization_array (1)) -> aim_template.level;
	category_set = addr (bv_authorization_array (1)) -> aim_template.categories;

	do i = 2 to bv_n_authorizations;		/* even works for n = 1 */
	     next_level = addr (bv_authorization_array (i)) -> aim_template.level;
	     next_category_set = addr (bv_authorization_array (i)) -> aim_template.categories;

	     if sensitivity_level > next_level then sensitivity_level = next_level;

	     category_set = category_set & next_category_set;
	end;

	addr (bv_minimum_authorization) -> aim_template.level = sensitivity_level;
	addr (bv_minimum_authorization) -> aim_template.categories = category_set;
	string (addr (bv_minimum_authorization) -> aim_template.privileges) = ""b;
	return;

/* Entry to encode an authorization as a character string short enough   */
/* to be used as an entry name.  For system_low, the string "system_low" */
/* is returned; for all other access classes, we use unique_chars_.	   */

encode:
     entry (bv_authorization_binary, bv_authorization_encoded);

/* parameters */

declare  bv_authorization_encoded char (*);

/* program */

	temp_string = unspec (bv_authorization_binary);
	string (addr (temp_string) -> aim_template.privileges) = ""b;

	if temp_string ^= ""b then
	     bv_authorization_encoded = unique_chars_ (temp_string);
	else bv_authorization_encoded = "system_low";

	return;

/* Entry to decode back into an authorization. */

decode:
     entry (bv_authorization_binary, bv_authorization_encoded);

/* program */

	if bv_authorization_encoded = "" | bv_authorization_encoded = "system_low" then
	     temp_string = ""b;
	else temp_string = unique_chars_$bits ((bv_authorization_encoded));

	unspec (bv_authorization_binary) = temp_string;
	return;

/* Entry to change the default system directory for testing purposes. */

test_cva:
     entry (bv_system_directory);

/* parameters */

declare  bv_system_directory char (*) parameter;

/* program */

	system_directory = bv_system_directory;
	initialized = "0"b;
	return;

/* Internal procedure to get a pointer to installation_parms. */

initialize_me:
     procedure (bv_code);

/* parameters */

declare  bv_code fixed bin (35) parameter;

/* program */

	call hcs_$initiate (system_directory, "installation_parms", "", 0, 0, ip, bv_code);
	if ip = null then return;

	bv_code = 0;
	initialized = "1"b;

     end initialize_me;

     end convert_access_class_;




		    convert_binary_integer_.pl1     11/11/89  1108.2rew 11/11/89  0803.9       72279



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



/* format: style4,delnl,insnl,ifthenstmt,indnoniterend */
decimal_string:					/* routine to convert fixed bin(35) number to its decimal string representation,
						   as a varying string of max length 12. Digits are generated
						   by successive remainders, from right to left in a temporary string, then
						   copied into the argument.
						   Modified 7/28/71 by David Reed */
						/* Modified 9/19/74 by Steve Herbst to special-case for 100...0b */
     proc (integer, string);

dcl  (integer, number, position, scan) fixed bin (35);
dcl  (long_integer, long_number) fixed bin (71);
dcl  bits_of_arg bit (72);
dcl  oct_string char (13) varying;
dcl  long_oct_string char (25) varying;
dcl  long_dec_string char (23) varying;
dcl  lower fixed bin (63),
     lower_quotient fixed bin (35),
     (upper_quotient, upper) fixed bin (35),
     upper_word fixed bin (35) based;
dcl  negative bit (1);
dcl  string char (12) varying;
dcl  temp_string char (25);
dcl  1 temp_string_ovly aligned based (addr (temp_string)),
       2 bit9_string (0:24) bit (9) unaligned;
dcl  (substr, fixed, divide, bit, unspec, addr, mod) builtin;
						/*
						   /* decimal_string:
						   proc(integer, string);	*/

	if unspec (integer) = "1"b then do;
	     string = "-34359738368";
	     return;
	     end;

	negative = "0"b;				/* set flag saying number is not negative yet */
	number = integer;				/* copy argument */
	if number = 0 then do;			/* if arg = 0 then return "0" immediate */
	     string = "0";
	     return;
	     end;

	if number < 0
	then					/* if number is negative then remember to put out sign */
	     do;
	     number = -number;			/* and make number positive */
	     negative = "1"b;
	     end;

	do position = 11 by -1 while (number ^= 0);	/* generate digits into temp string in reverse */
	     bit9_string (position) = "00011"b || bit (fixed (mod (number, 10), 4), 4);
						/* make a digit by prefixing */
						/* appropriate bits for 9-bit code */
	     number = divide (number, 10, 35);
	end;

	if negative
	then					/* if we rembered to put out minus sign, do so */
	     do;
	     substr (temp_string, position + 1, 1) = "-";
	     position = position - 1;
	     end;
	string = substr (temp_string, position + 2, 11 - position);
						/* copy temp string into output argument */
	return;					/*						   /* entry to convert fixed bin(35) to octal varying string representation */

octal_string:
     entry (integer, oct_string);


	if unspec (integer) = "1"b then do;
	     oct_string = "-400000000000";
	     return;
	     end;

	position = 0;				/*	start at beginning of string */
	number = integer;				/* copy argument number */
	if number < 0
	then					/* make number positive, and output sign if necessary */
	     do;
	     number = -number;
	     position = 1;
	     substr (temp_string, 1, 1) = "-";
	     end;

	substr (bits_of_arg, 1, 36) = unspec (number);	/* move number into bit string */
	do scan = 0 to 10 while (substr (bits_of_arg, 1, 3) = ""b);
						/* scan for first non-zero 3 bit byte */
	     substr (bits_of_arg, 1, 36) = substr (bits_of_arg, 4, 33);
						/* shift bit representation left */
						/* one octal digit */
	end;
	do scan = scan to 11;			/* loop over rest of number, outputting each byte as a digit */
	     bit9_string (position) = "000110"b || substr (bits_of_arg, 1, 3);
						/* make octal digit */
	     substr (bits_of_arg, 1, 36) = substr (bits_of_arg, 4, 33);
						/* shift bit representation of number */
						/* 3 bits (an octal digit) left */
	     position = position + 1;
	end;


	oct_string = substr (temp_string, 1, position);	/* copy result into result string */
	return;



/*   /* routine to convert fixed bin(71) to octal representation as varying string */

long_octal_string:
     entry (long_integer, long_oct_string);


	if unspec (long_integer) = "1"b then do;
	     long_oct_string = "-400000000000000000000000";
	     return;
	     end;

	position = 0;				/* start at left end of temp string */
	long_number = long_integer;			/* copy argument number */

	if long_number < 0
	then					/* make sign positive, outputting minus sign if negation is necessary */
	     do;
	     long_number = -long_number;
	     position = position + 1;
	     substr (temp_string, 1, 1) = "-";
	     end;

	bits_of_arg = unspec (long_number);		/* copy number into bit string */
	do scan = 0 to 22 while (substr (bits_of_arg, 1, 3) = ""b);
						/* scan for first non-zero 3 bit byte */
	     bits_of_arg = substr (bits_of_arg, 4);	/* shift number left one octal digit */
	end;

	do scan = scan to 23;			/* scan rest of digits, making output as we go */
	     bit9_string (position) = "000110"b || substr (bits_of_arg, 1, 3);
						/* make octal digit */
	     bits_of_arg = substr (bits_of_arg, 4);	/* shift number left one octal digit */
	     position = position + 1;
	end;

	long_oct_string = substr (temp_string, 1, position);
						/* copy temp string into output string */
	return;





/*   /* convert fixed bin(71) to a decimal string representation as a varying string */

long_decimal_string:
     entry (long_integer, long_dec_string);

	if unspec (long_integer) = "1"b then do;
	     long_dec_string = "-2361183233875680165888";
	     return;
	     end;

	negative = ""b;				/* remember we have not yet found number < 0 */
	long_number = long_integer;			/* copy argument for convenience */

	if long_number = 0
	then					/* if number = 0 then return 1 char string */
	     do;
	     long_dec_string = "0";
	     return;
	     end;

	if long_number < 0
	then					/* if number is negative, remember it was negative, and make it positive */
	     do;
	     long_number = -long_number;
	     negative = "1"b;
	     end;					/* The following loop is needed because the current Multics hardware cannot
						   handle division of fixed bin(71) numbers. Thus, we handle the division
						   in two halves until the number being divided by 10 is less than 2 ** 63,
						   at which point, we may use standard pl1 division. */

	upper = addr (long_number) -> upper_word;	/* upper gets upper half of double word integer */
	lower = long_number - 68719476736 * upper;	/* lower gets lower half */

	do position = 22 by -1 while (upper >= 134217728);/* generate digits by hard division
						   until upper is <= 2**27 */
	     upper_quotient = divide (upper, 10, 35);
	     lower = lower + 68719476736 * (upper - 10 * upper_quotient);
	     lower_quotient = divide (lower, 10, 63);
	     bit9_string (position) = "00011"b || bit (fixed (lower - 10 * lower_quotient, 4), 4);
						/* make digit from number */
	     upper = upper_quotient;
	     lower = lower_quotient;
	end;

/* end of hard division. now number is less than 2**63 */

	lower = lower + 68719476736 * upper;		/* make lower contain the total result */

	do position = position by -1 while (lower ^= 0);	/* now convert to decimal string by normal algorithm */
	     bit9_string (position) = "00011"b || bit (fixed (mod (lower, 10), 4), 4);
	     lower = divide (lower, 10, 63);
	end;

	if negative
	then					/* if we must precede nuber by a sign character, prefix it now */
	     do;
	     substr (temp_string, position + 1, 1) = "-";
	     position = position - 1;
	     end;

	long_dec_string = substr (temp_string, position + 2, 22 - position);
						/* copy result into return arg */
	return;
     end;




		    get_process_id_.pl1             11/11/89  1108.2rew 11/11/89  0804.6       40329



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

/****	GET_PROCESS_ID_
	GET_GROUP_ID_
	GET_PDIR_
	GET_LOCK_ID_
	GET_PROCESS_AUTHORIZATION_
	GET_PROCESS_ACCESS_CLASS_
	GET_PROCESS_MAX_AUTHORIZATION_
	GET_MAX_AUTHORIZATION_

 - entries to return values  for specified per process variables.

   Originally coded by R. J. Feiertag on January 25, 1970		*/
/*		Converted to V2 by E. Stone 03/74 */
/*		get_authorization_ entry added by Kobziar July 74 */
/*		get_max_authorization_ and get_privileges_ added May 75 */
/*		Modified March 1975 by Larry Johnson to fix init subroutine. */
/*		Modified 830906 for correct "returns" entry declarations... -E. A. Ranzenbach */
/* Modified 84-04-26 BIM for rationalized aim-related entries. */

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend */
get_process_id_:
     proc () returns (bit (36));

dcl  i fixed bin (17),
     authorization bit (72) aligned;
dcl  int_process_id bit (36) aligned internal static,
     int_group_id char (32) aligned internal static,
     int_pdir char (32) aligned internal static,
     access_class bit (72) aligned internal static,
     max_authorization bit (72) aligned internal static,
     int_lock_id bit (36) aligned internal static,
     not_init_yet bit (1) aligned internal static init ("1"b);

dcl  hcs_$get_authorization ext entry (bit (72) aligned, bit (72) aligned);
dcl  aim_util_$get_access_class entry (bit (72) aligned) returns (bit (72) aligned) reducible;
dcl  aim_util_$get_privileges entry (bit (72) aligned) returns (bit (36) aligned) reducible;

dcl  substr builtin;

dcl  process_id bit (36);

	if not_init_yet then call init;
	process_id = int_process_id;
	return (process_id);

get_group_id_:
     entry () returns (char (32));

dcl  group_id char (32);

	if not_init_yet then call init;
	group_id = int_group_id;
	return (group_id);

tag_star:
     entry () returns (char (32));

	if not_init_yet then call init;
	group_id = int_group_id;
	group_id = substr (group_id, 1, length (rtrim (group_id)) - 1) || "*";
	return (group_id);


get_pdir_:
     entry () returns (char (168));

dcl  pdir char (168);

	if not_init_yet then call init;
	pdir = int_pdir;
	return (pdir);

get_lock_id_:
     entry () returns (bit (36));

dcl  lock_id bit (36);

	if not_init_yet then call init;
	lock_id = int_lock_id;
	return (lock_id);

init:
     proc;					/* Internal procedure to initially recover per process information from ring 0 and
						   store it internal static */

dcl  hcs_$proc_info ext entry (bit (36) aligned, char (32) aligned, char (32) aligned, bit (36) aligned);

	call hcs_$proc_info (int_process_id, int_group_id, int_pdir, int_lock_id);

	call hcs_$get_authorization (access_class, max_authorization);
	access_class = aim_util_$get_access_class (access_class);

	not_init_yet = "0"b;

     end init;

get_initial_ring_:
     entry () returns (fixed bin (17));					/* Get initial ring from ring 0 each time */

dcl  iring fixed bin;

dcl  hcs_$get_initial_ring entry (fixed bin);

	call hcs_$get_initial_ring (iring);		/* Schlep it out to the user */

	return (iring);

get_process_access_class_:
get_authorization_: /** obsolete name */
     entry () returns (bit (72) aligned);

dcl  ret_auth bit (72) aligned;

	if not_init_yet then call init;
	return (access_class);


get_process_authorization_:
	entry () returns (bit (72) aligned);

	call hcs_$get_authorization (authorization, (""b));
	return (authorization);


get_process_max_authorization_:
get_max_authorization_: /** obsolete name */
     entry () returns (bit (72) aligned);

	if not_init_yet then call init;

	ret_auth = max_authorization;

	return (ret_auth);

get_privileges_:
     entry () returns (bit (36) aligned);

	call hcs_$get_authorization (authorization, "0"b);

	return (aim_util_$get_privileges (authorization));

     end get_process_id_;




		    iox_.alm                        11/11/89  1108.2rew 11/11/89  0805.9       67563



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

" Transfer vector and data segment for IOX.
" This Program was found on a doorstep, its parenthood and birthdate unrecorded.
" Largely recoded for hashing and new initialization April 1981 by Benson I. Margulies.
" Sentinel checking June 1981 Benson I. Margulies
" Hash table removed January 1982 by C. Hornig.
" Modified 11/82 by S. Krupp to add new transfer vectors for open_file,
"   close_file, detach, and attach_loud entries.  Changed version number
"   to 2.

	name	iox_
	perprocess_static
	maclist	off

	" Table of contents

	" iox_ i/o operation transfer vectors entries

	" IOCB version/sentinel constant

	" iox_ utility operation transfer vectors

	" iox_ error entrypoints

	" IOCB hash table and hit meter

	" iox_ standard attachment pointers
	"      and switch names

	" IOS writeround entries that map calls from IOX to IOS.



" The I/O entrypoints are defined below with the following macros

	macro	iocb_tv
	maclist	on,save
	" Entry point "iox_$&1"
	maclist	off
	segdef	&1
&1:	getlp
	maclist	restore
	ldx1	iocb.&1,du
	tra	iocb_tv_join
	&end

" The error entrypoints are defined with this macro

	macro	error	Error segdef.
	maclist 	on,save
	" Entry point "iox_$err_&1"
	maclist	restore
	segdef	err_&1
err_&1:   getlp
	maclist	on
	ldq	error_table_$&1
	tra	error_join
	maclist	restore
	&end

" This macro defines a utility procedure known to be bound in
" with this segment, and "callable" with tra.

	macro	tv	
	maclist	on,save
	" Utility entrypoint "iox_$&2"
	maclist	off
	segdef	&2
&2:	getlp
	maclist	restore
	tra	&1$&2
	&end

	iocb_tv	detach_iocb
	iocb_tv	open
	iocb_tv	close
	iocb_tv	get_line
	iocb_tv	get_chars
	iocb_tv	put_chars
	iocb_tv	modes
	iocb_tv	position
	iocb_tv	control
	iocb_tv	read_record
	iocb_tv	write_record
	iocb_tv	rewrite_record
	iocb_tv	delete_record
	iocb_tv	seek_key
	iocb_tv	read_key
	iocb_tv	read_length

	error	no_iocb
	error	no_operation
	error	not_attached
	error	not_closed
	error	not_open
	error	old_dim

	tv	iox_attach_name,attach_name
	tv	iox_attach_name,attach_ioname
	tv	iox_attach_name,attach_ptr
	tv	iox_attach_name,attach_iocb
	tv	iox_attach_name,attach_loud
	tv	iox_open_file,open_file
	tv	iox_close_file,close_file
	tv	iox_detach,detach
	tv	iox_find_iocb,find_iocb
	tv	iox_find_iocb,look_iocb
	tv 	iox_find_iocb,move_attach
	tv	iox_find_iocb,destroy_iocb
	tv	iox_find_iocb,find_iocb_n
	tv	iox_propagate,propagate
	tv	iox_init_,init_standard_iocbs

	" Common code for the error entrypoints

error_join: 
	ldx7	ap|0		Get number of arguments called with.
	tmoz	no_arguments
	stq	ap|0,7*		Store error code as last argument.
no_arguments:
	short_return

	" Common code for the io transfer vectors
iocb_tv_join:
	epp2	ap|2,*		Get pointer to pointer to IOCB
	epp2	pr2|0,*		Get pointer to IOCB
	epaq	pr2|0
	ana	-1,du		The bottom half is and'd with 0
          cmpa	=o077777,du
	tze	null_iocb_ptr
	lda	pr2|iocb.version
	cmpa	iocb_version_sentinel
	tnz	not_a_valid_iocb	Sentinel missing
	call6	pr2|0,x1*		Call the appropriate frob.

not_a_valid_iocb:
	ldq	error_table_$not_a_valid_iocb
	tra	error_join

null_iocb_ptr:
	ldq	error_table_$no_iocb  " null pointer certainly isn't an iocb
	tra	error_join	  " join the return-last-arg code	

	segdef	iocb_version_sentinel
iocb_version_sentinel:
	aci	~IOX2~		" externally available


	" Hash Table
	segdef	hash_table
	segdef	hash_table_ptr
	segdef	hash_hit_count
	segdef	hash_table_size

" hash_index_ produces numbers from 0 through the
" table size, though it divides by the specified
" size. So we divide by 127, a prime, but the table
" is 128 long. 

	use	hash
hash_table_size:
	dec	1		" will be grown later if necessary
hash_hit_count:
	dec	0
hash_table_ptr:
	its	-1,1		" set by iox_init_, updated by find_iocb.
hash_table:
	its	-1,1		" initial hash table

	join	/static/hash



" standard attachment iocbs

	segdef	n_standard_iocbs
	segdef	standard_iocb_info
	segdef	standard_iocb_ptrs	

	macro	iocb		Define standard switch "&1"
	use	text
	set	n_iocbs,n_iocbs+1
	use	iocb_names
	segdef	&1	" name of the entrypoint
	maclist	on,save
	aci	~&2~,32	" name of the switch
	aci	~&3~,72     " attach description if constant
	use	iocb_ptrs
	even
&1:	its	-1,1
"		IOCB &2 attached as &3
	maclist   restore
	&end

	set	n_iocbs,0

" Standard IOCB definitions
	
	use	iocb_names
standard_iocb_info:
	use	iocb_ptrs
standard_iocb_ptrs:

	iocb	user_io,(user_i/o),()
	iocb	user_input,user_input,(syn_ user_i/o -inhibit close put_chars)
	iocb	user_output,user_output,(syn_ user_i/o -inhibit get_chars get_line close)
	iocb	error_output,error_output,(syn_ user_i/o -inhibit get_line get_chars close)

	use	text
n_standard_iocbs:
	vfd	36/n_iocbs

	use	text
	join	/text/iocb_names
	join	/static/iocb_ptrs


	" IOS writearound
	segdef	ios_call
	segdef	ios_call_attach

" iox_$ios_call: proc(p,...other args...,status);
"
" dcl 1 ics aligned based(p),		IOS-call communication structure.
"	2 sdbptr ptr,		Address of SDB for attachment.
"	2 dimptr ptr,		Address of DIM's transfer vector.
"	2 segdef_offset fixed.:	1=detach, 2=read, ..., 20=writesync.
"
" After clearing 'status' for the DIM, this routine re-maps its call into
"
"	lxl6 segdef_offset
"	call dimptr(sdbptr,...other args...,status);
"
" by altering the first argument pointer of the caller's argument list and passing the
" call on.  Note that all descriptors are correct and need not be changed or moved.
" This routine is used by the new "iox_" write-arounds to call the segdef points of
" old "ios_"-style DIMs.

ios_call:	ldx6	ap|0		Get offset of 'status' argument pointer.
	epp2	ap|0,6*		Get address of 'status' itself.
	stz	pr2|0		Clear 'status' because some DIMs do not do it
	stz	pr2|1		for themselves.
	epp2	ap|2,*		Get address of pointer to 'ics'='ics.sdbptr'.
	epp2	pr2|0,*		Get address of 'ics'='ics.sdbptr' itself.
	spri2	ap|2		First argument is now 'sdbptr'.
	lxl6	pr2|4		Get offset of desired DIM segdef.
	tra	pr2|2,*		Go to transfer vector of DIM.
"
" End of segdef point ..... iox_$ios_call(p,...other args...,status) .....



" iox_$ios_call_attach: proc(...four other args...,status,p);
"
" This routine re-maps its call into
"
"	lxl6 0,dl
"	call dimptr(...other args...,status,sdbptr);
"
" by altering the last argument pointer of the caller's argument list and passing the
" call on.  This routine is used to call the "attach" segdef point of an old-style DIM,
" which has a different convention regarding the SDB pointer than the other entries.
"
ios_call_attach:
	epp2	ap|10,*		Get address of 'status'.
	stz	pr2|0		Clear 'status'.
	stz	pr2|1		..
	epp2	ap|12,*		Get address of pointer to 'ics'='ics.sdbptr'.
	epp2	pr2|0,*		Get address of 'ics'='ics.sdbptr' itself.
	spri2	ap|12		Last argument is now 'sdbptr'.
	lxl6	0,dl		Get offset of 'attach' segdef to DIM.

	tra	pr2|2,*		Go to transfer vector of DIM.
"
" End of segdef point ..... iox_$ios_call_attach(...other args...,status,p) .....




	include	iocbx
	end




		    iox_attach_name.pl1             11/11/89  1108.2rew 11/11/89  0805.9       54783



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

/* This is the attachment module for iox_.

   Last Modified: (Date and Reason)
   Aug 9, 1977 by S. Webber for quote processing
   Modified 11/82 by S. Krupp to do the following:  move code that
     parses attach descriptions to an external subroutine, to make
     way for the new iox_$attach_loud entry, and to move code that
     handles entry point names in attach module names from the
     io_call command to here.
*/
/* format: style4,delnl,insnl,ifthenstmt,indnoniterend */
iox_attach_name:
     proc();

          return;					/* Not a legal entry. */

/* Parameters. */

dcl  input_descrip char (*);
dcl  iocb_ptr ptr;
dcl  ref_ptr ptr;
dcl  ioname char (*);
dcl  ret_code fixed bin (35);


/* Automatic. */

dcl  attach_ent char(32);
dcl  caller_ptr ptr;
dcl  code fixed bin (35);
dcl  descrip char (length (input_descrip));
dcl  dir char (168);
dcl  ent char (32);
dcl  entry_var entry (ptr, (*) char (*) var, bit (1) aligned, fixed bin (35)) variable;
dcl  i fixed bin;
dcl  loud_sw bit(1) aligned;
dcl  max_option_len fixed bin;
dcl  n_options fixed bin;
dcl  p ptr;
dcl  pname char(length(input_descrip));
dcl  rem_descrip char (length (input_descrip)) var;

/* Procedures. */

dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  iox_find_iocb$find_iocb ext entry (char (*), ptr, fixed bin(35));
dcl  iox_get_options entry (char (*), (*) char (*) var, fixed bin (35));
dcl  hcs_$initiate_count ext entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr) returns (fixed bin (35));
dcl  hcs_$make_entry ext entry (ptr, char (*), char (*), entry, fixed bin (35));
dcl  iox_measure_options entry (char (*), fixed bin, fixed bin, fixed bin (35));
dcl  term_$single_refname ext entry (char (*) aligned) returns (fixed bin (35));

/* Static */

dcl  error_table_$noarg fixed bin (35) ext;

/* Built-ins. */

dcl  (index, length, null, reverse, rtrim, search, substr) builtin;

/* End of declarations. */
%page;
/* Beginning of entry point ..... iox_$attach_name(ioname,iocb_ptr,descrip,ref_ptr) ..... */

attach_name:
     entry (ioname, iocb_ptr, input_descrip, ref_ptr, ret_code);

	caller_ptr = ref_ptr;
	loud_sw = "0"b;
	go to FIND_IO;

/* Beginning of entry point ..... iox_$attach_ioname(ioname,iocb_ptr,descrip) ..... */

attach_ioname:
     entry (ioname, iocb_ptr, input_descrip, ret_code);

	caller_ptr = null ();
	loud_sw = "0"b;

FIND_IO:
	call iox_find_iocb$find_iocb (ioname, iocb_ptr, code);
	if code ^= 0 then goto ATTACH_RETURN;
	go to ATTACH;

/* Beginning of entry point ..... iox_$attach_ptr(iocb_ptr,descrip,ref_ptr) ..... */

attach_ptr:
     entry (iocb_ptr, input_descrip, ref_ptr, ret_code);

	caller_ptr = ref_ptr;
	loud_sw = "0"b;
	go to ATTACH;

/* Beginning of entry point ..... iox_$attach_iocb(iocb_ptr,descrip) ..... */

attach_iocb:
     entry (iocb_ptr, input_descrip, ret_code);

	caller_ptr = null ();
	loud_sw = "0"b;
	go to ATTACH;

/* Beginning of entry point ..... iox_$attach_loud(iocb_ptr, descrip, ref_ptr, code) ..... */

attach_loud:
     entry (iocb_ptr, input_descrip, ref_ptr, ret_code);

          caller_ptr = ref_ptr;
	loud_sw = "1"b;

/* Extract the first token in the description string, which is the Module name. */

ATTACH:
          descrip = input_descrip;

	i = index (descrip, " ") - 1;
	if i < 0 then i = length (descrip);
	if i = 0 then do;
	     code = error_table_$noarg;
	     goto ATTACH_RETURN;
	     end;

/* If a pathname is given, initiate the specified DIM. */

          pname = substr(descrip, 1, i);
	rem_descrip = substr(descrip, i + 1);

	attach_ent, dir, ent = "";

	i = search(reverse(pname), "<>$");		/* Look for special chars. */

	if i = 0
	then ent = pname;				/* The simplist case. */
	else do;					/* Must break description into components. */
	     i = length(pname) - i + 1;
	     if substr(pname, i, 1) = "$"		/* An entry was specified, use it. */
	     then do;				/* Save entry name for later. */
	          if i < length(pname)
		then attach_ent = substr(pname, i + 1);
		i = i - 1;
	     end;
	     else i = length(pname);			/* No entry specified by user. */
	     pname = substr(pname, 1, i);
	     if search (substr (descrip, 1, i), "<>") ^= 0
               then do;				/* must be pathname */
	          call expand_pathname_ (pname, dir, ent, code);
	          if code ^= 0 then goto ATTACH_RETURN;
	          code = term_$single_refname ((ent));	/* To avoid refname problems. */
	          code = hcs_$initiate_count (dir, ent, ent, 0, 1, p);
	          if p = null () then goto ATTACH_RETURN;
	          caller_ptr = null ();
	     end;
	     else ent = pname;
	end;

	if attach_ent = ""
	then attach_ent = rtrim(ent) || "attach";

	call hcs_$make_entry (caller_ptr, ent, attach_ent, entry_var, code);
	if code ^= 0 then goto ATTACH_RETURN;

/* Now scan the remainder of the description string, counting tokens (tn) and
   remembering the longest length (m). */

	call iox_measure_options ((rem_descrip), n_options, max_option_len, code);
	if code ^= 0 then goto ATTACH_RETURN;

	begin;

dcl  option_array (n_options) char (max_option_len) var;

	     call iox_get_options ((rem_descrip), option_array, code);
	     if code ^= 0 then goto ATTACH_RETURN;

/* Finally, call the Module to actually perform the attach. */

	     call entry_var (iocb_ptr, option_array, loud_sw, code);
	end;

ATTACH_RETURN:
	ret_code = code;

     end iox_attach_name;




		    iox_close_file.pl1              11/11/89  1108.2r w 11/11/89  0806.5       18027



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */

/* format: style4,inddcls,^ifthendo,^indproc */
iox_close_file: proc();

          return;					/* Not a legal entry. */

/* Written 11/29/82 by S. Krupp. */

/* Automatic */

	dcl  code fixed bin (35);
	dcl  description char(length(arg_descrip));
	dcl  entry_var entry (ptr, (*) char (*) var, fixed bin (35)) variable;
	dcl  iocb_ptr ptr;
	dcl  max_option_len fixed bin (21);
	dcl  n_options fixed bin (21);

/* Builtin */

	dcl  length builtin;

/* Entries */

	dcl  iox_get_options entry (char (*), (*) char (*) var, fixed bin (35));
	dcl  iox_measure_options entry (char (*), fixed bin (21), fixed bin (21), fixed bin (35));

/* Parameter */

	dcl  arg_code fixed bin (35);
	dcl  arg_descrip char (*);
	dcl  arg_iocb_ptr ptr;

%page;
%include iocb;
%page;

/*
   * This program, given a close description, breaks up the description
   * into its elements and then calls the appropriate I/O module entry.
*/

close_file: entry(arg_iocb_ptr, arg_descrip, arg_code);

	iocb_ptr = arg_iocb_ptr -> iocb.actual_iocb_ptr;
	description = arg_descrip;
	code = 0;

	call iox_measure_options (description, n_options, max_option_len, code);
	if code ^= 0
	then goto CLOSE_RETURN;

	begin;

	     dcl	option_array (n_options) char (max_option_len) var;

	     call iox_get_options (description, option_array, code);
	     if code ^= 0
	     then goto CLOSE_RETURN;

	     entry_var = iocb_ptr -> iocb.close_file;
	     call entry_var (iocb_ptr, option_array, code);

	end;

CLOSE_RETURN:

	arg_code = code;

     end iox_close_file;




		    iox_detach.pl1                  11/11/89  1108.2r w 11/11/89  0805.9       17919



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */

/* format: style4,inddcls,^ifthendo,^indproc */
iox_detach: proc();

          return;					/* Not a legal entry. */

/* Written 11/29/82 by S. Krupp. */

/* Automatic */

	dcl  code fixed bin (35);
	dcl  description char(length(arg_descrip));
	dcl  entry_var entry (ptr, (*) char (*) var, fixed bin (35)) variable;
	dcl  iocb_ptr ptr;
	dcl  max_option_len fixed bin (21);
	dcl  n_options fixed bin (21);

/* Builtin */

	dcl  length builtin;

/* Entries */

	dcl  iox_get_options entry (char (*), (*) char (*) var, fixed bin (35));
	dcl  iox_measure_options entry (char (*), fixed bin (21), fixed bin (21), fixed bin (35));

/* Parameter */

	dcl  arg_code fixed bin (35);
	dcl  arg_descrip char (*);
	dcl  arg_iocb_ptr ptr;

%page;
%include iocb;
%page;

/*
   * This program, given a detach description, breaks up the description
   * into its elements and then calls the appropriate I/O module entry.
*/

detach: entry(arg_iocb_ptr, arg_descrip, arg_code);

	iocb_ptr = arg_iocb_ptr -> iocb.actual_iocb_ptr;
	description = arg_descrip;
	code = 0;

	call iox_measure_options (description, n_options, max_option_len, code);
	if code ^= 0
	then goto DETACH_RETURN;

	begin;

	     dcl	option_array (n_options) char (max_option_len) var;

	     call iox_get_options (description, option_array, code);
	     if code ^= 0
	     then goto DETACH_RETURN;

	     entry_var = iocb_ptr -> iocb.detach;
	     call entry_var (iocb_ptr, option_array, code);

	end;

DETACH_RETURN:

	arg_code = code;

     end iox_detach;




		    iox_find_iocb.pl1               11/11/89  1108.2r w 11/11/89  0804.2      175095



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


/* format: style2 */
iox_find_iocb: proc();

          return;					/* Not a legal entry. */

/* Modified Benson I. Margulies 1981 03 07 for hashing. No previous journalization?! */
/* Modified 11/82 by S. Krupp to initialize new variables in version 2 iocb. */
/* Modified C. Spitzer not to fault when passed a null pointer.	       */
/* Parameters. */

	declare (
	        P_iocb_name		 char (*),	/* Name of sought I/O control block. */
	        P_iocb_ptr		 pointer,		/* Returned location of I/O control block. */
	        P_code		 fixed bin (35),
	        (P_iocb_ptr1, P_iocb_ptr2)
				 pointer,		/* From and to locations for move_attach. */
	        P_iocb_n		 fixed bin
	        ) /* Number of sought I/O control block. */
				 parameter;	/* Automatic. */

	declare critical_op_in_progress
				 bit (1);
	declare hash_chain_anchor	 pointer based (ptr_to_hash_tbl_ptr);
	declare ptr_to_hash_tbl_ptr	 pointer;
	declare hash_ptr		 pointer;
	declare hash_table_ptr	 pointer;
	declare iocb_ptr		 pointer;
	declare iocb_ptr1		 pointer;
	declare iocb_ptr2		 pointer;
	declare iocb_ptr3		 ptr;		/* Father IOCB ptr used by move_attach. */
	declare just_looking	 bit (1);		/* "1"b if called "look_iocb" rather than "find_iocb". */
	declare move_switch		 bit (1);		/* initialize_iocb works different for move_attach. */
	declare name		 char (32) aligned; /* Local copy of sought name. */
	declare syn_son		 ptr;		/* Place to save iocb.syn_son. */
	declare (i, j)		 fixed;
	declare mask		 bit (36) aligned;	/* Save existing IPS mask while inhibited. */

/* External static. */

	declare iox_$hash_table	 external static;
	declare iox_$hash_table_ptr	 ptr external static;
	declare iox_$hash_table_size	 fixed bin (35) aligned external static;
	declare iox_$hash_hit_count	 fixed bin (35) external static;
						/* meter hash hits when we make a new one in a chain */
	declare iox_$n_standard_iocbs	 fixed bin external static;
	declare iox_$standard_iocb_ptrs
				 bit (36) aligned external static;

/* external entries */

	declare iox_$propagate	 external entry (pointer);
	declare hash_index_		 entry (pointer, fixed bin (35) aligned, fixed bin (35) aligned,
				 fixed bin (35) aligned) returns (fixed bin (35) aligned) reducible;

	declare hcs_$set_ips_mask	 ext entry (bit (36) aligned, bit (36) aligned);
	declare hcs_$reset_ips_mask	 ext entry (bit (36) aligned, bit (36) aligned);
	declare iox_$err_no_operation  entry() options(variable);
	declare iox_$err_not_attached	 ext entry options (variable);
	declare iox_$err_not_open	 ext entry options (variable);
	declare sub_err_		 ext entry options (variable);
	declare terminate_process_	 ext entry (char (*), ptr);


/* Error Table Codes */

	declare (
	        error_table_$unable_to_do_io,
	        error_table_$not_a_valid_iocb,
	        error_table_$no_iocb,
	        error_table_$not_attached,
	        error_table_$not_detached,
	        error_table_$name_not_found
	        )			 external static fixed bin (35);

/* Based. */

	declare hash_table		 dimension (iox_$hash_table_size) pointer based (hash_table_ptr);
	declare system_free_area	 area based (stackbaseptr () -> stack_header.system_free_ptr);
						/* get_system_free_area_ is not cheap */

	declare any_other		 condition;

/* Built-in. */

	declare (addr, length, null, rank, rtrim, substr, stackbaseptr)
				 builtin;
%page;
%include iocbx;
%include stack_header;
%page;
/* iox_$find_iocb */

find_iocb: entry (P_iocb_name, P_iocb_ptr, P_code);

	just_looking = "0"b;			/* Remember "find", not "look", was called. */
	go to join;				/* Go join common table search. */

/* iox_$look_iocb */

look_iocb:
     entry (P_iocb_name, P_iocb_ptr, P_code);

	just_looking = "1"b;			/* Remember "look", not "find", was called. */

join:
	call setup;
	move_switch = "0"b;				/* this is not move_iocb */
	name = P_iocb_name;				/* Copy name so no one changes it under us. */
	P_iocb_ptr = null ();
	iocb_ptr = null ();				/* Prepare to search IOCB table. */
	on any_other call handler;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* the original strategy of this program was as follows: All iocbs were allocated in	*/
/* blocks of five. The blocks were chained, but the iocbs themselves were not. Destroyed	*/
/* iocb's were not deallocated, but were left in place. Free or used iocbs were found by	*/
/* a linear search down the blocks. Since no operation ever changed the threading of	*/
/* blocks except to add a new one, this search could be made without masking off ips	*/
/* signals. It had to be, because it could be long. A pseudo-clock, changed_at, was used	*/
/* to detect modification during the search, which caused the search to be retried.	*/
/*									*/
/* The new scheme assumes that the area package is at least as good as managing iocb	*/
/* sized blocks of stuff as hand code that chases a chain. Iocbs are individually	*/
/* allocated with allocate statements, and freed when destroyed. Iocbs are found by way	*/
/* of a hash table, with chains for the buckets. Because these chains can be changed by a */
/* freed iocb, the search down one must take place with ips signals masked. It is not	*/
/* expected that these chains will ever get long enough to make masking impractical. If	*/
/* they do, the hash table can be enlarged, or the hash function improved.                */
/******************************************************************************************/

	call set_ips_mask;

/* use based variable to avoid lots of subscripting */
/* hash_chain_anchor is based on this pointer */
	ptr_to_hash_tbl_ptr = addr (hash_table (hash_search (name)));

	iocb_ptr = chase_chain (hash_chain_anchor, name);

	if iocb_ptr = null ()			/* not in the chain */
	then do;
		if just_looking			/* do not create if not found */
		then P_code = error_table_$no_iocb;
		else do;
			allocate iocb in (system_free_area) set (iocb_ptr);

			call initialize_iocb_values (iocb_ptr, name);
			call link_in_iocb (hash_chain_anchor, iocb_ptr, name);
		     end;
	     end;
	call reset_ips_mask;
	P_iocb_ptr = iocb_ptr;
	return;
%page;
destroy_iocb:
     entry (P_iocb_ptr, P_code);

	iocb_ptr = P_iocb_ptr;
	if iocb_ptr = null () then do;
	     P_code = 0;				/* already gone */
	     return;				/* nothing to do anymore */
	     end;
	call check_sentinel (iocb_ptr);
	call setup;
	on any_other call handler;
	call set_ips_mask;

	if iocb_ptr -> iocb.name = ""			/* freed but had another ptr */
	then do;
		P_code = 0;
		P_iocb_ptr = null ();
	     end;

	else if iocb_ptr -> iocb.attach_descrip_ptr ^= null ()
	then P_code = error_table_$not_detached;

	else if iocb_ptr -> iocb.syn_son ^= null ()
	then P_code = error_table_$not_detached;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* There is a special case here for the iox_ variables. To prevent inconsistencies, we	*/
/* must check if the iocb being destroyed is one of the standard iocbs. It so, we	*/
/* must insure that the iox_ pointers are nulled as well.				*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	else do;					/* OK to destroy it. */
		call check_standard_iocbs (iocb_ptr);
		call flush_iocb (iocb_ptr);
		P_iocb_ptr = null ();		/* Reset caller's IOCB pointer. */
		P_code = 0;			/* No errors. */
	     end;

	call reset_ips_mask;
	return;
%page;
find_iocb_n:
     entry (P_iocb_n, P_iocb_ptr, P_code);
	j = 0;					/* Count the non-null IOCBxs. */
	call setup;
	on any_other call handler;

	do i = 1 to iox_$hash_table_size;		/* look at each hash bucket */
	     if hash_table (i) ^= null ()
	     then do;
		     call set_ips_mask;
		     do iocb_ptr = hash_table (i)
			repeat iocb_ptr -> iocb.hash_chain_ptr /* and consider each in the chain */
			while (iocb_ptr ^= null ());
			j = j + 1;
			if j = P_iocb_n
			then do;
				P_iocb_ptr = iocb_ptr;
				call reset_ips_mask;
				return;
			     end;
		     end;
		     call reset_ips_mask;
		end;
	end;
	P_iocb_ptr = null ();			/* Didn't find it. */
	P_code = error_table_$no_iocb;
	return;
%page;
move_attach:
     entry (P_iocb_ptr1, P_iocb_ptr2, P_code);

	move_switch = "1"b;
	iocb_ptr1 = P_iocb_ptr1;
	iocb_ptr2 = P_iocb_ptr2;
	if iocb_ptr1 = null () | iocb_ptr2 = null ()
	then do;
		P_code = error_table_$no_iocb;
		return;
	     end;

	call check_sentinel (iocb_ptr1);
	call check_sentinel (iocb_ptr2);

	if iocb_ptr1 = iocb_ptr2
	then P_code = 0;

	else if iocb_ptr1 -> iocb.attach_descrip_ptr = null ()
	then /* Original block must be attached. */
	     P_code = error_table_$not_attached;

	else if iocb_ptr2 -> iocb.attach_descrip_ptr ^= null ()
	then /* Target block must be detached. */
	     P_code = error_table_$not_detached;

	else do;
		call setup;
		on any_other call handler;
		call set_ips_mask;

/* Copy the IOCB. */

		name = iocb_ptr2 -> iocb.name;	/* Save target's name. */
		syn_son = iocb_ptr2 -> iocb.syn_son;	/* Save target's syn son. */
		hash_ptr = iocb_ptr2 -> iocb.hash_chain_ptr;
						/* Save hash chain ptr */

		iocb_ptr2 -> iocb = iocb_ptr1 -> iocb;	/* Copy contents of block. */
		iocb_ptr2 -> iocb.name = name;	/* Restore target's name. */
		iocb_ptr2 -> iocb.syn_son = syn_son;	/* Restore target's syn son. */
		iocb_ptr2 -> iocb.hash_chain_ptr = hash_ptr;
						/* Restore hash chain */
		if iocb_ptr1 -> iocb.actual_iocb_ptr = iocb_ptr1
		then iocb_ptr2 -> iocb.actual_iocb_ptr = iocb_ptr2;
						/* Reset actual_iocb_ptr. */

/* Thread target block in place of the original block if syn'd. */

		else do;
			call set_critical;
			iocb_ptr3 = iocb_ptr1 -> iocb.syn_father;
			if iocb_ptr3 -> iocb.syn_son = iocb_ptr1
			then iocb_ptr3 -> iocb.syn_son = iocb_ptr2;
			else do;
				do iocb_ptr3 = iocb_ptr3 -> iocb.syn_son
				     repeat iocb_ptr3 -> iocb.syn_brother
				     while (iocb_ptr3 -> iocb.syn_brother ^= iocb_ptr1);
				end;
				iocb_ptr3 -> iocb.syn_brother = iocb_ptr2;
			     end;
			call reset_critical;
		     end;

		call initialize_iocb_values (iocb_ptr1, iocb_ptr1 -> iocb.name);
						/* Initialize original block to detached state, leaving hash chain alone. */
		call iox_$propagate (iocb_ptr1);	/* Propagate detached state. */
		call iox_$propagate (iocb_ptr2);	/* Propagate changes. */

		call reset_ips_mask;
		P_code = 0;
	     end;
	return;
%page;
/* Internal procedure to initialize an IOCB to the detached state. */

initialize_iocb_values:
     proc (iocb_ptr, iocb_name);
	declare iocb_ptr		 ptr;
	declare iocb_name		 char (32) aligned;

	iocb_ptr -> iocb.version = iox_$iocb_version_sentinel;
	iocb_ptr -> iocb.name = iocb_name;
	iocb_ptr -> iocb.actual_iocb_ptr = iocb_ptr;
	iocb_ptr -> iocb.attach_descrip_ptr, iocb_ptr -> iocb.attach_data_ptr, iocb_ptr -> iocb.open_descrip_ptr,
	     iocb_ptr -> iocb.open_data_ptr = null ();
	iocb_ptr -> iocb.event_channel = ""b;
	iocb_ptr -> iocb.detach_iocb = iox_$err_not_attached;
	iocb_ptr -> iocb.open = iox_$err_not_attached;
	iocb_ptr -> iocb.close = iox_$err_not_open;
	iocb_ptr -> iocb.get_line = iox_$err_not_open;
	iocb_ptr -> iocb.get_chars = iox_$err_not_open;
	iocb_ptr -> iocb.put_chars = iox_$err_not_open;
	iocb_ptr -> iocb.modes = iox_$err_not_attached;
	iocb_ptr -> iocb.position = iox_$err_not_open;
	iocb_ptr -> iocb.control = iox_$err_not_attached;
	iocb_ptr -> iocb.read_record = iox_$err_not_open;
	iocb_ptr -> iocb.write_record = iox_$err_not_open;
	iocb_ptr -> iocb.rewrite_record = iox_$err_not_open;
	iocb_ptr -> iocb.delete_record = iox_$err_not_open;
	iocb_ptr -> iocb.seek_key = iox_$err_not_open;
	iocb_ptr -> iocb.read_key = iox_$err_not_open;
	iocb_ptr -> iocb.read_length = iox_$err_not_open;
	iocb_ptr -> iocb.open_file = iox_$err_no_operation;
						/* New, version 2. */
	iocb_ptr -> iocb.close_file = iox_$err_no_operation;   /* Version 2. */
	iocb_ptr -> iocb.detach = iox_$err_no_operation;	/* Version 2. */
	iocb_ptr -> iocb.ios_compatibility = null ();
	iocb_ptr -> iocb.syn_inhibits = ""b;
	iocb_ptr -> iocb.syn_father, iocb_ptr -> iocb.syn_brother = null;
	if ^move_switch
	then iocb_ptr -> iocb.syn_son = null;
	/*** do not set hash ptr. It is set by link_in_iocb */

     end initialize_iocb_values;

link_in_iocb:
     procedure (hash_chain_anchor, iocb_ptr, iocb_name);

	declare hash_chain_anchor	 pointer;
	declare iocb_ptr		 pointer;
	declare iocb_name		 character (32) aligned;


	if hash_chain_anchor = null ()
	then do;					/* easy case */
		iocb_ptr -> iocb.hash_chain_ptr = null ();
		hash_chain_anchor = iocb_ptr;
	     end;
	else do;	/*** Thread into beginning. We are most likely to reference the one we just created. */
		/*** Meter this as a hit, as well. */
		call set_critical;
		iocb_ptr -> iocb.hash_chain_ptr = hash_chain_anchor;
		hash_chain_anchor = iocb_ptr;
		call reset_critical;
		iox_$hash_hit_count = iox_$hash_hit_count + 1;
	     end;
     end link_in_iocb;

flush_iocb:
     procedure (iocb_ptr);

	declare iocb_ptr		 pointer;
	declare hi		 fixed bin;
	declare cp		 pointer;

	hi = hash_search (iocb_ptr -> iocb.name);

	if hash_table (hi) = null ()
	then call iocb_missing_from_chain (iocb_ptr, hi, hash_table (hi));
	if hash_table (hi) = iocb_ptr
	then hash_table (hi) = hash_table (hi) -> iocb.hash_chain_ptr;
	else do;					/* nontrivial, find the one to link out */
		do cp = hash_table (hi) repeat cp -> iocb.hash_chain_ptr while (cp -> iocb.hash_chain_ptr ^= null ());
		     if cp -> iocb.hash_chain_ptr = iocb_ptr
		     then do;
			     cp -> iocb.hash_chain_ptr = cp -> iocb.hash_chain_ptr -> iocb.hash_chain_ptr;
			     goto linked_out;
			end;			/* Copy chain pointer from defunkt IOCB to previous in chain */
		end;

		/*** if we got here, it was not in the right chain.
		this is a really bad scene */

		call iocb_missing_from_chain (iocb_ptr, hi, hash_table (hi));
						/* this signals an error */
linked_out:
	     end;
	iocb_ptr -> iocb.name = "";			/* sentinel to avoid freeing twice */
	free iocb_ptr -> iocb;
	return;
     end flush_iocb;
%page;
/* Internal procedure to handle faults while IPS interrupts
   are masked.  While not masked, any signals are simply
   passed on up the stack to their normal handlers.  
   If we are restarted then the mask will stay reset.
*/

handler:
     procedure;

	declare continue_to_signal_	 entry (fixed bin (35));

	if mask ^= ""b
	then do;
		if critical_op_in_progress
		then call terminate_this_process;
		call reset_ips_mask;
		call continue_to_signal_ (0);
		return;
	     end;
	else call continue_to_signal_ (0);

     end handler;

chase_chain:
     procedure (start_ptr, name) returns (pointer);

	declare start_ptr		 pointer;
	declare name		 character (32) aligned;
	declare iocb_ptr		 pointer;
	declare 1 IOCB		 aligned like iocb based (iocb_ptr);

	do iocb_ptr = start_ptr repeat IOCB.hash_chain_ptr while (iocb_ptr ^= null ());

	     if IOCB.name = name
	     then return (iocb_ptr);
	end;
	return (null ());
     end chase_chain;

hash_search:
     procedure (name) returns (fixed bin) reducible;

	declare name		 character (32) aligned;
	declare trimmed_length	 fixed bin (35);



/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* The exact hashing function to use here is a bother. Since IOCB names in use at the	*/
/* same time tend to be the same length, and are often 15 or more characters, the	*/
/* variation amongst the characters has an unfortunate habit of averaging out.		*/
/* Especially because many start with something like MUMBLE!BBB. To counteract this	*/
/* problem we use the "ring-number" argument of hash_index_, and give it the rank value	*/
/* of the last character of the name. This is pretty independent of the other		*/
/* characteristics of the string.						*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


	trimmed_length = length (rtrim (name));

	return (1
	     + hash_index_ (addr (name), trimmed_length, rank (substr (name, trimmed_length, 1)), iox_$hash_table_size))
	     ;
     end hash_search;
%page;
is_standard_iocb_ptr:
     procedure (iocb_ptr) returns (bit (1) aligned) reducible;

	declare iocb_ptr		 pointer parameter;
	declare px		 fixed bin;
	declare standard_ptrs_ptr	 pointer;
	declare standard_ptrs	 (iox_$n_standard_iocbs) pointer based (standard_ptrs_ptr);
	declare kill_switch		 bit (1);

	kill_switch = "0"b;
	go to common;

check_standard_iocbs:
     entry (iocb_ptr);

	kill_switch = "1"b;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* The standard attachment iocb_ptrs stored in an array, so this code can properly find	*/
/* them even if more are added later.						*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

common:
	standard_ptrs_ptr = addr (iox_$standard_iocb_ptrs);
	do px = 1 to iox_$n_standard_iocbs;
	     if iocb_ptr = standard_ptrs (px)
	     then if kill_switch
		then standard_ptrs (px) = null ();
		else return ("1"b);
	     else ;
	end;

	if ^kill_switch
	then return ("0"b);
	else return;
     end is_standard_iocb_ptr;

set_ips_mask:
     procedure;
	call hcs_$set_ips_mask (""b, mask);
     end set_ips_mask;

reset_ips_mask:
     procedure;

	if mask ^= ""b
	then call hcs_$reset_ips_mask (mask, mask);
     end reset_ips_mask;

set_critical:
     procedure;

	critical_op_in_progress = "1"b;
	return;

reset_critical:
     entry;

	critical_op_in_progress = "0"b;
     end set_critical;
%page;
iocb_missing_from_chain:
     procedure (iocb_ptr, hash_index, hash_chain_anchor) options (non_quick);

	declare iocb_ptr		 pointer;
	declare hash_index		 fixed bin;
	declare hash_chain_anchor	 pointer;

	call sub_err_ (error_table_$name_not_found, "iox_", "s", null (), (0),
	     "IOCB ^a (^p) missing from hash chain ^d (^p).", iocb_ptr -> iocb.name, iocb_ptr, hash_index,
	     hash_chain_anchor);
     end iocb_missing_from_chain;

terminate_this_process:
     procedure options (non_quick);

	declare 1 ti		 aligned,
		2 version		 fixed,
		2 code		 fixed (35);

	ti.version = 0;
	ti.code = error_table_$unable_to_do_io;
	call terminate_process_ ("fatal_error", addr (ti));

     end terminate_this_process;

setup:
     procedure;

	mask = ""b;
	critical_op_in_progress = "0"b;
	P_code = 0;
	if iox_$hash_table_ptr = null ()
	then iox_$hash_table_ptr = addr (iox_$hash_table);
	hash_table_ptr = iox_$hash_table_ptr;
     end setup;

check_sentinel:
     procedure (iocb_ptr);
	declare iocb_ptr		 pointer;

	if iocb_ptr -> iocb.version ^= iox_$iocb_version_sentinel
	then do;
		P_code = error_table_$not_a_valid_iocb;
		go to main_block_return;
	     end;
     end check_sentinel;

main_block_return:
	return;

     end iox_find_iocb;




		    iox_get_options.pl1             11/11/89  1108.2rew 11/11/89  0805.2       21699



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */

/* format: style4,inddcls,^ifthendo,^indproc,indcom,^indblkcom,declareind8,dclind4 */

iox_get_options: proc (arg_description, arg_option_array, arg_code);

     /* Removed from attach_name.pl1 4/83 by S. Krupp. */

     /* Automatic */

	dcl descrip char (length (arg_description)) var;
	dcl first_option_num fixed bin;
	dcl i fixed bin;
	dcl last_option_num fixed bin;
	dcl n_options fixed bin;
	dcl t fixed bin;
	dcl tn fixed bin;
	dcl ts fixed bin;
	dcl x fixed bin;
	dcl y fixed bin;

     /* Builtin */

	dcl (index, length, ltrim, rtrim, search, substr, verify) builtin;

     /* Parameter */

	dcl arg_code fixed bin (35);
	dcl arg_description char (*);
	dcl arg_option_array (*) char (*) var;

	arg_code = 0;
	arg_option_array (*) = "";

	descrip = ltrim (rtrim (arg_description));
	if descrip = ""
	then return;

	first_option_num = lbound (arg_option_array, 1);
	last_option_num = hbound (arg_option_array, 1);
	n_options = last_option_num - first_option_num + 1;
	if n_options <= 0
	then return;

	tn = first_option_num - 1;
	ts = 1;

more1:
	tn = tn + 1;
	i = verify (substr (descrip, ts), "	 ") - 1;
	if i < 0 then goto done1;
	ts = ts + i;

continue1:
	x = search (substr (descrip, ts), "	"" ") - 1;
	if x < 0 then goto done1;

	arg_option_array (tn) = arg_option_array (tn) || substr (descrip, ts, x);
	t = ts + x + 1;
	if substr (descrip, t - 1, 1) = """" then do;
pass1:
	     y = index (substr (descrip, t), """") - 1;

	     arg_option_array (tn) = arg_option_array (tn) || substr (descrip, t, y);
	     ts = t + y + 1;
	     if ts <= length (descrip)
	     then if substr (descrip, ts, 1) = """" then do;
		     arg_option_array (tn) = arg_option_array (tn) || """";
		     t = ts + 1;
		     x = 0;
		     goto pass1;
		end;
	     goto continue1;
	end;
	ts = t;
	goto more1;

done1:
	arg_option_array (tn) = arg_option_array (tn) || substr (descrip, ts, length (descrip) - ts + 1);

     end iox_get_options;




		    iox_init_.pl1                   11/11/89  1108.2rew 11/11/89  0806.5       30501



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


/* procedure to initialize the user ring iox_ environment */
/* The process is terminated in this program on failure so that stack history
   will be useful. It this program returned a code it would be
   lose the information of what attachment failed. Already_attached
   switches are not considered to be errors so that calling this
   program twice will not kill the process. */

/* format: style2 */

iox_init_:
     procedure;
	return;

/*
This procedure attached the switches specified in the constant
data in iox_.alm for a standard user ring io system.
*/

	declare iox_$n_standard_iocbs	 fixed bin (35) external static;
	declare iox_$standard_iocb_ptrs
				 bit (36) aligned external static;
	declare iox_$standard_iocb_info
				 bit (36) aligned external static;

	declare iocb_ptrs_ptr	 pointer;
	declare iocb_info_ptr	 pointer;
	declare i			 fixed bin;

	declare 1 iocb_info		 (iox_$n_standard_iocbs) aligned based (iocb_info_ptr),
		2 name		 character (32) unaligned,
		2 attach_description character (72) unaligned;

	declare iocb_ptrs		 (iox_$n_standard_iocbs) pointer aligned based (iocb_ptrs_ptr);

	declare code		 fixed bin (35);

	declare error_table_$not_detached
				 fixed bin (35) external static;

	declare iox_$attach_name	 entry (character (*), pointer, character (*), pointer, fixed bin (35));
	declare iox_$find_iocb	 entry (character (*), pointer, fixed bin (35));


init_standard_iocbs:
     entry;
	iocb_ptrs_ptr = addr (iox_$standard_iocb_ptrs);
	iocb_info_ptr = addr (iox_$standard_iocb_info);

	do i = 1 to iox_$n_standard_iocbs;
	     code = 0;
	     if iocb_info.attach_description (i) ^= ""
	     then call iox_$attach_name (iocb_info.name (i), iocb_ptrs (i), rtrim (iocb_info.attach_description (i)),
		     null (), code);		/* allow io modules in the home directory */
	     else call iox_$find_iocb (iocb_info.name (i), iocb_ptrs (i), code);
	     if code ^= 0 & code ^= error_table_$not_detached
	     then call failure (code, i, iocb_ptrs (i), iocb_info.name (i), rtrim (iocb_info.attach_description (i)));

	end;
	return;

failure:
     procedure (code, switchx, iocb_ptr, name, atd) options (non_quick);

	/*** the stack frame of this procedure is very informative
	     in a saved dead process */

	declare code		 fixed bin (35);
	declare switchx		 fixed bin;
	declare iocb_ptr		 pointer;
	declare name		 character (32);
	declare atd		 character (72);
	declare terminate_process_	 entry (char (*), ptr);

	declare 1 terminate_info	 aligned,
		2 version		 fixed bin,
		2 s_code		 fixed bin (35);

	terminate_info.version = 0;
	terminate_info.s_code = code;

	call terminate_process_ ("io_attach", addr (terminate_info));
     end failure;
     end iox_init_;




		    iox_measure_options.pl1         11/11/89  1108.2rew 11/11/89  0804.2       23715



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */

/* format: style4,inddcls,^ifthendo,^indproc,indcom,^indblkcom,declareind8,dclind4 */

iox_measure_options: proc (arg_description, arg_n_options, arg_max_option_len, arg_code);

     /* Removed from attach_name.pl1 4/83 by S. Krupp. */

     /* Automatic */

	dcl as fixed bin;
	dcl code fixed bin;
	dcl descrip char (length (arg_description)) var;
	dcl i fixed bin;
	dcl m fixed bin;
	dcl t fixed bin;
	dcl tn fixed bin;
	dcl ts fixed bin;
	dcl x fixed bin;
	dcl y fixed bin;

     /* Builtin */

	dcl (index, length, ltrim, max, rtrim, search, substr, verify) builtin;

     /* Parameter */

	dcl arg_code fixed bin (35);
	dcl arg_description char (*);
	dcl arg_max_option_len fixed bin;
	dcl arg_n_options fixed bin;

     /* Static */

	dcl error_table_$unbalanced_quotes fixed bin (35) ext static;

	arg_n_options = 0;
	arg_max_option_len = 0;
	arg_code = 0;

	descrip = ltrim (rtrim (arg_description));

	if descrip = ""
	then return;				/* Nothing to scan. */

     /* Scan the description string, counting tokens (tn) and remembering the
        longest length (m). */


	code = 0;
	tn = 0;
	m = 0;
	ts = 1;

more:
	as = 1;
	i = verify (substr (descrip, ts), "	 ") - 1;	/* Skip over blanks and tabs */
	if i < 0 then goto done;
	ts = ts + i;
	tn = tn + 1;

continue:
	x = search (substr (descrip, ts), "	"" ") - 1;/* quotes, blanks, and tabs */
	if x < 0 then goto done;

	as = as + x;
	t = ts + x + 1;
	if substr (descrip, t - 1, 1) = """"		/* terminator found was a quote */
	then do;
pass:
	     y = index (substr (descrip, t), """") - 1;	/* search for matching quote */
	     if y < 0
	     then do;
		code = error_table_$unbalanced_quotes;
		goto ERROR_RETURN;
	     end;

	     as = as + y;
	     ts = t + y + 1;
	     if ts <= length (descrip)
	     then if substr (descrip, ts, 1) = """"	/* double quote encountered */
		then do;
		     as = as + 1;
		     t = ts + 1;
		     x = 0;
		     goto pass;
		end;
	     goto continue;
	end;
	ts = t;
	m = max (m, as - 1);
	goto more;

done:
	m = max (m, as + length (descrip) - ts);

	arg_n_options = tn;
	arg_max_option_len = m;

ERROR_RETURN:

	arg_code = code;

     end iox_measure_options;




		    iox_open_file.pl1               11/11/89  1108.2r w 11/11/89  0803.9       19161



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */

/* format: style4,inddcls,^ifthendo,^indproc */

iox_open_file: proc();

          return;					/* Not a legal entry. */

/* Written 11/29/82 by S. Krupp. */

/* Automatic */

	dcl  code fixed bin (35);
	dcl  description char(length(arg_descrip));
	dcl  entry_var entry (ptr, fixed bin, (*) char (*) var, bit (1) aligned, fixed bin (35)) variable;
	dcl  iocb_ptr ptr;
	dcl  max_option_len fixed bin (21);
	dcl  n_options fixed bin (21);

/* Builtin */

	dcl  length builtin;

/* Entries */

	dcl  iox_get_options entry (char (*), (*) char (*) var, fixed bin (35));
	dcl  iox_measure_options entry (char (*), fixed bin (21), fixed bin (21), fixed bin (35));

/* Parameter */

	dcl  arg_code fixed bin (35);
	dcl  arg_descrip char (*);
	dcl  arg_iocb_ptr ptr;
	dcl  arg_mode fixed bin;
	dcl  arg_unused bit (1) aligned;

%page;
%include iocb;
%page;

/*
   * This program, given an open description, breaks up the description
   * into its elements and then calls the appropriate I/O module entry.
*/

open_file: entry(arg_iocb_ptr, arg_mode, arg_descrip, arg_unused, arg_code);

	iocb_ptr = arg_iocb_ptr -> iocb.actual_iocb_ptr;
	description = arg_descrip;
	code = 0;

	call iox_measure_options (description, n_options, max_option_len, code);
	if code ^= 0
	then goto OPEN_RETURN;

	begin;

	     dcl	option_array (n_options) char (max_option_len) var;

	     call iox_get_options (description, option_array, code);
	     if code ^= 0
	     then goto OPEN_RETURN;

	     entry_var = iocb_ptr -> iocb.open_file;
	     call entry_var (iocb_ptr, arg_mode, option_array, arg_unused, code);

	end;

OPEN_RETURN:

	arg_code = code;

     end iox_open_file;




		    iox_propagate.pl1               11/11/89  1108.2rew 11/11/89  0803.9       95229



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

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend */
iox_propagate: proc();

          return;					/* Not a legal entry. */

/* Pointers. */

dcl  (iocb_ptr, a_iocb_ptr, father_iocb_ptr) ptr;

/* Based. */

%include iocbx;

/* Constants. */


dcl  iox_$err_no_operation ext entry options (variable);
dcl  iox_$err_not_attached ext entry options (variable);
dcl  iox_$err_not_closed ext entry options (variable);
dcl  iox_$err_not_open ext entry options (variable);
dcl  iox_$err_old_dim ext entry options (variable);
dcl  open_bit bit (36) int static init ("100000000000000"b);
dcl  close_bit bit (36) int static init ("010000000000000"b);
dcl  get_line_bit bit (36) int static init ("001000000000000"b);
dcl  get_chars_bit bit (36) int static init ("000100000000000"b);
dcl  put_chars_bit bit (36) int static init ("000010000000000"b);
dcl  modes_bit bit (36) int static init ("000001000000000"b);
dcl  position_bit bit (36) int static init ("000000100000000"b);
dcl  control_bit bit (36) int static init ("000000010000000"b);
dcl  read_record_bit bit (36) int static init ("000000001000000"b);
dcl  write_record_bit bit (36) int static init ("000000000100000"b);
dcl  rewrite_record_bit bit (36) int static init ("000000000010000"b);
dcl  delete_record_bit bit (36) int static init ("000000000001000"b);
dcl  seek_key_bit bit (36) int static init ("000000000000100"b);
dcl  read_key_bit bit (36) int static init ("000000000000010"b);
dcl  read_length_bit bit (36) int static init ("000000000000001"b);

/* Built-in. */

dcl  null builtin;

/* End of declarations. */





/* Beginning of entry point ..... iox_$propagate(iocb_ptr) ..... */

propagate: entry(a_iocb_ptr);

	iocb_ptr = a_iocb_ptr;
	if iocb_ptr = null () then return;
	if iocb_ptr -> iocb.version ^= iox_$iocb_version_sentinel then return;
	if iocb_ptr -> iocb.actual_iocb_ptr = iocb_ptr then do;
						/* Not a SYN attachment, ensure IOCB consistent. */
	     if iocb_ptr -> iocb.attach_descrip_ptr = null () then do;
						/* IOCB is detached. */
		iocb_ptr -> iocb.attach_data_ptr, iocb_ptr -> iocb.open_descrip_ptr,
						/* "open_data_ptr" is reset below. */
		     iocb_ptr -> iocb.ios_compatibility = null ();
		iocb_ptr -> iocb.event_channel = "0"b;
		iocb_ptr -> iocb.detach_iocb = iox_$err_not_attached;
		iocb_ptr -> iocb.open = iox_$err_not_attached;
		iocb_ptr -> iocb.modes = iox_$err_not_attached;
		iocb_ptr -> iocb.control = iox_$err_not_attached;
		end;
	     else if iocb_ptr -> iocb.open_descrip_ptr = null () then do;
						/* IOCB is closed. */
		if iocb_ptr -> iocb.open = iox_$err_not_attached | iocb_ptr -> iocb.open = iox_$err_not_closed
		then iocb_ptr -> iocb.open = iox_$err_no_operation;
		if iocb_ptr -> iocb.control = iox_$err_no_operation | iocb_ptr -> iocb.control = iox_$err_not_attached
		then iocb_ptr -> iocb.control = iox_$err_not_open;
		if iocb_ptr -> iocb.modes = iox_$err_no_operation | iocb_ptr -> iocb.modes = iox_$err_not_attached
		then iocb_ptr -> iocb.modes = iox_$err_not_open;
		end;
	     if iocb_ptr -> iocb.open_descrip_ptr = null () then do;
						/* IOCB is detached or closed. */
		iocb_ptr -> iocb.open_data_ptr = null ();
		if iocb_ptr -> iocb.close ^= iox_$err_old_dim then iocb_ptr -> iocb.close = iox_$err_not_open;
		if iocb_ptr -> iocb.get_line ^= iox_$err_old_dim then iocb_ptr -> iocb.get_line = iox_$err_not_open;
		if iocb_ptr -> iocb.get_chars ^= iox_$err_old_dim then iocb_ptr -> iocb.get_chars = iox_$err_not_open;
		if iocb_ptr -> iocb.put_chars ^= iox_$err_old_dim then iocb_ptr -> iocb.put_chars = iox_$err_not_open;
		if iocb_ptr -> iocb.position ^= iox_$err_old_dim then iocb_ptr -> iocb.position = iox_$err_not_open;
		if iocb_ptr -> iocb.read_record ^= iox_$err_old_dim
		then iocb_ptr -> iocb.read_record = iox_$err_not_open;
		if iocb_ptr -> iocb.write_record ^= iox_$err_old_dim
		then iocb_ptr -> iocb.write_record = iox_$err_not_open;
		if iocb_ptr -> iocb.rewrite_record ^= iox_$err_old_dim
		then iocb_ptr -> iocb.rewrite_record = iox_$err_not_open;
		if iocb_ptr -> iocb.delete_record ^= iox_$err_old_dim
		then iocb_ptr -> iocb.delete_record = iox_$err_not_open;
		if iocb_ptr -> iocb.seek_key ^= iox_$err_old_dim then iocb_ptr -> iocb.seek_key = iox_$err_not_open;
		if iocb_ptr -> iocb.read_key ^= iox_$err_old_dim then iocb_ptr -> iocb.read_key = iox_$err_not_open;
		if iocb_ptr -> iocb.read_length ^= iox_$err_old_dim
		then iocb_ptr -> iocb.read_length = iox_$err_not_open;
		end;
	     else do;				/* IOCB is open. */
		if iocb_ptr -> iocb.detach_iocb ^= iox_$err_old_dim
		then iocb_ptr -> iocb.detach_iocb = iox_$err_not_closed;
		if iocb_ptr -> iocb.open ^= iox_$err_old_dim then iocb_ptr -> iocb.open = iox_$err_not_closed;
		if iocb_ptr -> iocb.get_line = iox_$err_not_open
		then iocb_ptr -> iocb.get_line = iox_$err_no_operation;
		if iocb_ptr -> iocb.get_chars = iox_$err_not_open
		then iocb_ptr -> iocb.get_chars = iox_$err_no_operation;
		if iocb_ptr -> iocb.put_chars = iox_$err_not_open
		then iocb_ptr -> iocb.put_chars = iox_$err_no_operation;
		if iocb_ptr -> iocb.modes = iox_$err_not_open then iocb_ptr -> iocb.modes = iox_$err_no_operation;
		if iocb_ptr -> iocb.position = iox_$err_not_open
		then iocb_ptr -> iocb.position = iox_$err_no_operation;
		if iocb_ptr -> iocb.control = iox_$err_not_open then iocb_ptr -> iocb.control = iox_$err_no_operation;
		if iocb_ptr -> iocb.read_record = iox_$err_not_open
		then iocb_ptr -> iocb.read_record = iox_$err_no_operation;
		if iocb_ptr -> iocb.write_record = iox_$err_not_open
		then iocb_ptr -> iocb.write_record = iox_$err_no_operation;
		if iocb_ptr -> iocb.rewrite_record = iox_$err_not_open
		then iocb_ptr -> iocb.rewrite_record = iox_$err_no_operation;
		if iocb_ptr -> iocb.delete_record = iox_$err_not_open
		then iocb_ptr -> iocb.delete_record = iox_$err_no_operation;
		if iocb_ptr -> iocb.seek_key = iox_$err_not_open
		then iocb_ptr -> iocb.seek_key = iox_$err_no_operation;
		if iocb_ptr -> iocb.read_key = iox_$err_not_open
		then iocb_ptr -> iocb.read_key = iox_$err_no_operation;
		if iocb_ptr -> iocb.read_length = iox_$err_not_open
		then iocb_ptr -> iocb.read_length = iox_$err_no_operation;
		end;
	     end;

	father_iocb_ptr = iocb_ptr;
	go to skip;

recurse:
     entry (a_iocb_ptr);

	father_iocb_ptr = a_iocb_ptr;

/* Propagate corrected IOCB fields to all SYN offspring. */

skip:
	do iocb_ptr = father_iocb_ptr -> iocb.syn_son repeat iocb_ptr -> iocb.syn_brother while (iocb_ptr ^= null ());
	     iocb_ptr -> iocb.actual_iocb_ptr = father_iocb_ptr -> iocb.actual_iocb_ptr;
						/* Update each son. */
	     iocb_ptr -> iocb.open_descrip_ptr = father_iocb_ptr -> iocb.open_descrip_ptr;
	     iocb_ptr -> iocb.open_data_ptr = father_iocb_ptr -> iocb.open_data_ptr;
	     iocb_ptr -> iocb.event_channel = father_iocb_ptr -> iocb.event_channel;
	     iocb_ptr -> iocb.ios_compatibility = father_iocb_ptr -> iocb.ios_compatibility;
	     if iocb_ptr -> iocb.syn_inhibits & open_bit
	     then iocb_ptr -> iocb.open = iox_$err_no_operation;
	     else iocb_ptr -> iocb.open = father_iocb_ptr -> iocb.open;
	     if iocb_ptr -> iocb.syn_inhibits & close_bit
	     then iocb_ptr -> iocb.close = iox_$err_no_operation;
	     else iocb_ptr -> iocb.close = father_iocb_ptr -> iocb.close;
	     if iocb_ptr -> iocb.syn_inhibits & get_line_bit
	     then iocb_ptr -> iocb.get_line = iox_$err_no_operation;
	     else iocb_ptr -> iocb.get_line = father_iocb_ptr -> iocb.get_line;
	     if iocb_ptr -> iocb.syn_inhibits & get_chars_bit
	     then iocb_ptr -> iocb.get_chars = iox_$err_no_operation;
	     else iocb_ptr -> iocb.get_chars = father_iocb_ptr -> iocb.get_chars;
	     if iocb_ptr -> iocb.syn_inhibits & put_chars_bit
	     then iocb_ptr -> iocb.put_chars = iox_$err_no_operation;
	     else iocb_ptr -> iocb.put_chars = father_iocb_ptr -> iocb.put_chars;
	     if iocb_ptr -> iocb.syn_inhibits & modes_bit
	     then iocb_ptr -> iocb.modes = iox_$err_no_operation;
	     else iocb_ptr -> iocb.modes = father_iocb_ptr -> iocb.modes;
	     if iocb_ptr -> iocb.syn_inhibits & position_bit
	     then iocb_ptr -> iocb.position = iox_$err_no_operation;
	     else iocb_ptr -> iocb.position = father_iocb_ptr -> iocb.position;
	     if iocb_ptr -> iocb.syn_inhibits & control_bit
	     then iocb_ptr -> iocb.control = iox_$err_no_operation;
	     else iocb_ptr -> iocb.control = father_iocb_ptr -> iocb.control;
	     if iocb_ptr -> iocb.syn_inhibits & read_record_bit
	     then iocb_ptr -> iocb.read_record = iox_$err_no_operation;
	     else iocb_ptr -> iocb.read_record = father_iocb_ptr -> iocb.read_record;
	     if iocb_ptr -> iocb.syn_inhibits & write_record_bit
	     then iocb_ptr -> iocb.write_record = iox_$err_no_operation;
	     else iocb_ptr -> iocb.write_record = father_iocb_ptr -> iocb.write_record;
	     if iocb_ptr -> iocb.syn_inhibits & rewrite_record_bit
	     then iocb_ptr -> iocb.rewrite_record = iox_$err_no_operation;
	     else iocb_ptr -> iocb.rewrite_record = father_iocb_ptr -> iocb.rewrite_record;
	     if iocb_ptr -> iocb.syn_inhibits & delete_record_bit
	     then iocb_ptr -> iocb.delete_record = iox_$err_no_operation;
	     else iocb_ptr -> iocb.delete_record = father_iocb_ptr -> iocb.delete_record;
	     if iocb_ptr -> iocb.syn_inhibits & seek_key_bit
	     then iocb_ptr -> iocb.seek_key = iox_$err_no_operation;
	     else iocb_ptr -> iocb.seek_key = father_iocb_ptr -> iocb.seek_key;
	     if iocb_ptr -> iocb.syn_inhibits & read_key_bit
	     then iocb_ptr -> iocb.read_key = iox_$err_no_operation;
	     else iocb_ptr -> iocb.read_key = father_iocb_ptr -> iocb.read_key;
	     if iocb_ptr -> iocb.syn_inhibits & read_length_bit
	     then iocb_ptr -> iocb.read_length = iox_$err_no_operation;
	     else iocb_ptr -> iocb.read_length = father_iocb_ptr -> iocb.read_length;
	     if iocb_ptr -> iocb.syn_son ^= null then call recurse (iocb_ptr);
	end;
	return;

     end iox_propagate;




		    iox_signal_.pl1                 11/11/89  1108.2rew 11/11/89  0805.2       19053



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


/* format: style2 */
iox_signal_:
     procedure (switch, code) options (support);

/* This procedure signals io_error for iox_. */


/* Coded 8/73 by M. Weaver
   Last modified (date and reason):
   Aug 9, 1977 by S. Webber to make better use of static storage
   Oct 28,1977 by M. R. Jordan to make io_status fixed bin(35) rather than bit(72) aligned
   April 1981 by Benson I. Margulies to rename to iox_signal_ for iox_.
   May 1982 by C. Hornig to use an IOCB pointer.
*/

/* this program is called by routines that use iox_, but have no
   status code in which to return their displeasure. The existing
   examples are ioa_ and listen_ */

	declare switch		 pointer parameter;
	declare code		 fixed bin (35) parameter;
	declare (addr, null, size)	 builtin;

	declare signal_		 entry options (variable);

%include io_error_info;
%include condition_info_header;
	declare 1 io_err_info	 aligned like io_error_info automatic;
%page;
/* fill in info structure */

	io_err_info.length = size (io_err_info);
	io_err_info.version = 1;
	string (io_err_info.action_flags) = ""b;
	io_err_info.info_string = "Could not do I/O on switch.";
	io_err_info.status_code = 0;
	io_err_info.switch_name = switch -> iocb.name;
	io_err_info.status.code = code;
	io_err_info.status.IOS_status_bits = ""b;

	call signal_ ("io_error", null (), addr (io_err_info));
						/* if returned to, try again */

	return;

%include iocb;

     end iox_signal_;




		    pathname_.pl1                   11/11/89  1108.2rew 11/11/89  0806.5       31572



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


/* Construct pathnames and archive component pathnames.

   Written 9 April 1981 by M. N. Davidoff.
*/
/* format: style2 */
pathname_:
     procedure (P_dirname, P_entryname) returns (char (168));

	declare P_code		 fixed binary (35);
	declare P_component_name	 char (*);
	declare P_dirname		 char (*);
	declare P_entryname		 char (*);
	declare P_pathname		 char (*);

/* automatic */

	declare component_name	 char (32) varying;
	declare dirname		 char (168) varying;
	declare entryname		 char (32) varying;
	declare have_code		 bit (1) aligned;
	declare pathname		 char (194) varying;
	declare return_length	 fixed binary (21);

/* builtin */

	declare (after, index, length, maxlength, min, reverse, rtrim, substr)
				 builtin;

/* internal static */

	declare ARCHIVE_SUFFIX	 char (8) internal static options (constant) initial (".archive");
	declare PATHLONG		 char (20) internal static options (constant) initial (" <PATHNAME TOO LONG>");

/* external static */

	declare error_table_$pathlong	 fixed binary (35) external static;

/* P_dirname		(Input)
   P_entryname		(Input) */

	component_name = "";
	return_length = maxlength (dirname);
	have_code = "0"b;
	goto join;

/* P_dirname		(Input)
   P_entryname		(Input)
   P_component_name		(Input) */

component:
     entry (P_dirname, P_entryname, P_component_name) returns (char (194));

	component_name = rtrim (P_component_name);
	return_length = maxlength (pathname);
	have_code = "0"b;
	goto join;

/* P_dirname		(Input)
   P_entryname		(Input)
   P_component_name		(Input)
   P_pathname		(Output)
   P_code			(Output) */

component_check:
     entry (P_dirname, P_entryname, P_component_name, P_pathname, P_code);

	component_name = rtrim (P_component_name);
	return_length = min (length (P_pathname), maxlength (pathname));
	have_code = "1"b;
	P_pathname = "";
	P_code = 0;

join:
	dirname = rtrim (P_dirname);
	entryname = rtrim (P_entryname);

	if component_name ^= "" & index (reverse (entryname), reverse (ARCHIVE_SUFFIX)) = 1
	then entryname = reverse (after (reverse (entryname), reverse (ARCHIVE_SUFFIX)));

	if dirname = ">"
	then pathname = dirname || entryname;

	else begin;
		declare max_pathname_length	 fixed binary (21);

		if component_name = ""
		then max_pathname_length = return_length;
		else max_pathname_length = return_length - length ("::") - length (component_name);

		pathname = dirname || ">" || entryname;

		if length (dirname) + length (">") + length (entryname) > max_pathname_length
		then if have_code
		     then P_code = error_table_$pathlong;
		     else pathname = substr (pathname, 1, max_pathname_length - length (PATHLONG)) || PATHLONG;
	     end;

	if component_name ^= ""
	then pathname = pathname || "::" || component_name;

	if have_code
	then P_pathname = pathname;
	else return (pathname);
     end pathname_;




		    syn_.pl1                        11/11/89  1108.2rew 11/11/89  0803.9       99441



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


/* format: style4,delnl,insnl,tree,ifthenstmt,indnoniterend */

/* Modified 05/15/84 by Jim Lippard to free attach data on detach */
syn_$syn_attach:
     proc (p1, args, loud_sw_param, Code);

/* Parameters. */

dcl  args (*) char (*) varying parameter;
dcl  p1 ptr parameter;
dcl  loud_sw_param bit (1) aligned parameter;
dcl  Code fixed bin (35) parameter;

/* Automatic. */

dcl  blkptr ptr;
dcl  code fixed (35);
dcl  i fixed;
dcl  inhibit_sw bit (1);
dcl  inhibits bit (36);
dcl  loud_sw bit (1);
dcl  mask fixed (35);
dcl  (p2, p3) ptr;

/* Procedures. */

dcl  com_err_ ext entry options (variable);
dcl  get_system_free_area_ entry () returns (ptr);
dcl  hcs_$set_ips_mask ext entry (fixed bin (35), fixed bin (35));
dcl  hcs_$reset_ips_mask ext entry (fixed bin (35), fixed bin (35));
dcl  iox_$find_iocb entry (char (*), ptr, fixed bin (35));
dcl  iox_$propagate entry (ptr);

/* Based. */

dcl  based_area area based;

dcl  1 blk aligned based (blkptr),
       2 attach char (189) varying;
%include iocbx;

/* Constants. */

dcl  error_table_$cyclic_syn fixed (35) ext;
dcl  error_table_$not_detached fixed (35) ext;
dcl  error_table_$noarg fixed (35) ext;
dcl  error_table_$badopt fixed (35) ext;
dcl  iox_$err_no_operation ext entry options (variable);
dcl  iox_$err_not_attached ext entry options (variable);
dcl  iox_$err_not_open ext entry options (variable);
dcl  open_bit bit (36) int static init ("100000000000000"b);
dcl  close_bit bit (36) int static init ("010000000000000"b);
dcl  get_line_bit bit (36) int static init ("001000000000000"b);
dcl  get_chars_bit bit (36) int static init ("000100000000000"b);
dcl  put_chars_bit bit (36) int static init ("000010000000000"b);
dcl  modes_bit bit (36) int static init ("000001000000000"b);
dcl  position_bit bit (36) int static init ("000000100000000"b);
dcl  control_bit bit (36) int static init ("000000010000000"b);
dcl  read_record_bit bit (36) int static init ("000000001000000"b);
dcl  write_record_bit bit (36) int static init ("000000000100000"b);
dcl  rewrite_record_bit bit (36) int static init ("000000000010000"b);
dcl  delete_record_bit bit (36) int static init ("000000000001000"b);
dcl  seek_key_bit bit (36) int static init ("000000000000100"b);
dcl  read_key_bit bit (36) int static init ("000000000000010"b);
dcl  read_length_bit bit (36) int static init ("000000000000001"b);

/* Built-ins. */

dcl  (addr, hbound, index, null) builtin;

dcl  cleanup condition;

/* End of declarations. */
%page;
/* Beginning of entry point ..... syn_$syn_attach(p1,args,loud_sw_param,Code) ..... */

	loud_sw = loud_sw_param;
	mask = 0;					/* used by cleaner which is called by error */
	
	if hbound (args, 1) < 1 then call error (error_table_$noarg);

	call iox_$find_iocb ((args (1)), p2, code);
	if code ^= 0 then call error (code);

	inhibits, inhibit_sw = "0"b;
	do i = 2 to hbound (args, 1);
	     if /* case */ (args (i) = "-inh") | (args (i) = "-inhibit") then inhibit_sw = "1"b;
	     else if ^inhibit_sw then go to badopt;
	     else if args (i) = "open" then inhibits = inhibits | open_bit;
	     else if args (i) = "close" then inhibits = inhibits | close_bit;
	     else if args (i) = "get_line" then inhibits = inhibits | get_line_bit;
	     else if args (i) = "get_chars" then inhibits = inhibits | get_chars_bit;
	     else if args (i) = "put_chars" then inhibits = inhibits | put_chars_bit;
	     else if args (i) = "modes" then inhibits = inhibits | modes_bit;
	     else if args (i) = "position" then inhibits = inhibits | position_bit;
	     else if args (i) = "control" then inhibits = inhibits | control_bit;
	     else if args (i) = "read_record" then inhibits = inhibits | read_record_bit;
	     else if args (i) = "write_record" then inhibits = inhibits | write_record_bit;
	     else if args (i) = "rewrite_record" then inhibits = inhibits | rewrite_record_bit;
	     else if args (i) = "delete_record" then inhibits = inhibits | delete_record_bit;
	     else if args (i) = "seek_key" then inhibits = inhibits | seek_key_bit;
	     else if args (i) = "read_key" then inhibits = inhibits | read_key_bit;
	     else if args (i) = "read_length" then inhibits = inhibits | read_length_bit;
	     else
badopt:
		call error (error_table_$badopt);
	end;

	if p1 -> iocb.attach_descrip_ptr ^= null () then call error (error_table_$not_detached);
	if p2 -> iocb.actual_iocb_ptr = p1 then call error (error_table_$cyclic_syn);

	allocate blk in (get_system_free_area_ () -> based_area) set (blkptr);
	blk.attach = "syn_ " || rtrim (p2 -> iocb.name);
	if inhibits ^= ""b then do;
	     blk.attach = blk.attach || " -inh";
	     if inhibits & open_bit then blk.attach = blk.attach || " open";
	     if inhibits & close_bit then blk.attach = blk.attach || " close";
	     if inhibits & get_line_bit then blk.attach = blk.attach || " get_line";
	     if inhibits & get_chars_bit then blk.attach = blk.attach || " get_chars";
	     if inhibits & put_chars_bit then blk.attach = blk.attach || " put_chars";
	     if inhibits & modes_bit then blk.attach = blk.attach || " modes";
	     if inhibits & position_bit then blk.attach = blk.attach || " position";
	     if inhibits & control_bit then blk.attach = blk.attach || " control";
	     if inhibits & read_record_bit then blk.attach = blk.attach || " read_record";
	     if inhibits & write_record_bit then blk.attach = blk.attach || " write_record";
	     if inhibits & rewrite_record_bit then blk.attach = blk.attach || " rewrite_record";
	     if inhibits & delete_record_bit then blk.attach = blk.attach || " delete_record";
	     if inhibits & seek_key_bit then blk.attach = blk.attach || " seek_key";
	     if inhibits & read_key_bit then blk.attach = blk.attach || " read_key";
	     if inhibits & read_length_bit then blk.attach = blk.attach || " read_length";
	     end;

	mask = 0;
	on cleanup call cleaner;
	call hcs_$set_ips_mask (0, mask);

	p1 -> iocb.actual_iocb_ptr = p2 -> iocb.actual_iocb_ptr;
	p1 -> iocb.attach_descrip_ptr = addr (blk.attach);
	p1 -> iocb.attach_data_ptr = blkptr;
	p1 -> iocb.open_descrip_ptr = p2 -> iocb.open_descrip_ptr;
	p1 -> iocb.open_data_ptr = p2 -> iocb.open_data_ptr;
	p1 -> iocb.detach_iocb = syn_detach;
	if inhibits & open_bit
	then p1 -> iocb.open = iox_$err_no_operation;
	else p1 -> iocb.open = p2 -> iocb.open;
	if inhibits & close_bit
	then p1 -> iocb.close = iox_$err_no_operation;
	else p1 -> iocb.close = p2 -> iocb.close;
	if inhibits & get_line_bit
	then p1 -> iocb.get_line = iox_$err_no_operation;
	else p1 -> iocb.get_line = p2 -> iocb.get_line;
	if inhibits & get_chars_bit
	then p1 -> iocb.get_chars = iox_$err_no_operation;
	else p1 -> iocb.get_chars = p2 -> iocb.get_chars;
	if inhibits & put_chars_bit
	then p1 -> iocb.put_chars = iox_$err_no_operation;
	else p1 -> iocb.put_chars = p2 -> iocb.put_chars;
	if inhibits & modes_bit
	then p1 -> iocb.modes = iox_$err_no_operation;
	else p1 -> iocb.modes = p2 -> iocb.modes;
	if inhibits & position_bit
	then p1 -> iocb.position = iox_$err_no_operation;
	else p1 -> iocb.position = p2 -> iocb.position;
	if inhibits & control_bit
	then p1 -> iocb.control = iox_$err_no_operation;
	else p1 -> iocb.control = p2 -> iocb.control;
	if inhibits & read_record_bit
	then p1 -> iocb.read_record = iox_$err_no_operation;
	else p1 -> iocb.read_record = p2 -> iocb.read_record;
	if inhibits & write_record_bit
	then p1 -> iocb.write_record = iox_$err_no_operation;
	else p1 -> iocb.write_record = p2 -> iocb.write_record;
	if inhibits & rewrite_record_bit
	then p1 -> iocb.rewrite_record = iox_$err_no_operation;
	else p1 -> iocb.rewrite_record = p2 -> iocb.rewrite_record;
	if inhibits & delete_record_bit
	then p1 -> iocb.delete_record = iox_$err_no_operation;
	else p1 -> iocb.delete_record = p2 -> iocb.delete_record;
	if inhibits & seek_key_bit
	then p1 -> iocb.seek_key = iox_$err_no_operation;
	else p1 -> iocb.seek_key = p2 -> iocb.seek_key;
	if inhibits & read_key_bit
	then p1 -> iocb.read_key = iox_$err_no_operation;
	else p1 -> iocb.read_key = p2 -> iocb.read_key;
	if inhibits & read_length_bit
	then p1 -> iocb.read_length = iox_$err_no_operation;
	else p1 -> iocb.read_length = p2 -> iocb.read_length;
	p1 -> iocb.ios_compatibility = p2 -> iocb.ios_compatibility;
	p1 -> iocb.syn_inhibits = inhibits;
	p1 -> iocb.syn_father = p2;
	p1 -> iocb.syn_brother = p2 -> iocb.syn_son;
	p2 -> iocb.syn_son = p1;
	call iox_$propagate (p1);
	call cleaner;
	Code = 0;
	return;
%page;
/* Handler for the 'detach_iocb' I/O operation. */

syn_detach:
     entry (p1, Code);

	mask = 0;
	on cleanup call cleaner;
	call hcs_$set_ips_mask (0, mask);

	blkptr = p1 -> iocb.attach_data_ptr;
	p1 -> iocb.actual_iocb_ptr = p1;
	p1 -> iocb.attach_descrip_ptr = null ();
	p1 -> iocb.attach_data_ptr = null ();
	p1 -> iocb.open_descrip_ptr = null ();
	p1 -> iocb.open_data_ptr = null ();
	p1 -> iocb.detach_iocb = iox_$err_not_attached;
	p1 -> iocb.open = iox_$err_not_attached;
	p1 -> iocb.close = iox_$err_not_open;
	p1 -> iocb.get_line = iox_$err_not_open;
	p1 -> iocb.get_chars = iox_$err_not_open;
	p1 -> iocb.put_chars = iox_$err_not_open;
	p1 -> iocb.modes = iox_$err_not_open;
	p1 -> iocb.position = iox_$err_not_open;
	p1 -> iocb.control = iox_$err_not_open;
	p1 -> iocb.read_record = iox_$err_not_open;
	p1 -> iocb.write_record = iox_$err_not_open;
	p1 -> iocb.rewrite_record = iox_$err_not_open;
	p1 -> iocb.delete_record = iox_$err_not_open;
	p1 -> iocb.seek_key = iox_$err_not_open;
	p1 -> iocb.read_key = iox_$err_not_open;
	p1 -> iocb.read_length = iox_$err_not_open;
	p1 -> iocb.ios_compatibility = null ();
	p1 -> iocb.syn_inhibits = "0"b;
	p3 = p1 -> iocb.syn_father;
	if p3 -> iocb.syn_son = p1
	then p3 -> iocb.syn_son = p1 -> iocb.syn_brother;
	else do;
	     do p3 = p3 -> iocb.syn_son repeat p3 -> iocb.syn_brother while (p3 -> iocb.syn_brother ^= p1);
	     end;
	     p3 -> iocb.syn_brother = p1 -> iocb.syn_brother;
	     end;
	p1 -> iocb.syn_father, p1 -> iocb.syn_brother = null ();
	call iox_$propagate (p1);
	call cleaner;
	Code = 0;
	free blkptr -> blk;
	return;
%page;
error:
     procedure (c);
dcl  c fixed bin (35) parameter;

	call cleaner;
	if loud_sw then call com_err_ (c, "syn_");
	code = c;
	go to return;
     end error;

return:
	Code = code;
	return;


cleaner:
     procedure;
	if mask ^= 0 then call hcs_$reset_ips_mask (mask, mask);
	return;
     end cleaner;

     end syn_$syn_attach;






		    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
