



		    abbrev.pl1                      04/12/90  1638.8rew 04/12/90  1539.5      973845



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

/* format: off */

/* The Multics standard abbreviation processor */

/* Created:  February 1982 by G. Palter based on various previous versions */
/****^  HISTORY COMMENTS:
  1) change(86-05-01,Gilcrease), approve(86-05-10,MCR7409),
     audit(86-08-01,GWMay), install(86-08-04,MR12.0-1112):
     (old history comments)
     
     Modified: 7 March 1982 to insure that set_profile_ptr is quick, move
     special requests check into standard request checking code, and add the
     following warning
     
     Modified: 12 March 1982 by G. Palter to set the bit count on the profile
     segment after an add request
     
     Modified: 18 March 1982 by G. Palter to terminate the old profile when
     appropriate after a ".u" request
     
     Modified: 30 July 1982 by G. Palter to make abbrev as an active function
     return true/flase if expansion is enabled/disabled, respectively
     
     Modified: April 1983 by G. Palter for version 1.2:
      (1) Added initial support for multiple character break sequences and
          defined "::" as a break sequence;
      (2) Added the ".rename" request to allow users to rename old
          abbreviations whose names contain "::"
     
     Modified: 29 February 1984 by G. Palter for version 1.2a which fixes the
     following bugs:
      #0052: If abbrev has to reinitialize the default profile, it will
             erroneously state that it created the profile.  In addition,
             abbrev will always initiate the default profile twice.
      #0053: If the last character of the line to be expanded is the first
             character of a multi-character break sequence, abbrev will loop
             indefinitely
     
     Modified: January 1983 by G. Palter for version 3.0:
      (1) Added the ".edit" request to allow editing the definition of an
          abbreviation using qedx_;
      (2) Added the ".switch_on" and ".switch_off" requests to manipulate an
          abbreviation's beginning-of-line switch;
      (3) Renamed the ".call_debug" request to ".debug" and the ".call_probe"
          request to ".probe" (Version 2 was the "Goldman" abbrev which lived
          in EXL on MIT and System-M for many, many years)
  2) change(86-05-01,Gilcrease), approve(86-05-10,MCR7409),
     audit(86-08-01,GWMay), install(86-08-04,MR12.0-1112):
     (more old history comments)
     
     Modified: March 1983 by G. Palter for version 3.1:
      (1) Changed the ".edit" request to print the abbreviation's definition
          and a prompt before invoking qedx_ and to query if overwriting an
          existing abbreviation (if not the "default pathname");
      (2) Added the ".escape" request and the "-escape" abbrev control
          argument to set the character used to identify abbrev request lines;
      (3) Added the "-on", "-off", and "-profile" control arguments for
          compatibility with the standard abbrev subsystem request
     
     Modified: 6 August 1985 by G. Palter for version 3.1a which fixes the
     following bugs:
      #0092: If the ".use" request is used in a subsystem which is using the
             same profile as Multics command level, abbrev will incorrectly
             terminate the profile which will cause subsequent command lines
             to fault until the ".quit" request is issued.
      #0107: If the new name given for an abbreviation by the ".rename"
             request is too long (i.e., more than 8 characters), the error
             message printed by abbrev includes 32 random characters instead
             of the supplied name
  3) change(86-05-01,Gilcrease), approve(86-05-10,MCR7409),
     audit(86-08-01,GWMay), install(86-08-04,MR12.0-1112):
     Call ioa_ rather than com_err_ on "Profile create" message.
     (command_environment 123), and implement .?  request, install version
     3.1a abbrev.
  4) change(86-05-17,GDixon), approve(86-05-17,MCR7357),
     audit(86-07-10,Farley), install(86-07-18,MR12.0-1098):
     Change call to tct_ to reference find_char_$first_in_table instead.  The
     tct_ subroutines were renamed.
  5) change(86-10-10,Gilcrease), approve(87-02-27,MCR7626),
     audit(87-03-09,Parisek), install(87-03-20,MR12.1-1005):
     Add version 2 list requests.
  6) change(87-06-20,Gilcrease), approve(87-07-15,MCR7738),
     audit(87-07-16,Parisek), install(87-07-17,MR12.1-1042):
     Fix bug in .lx request.
  7) change(87-07-01,GWMay), approve(87-07-01,MCR7730), audit(87-08-10,JRGray),
     install(87-09-10,MR12.1-1104):
     Added the pipe token combination ";|" and the left bracket "[" to the
     list of beginning of line breaks. Fixed a minor bug with the .lx
     request.
  8) change(87-10-16,TLNguyen), approve(87-10-16,MCR7778),
     audit(87-12-02,Farley), install(87-12-07,MR12.2-1009):
     - Make the abbrev .use request strip one level of quotes from the
       pathname, if specified.
     
     - Add the new entry point named abbrev_$expand_line which will be like
       the "abbrev_$expanded_line" current entry point;  however, this new
       entry point will have one new argument to say what kind of abbrevs
       to expand.  This argument can be EXPAND_BOL_ONLY (1), or
       EXPAND_INTERNAL_ONLY (2), or EXPAND_BOTH (3).  For solving the
       TR #14559, the EXPAND_INTERNAL_ONLY (2)  constant will be used.
     
     - Clear out errors found at run time after compiled with
       -prefix size,strg,strz,subrg.
  9) change(90-03-15,Vu), approve(90-03-15,MCR8161), audit(90-03-19,Kallstrom),
     install(90-04-12,MR12.4-1002):
     The abbrev command .lx should not limit its argument's length.
                                                   END HISTORY COMMENTS */

/*  Note: In order to insure that the main path through the command/request line expander does not entail the overhead of
   calls to non-quick procedures, two internal procedures, set_profile_ptr and lookup_abbrev, are duplicated.  One version
   appears either in the expand_line procedure or as a top-level internal procedure; the other version appears as an
   internal procedure of the begin block in the process_request_line internal procedure.  Anyone modifying either of these
   two procedures should be certain to modify both copies of the procedure.  (An attempt will be made at a future date to
   eliminate the need for two copies of these procedures) 	*/

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


abbrev:
ab:
     procedure () options (variable);


/* Parameters */

dcl  P_code fixed binary (35) parameter;

dcl  P_command_processor entry (pointer, fixed binary (21), fixed binary (35)) variable parameter;
						/* set_cp: the command processor to always invoke */

dcl  P_breaks character (*) parameter;			/* set_break, reset_break: the break chars to add/delete */

dcl  P_abbrev_type fixed bin;				/* = 1 expand beginning-of-line (bol) abbrevs only.
						   = 2 expand internal (non-bol) abbrevs only.
						   = 3 expand both bol and non-bol abbrevs */

dcl  P_input_line_ptr pointer parameter;		/* abbrev_processor, expanded_line: -> line to expand */
dcl  P_input_line_lth fixed binary (21) parameter;	/* abbrev_processor, expanded_line: length of the line */

dcl  P_subsystem_name character (*) parameter;		/* subsys_process_line: name of the subsystem */
dcl  P_sci_ptr pointer parameter;			/* subsys_process_line: -> the subsystem's control data */
dcl  P_execute_request entry () variable parameter;	/* subsys_process_line: entry to invoke a single request */
dcl  P_subsys_cp_info_ptr pointer parameter;		/* subsys_process_line: -> data of subsys request processor */
dcl  P_subsys_cp entry (character (*), pointer, entry, pointer, character (*), fixed binary (35)) variable parameter;
						/* subsys_process_line: the subsystem request processor */
dcl  P_default_profile_ptr pointer parameter;		/* subsys_process_line: -> default profile segment */
dcl  P_profile_ptr pointer parameter;			/* subsys_process_line: -> current profile segment */
dcl  P_request_line character (*) parameter;		/* subsys_process_line: the request line itself */

dcl  P_workspace_ptr pointer parameter;			/* expanded_line: -> buffer where expansion is placed */
dcl  P_workspace_lth fixed binary (21) parameter;		/* expanded_line: length of the buffer */
dcl  P_output_line_ptr pointer parameter;		/* expanded_line: set -> the expansion */
dcl  P_output_line_lth fixed binary (21) parameter;	/* expanded_line: set to length of the expansion */


/* Local copies of parameters */

dcl  abbrev_type fixed bin;				/* = 1 expand beginning-of-line (bol) abbrevs only.
						   = 2 expand internal (non-bol) abbrevs only.
						   = 3 expand both bol and non-bol abbrevs */

dcl  input_line character (input_line_lth) based (input_line_ptr);
dcl  input_line_lth fixed binary (21);
dcl  input_line_ptr pointer;

dcl  P_output_line character (P_output_line_lth) based (P_output_line_ptr);

dcl  code fixed binary (35);


/* Remaining declarations */

dcl  system_area area based (system_area_ptr);
dcl  system_area_ptr pointer;

dcl  expanded_line character (expanded_line_lth) based (expanded_line_ptr);
dcl  expanded_line_lth fixed binary (21);
dcl  expanded_line_ptr pointer;

dcl  expansion_stack_space_lth fixed binary (21);
dcl  expansion_stack_space_ptr pointer;
dcl  extended_stack bit (1) aligned;			/* ON => expansion is in the stack extension */

dcl  expansion_temp_segment character (4 * sys_info$max_seg_size) based (expansion_temp_segment_ptr);
dcl  expansion_temp_segment_ptr pointer;
dcl  used_temp_segment bit (1) aligned;			/* ON => expansion is in a temporary segment */

dcl  based_word fixed binary (35) based;

dcl  (subsystem_entry, return_expansion, allow_request_lines, have_return_code, null_line) bit (1) aligned;

dcl  start fixed binary (21);

dcl  cp_variable entry (pointer, fixed binary (21), fixed binary (35)) variable;

dcl  ABBREV character (32) static options (constant) initial ("abbrev");

dcl  EXPAND_BOL_ONLY fixed bin static options (constant) initial (1);
						/* expand beginning-of-line (bol) abbrevs only */
dcl  EXPAND_INTERNAL_ONLY fixed bin static options (constant) initial (2);
						/* expand internal (non-bol) abbrevs only */
dcl  EXPAND_BOTH fixed bin static options (constant) initial (3);
						/* expand both bol and non-bol abbrevs */

dcl  MAX_STACK_EXTENSION fixed binary (18) static options (constant) initial (16384);
						/* grow the stack no more than 16K characters */

dcl  WHITE_SPACE character (4) static options (constant) initial (" 	");						/* SP HT VT FF */

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

dcl  DEFAULT_ABBREV_ESCAPE_CHARACTER character (1) static options (constant) initial (".");

dcl  DEFAULT_BREAKS character (21) static options (constant) initial ("	
 ""$'().:;<>[]`{|}");				/* HT NL VT FF SP QUOTE, etc: must be in collating sequence */

dcl  SP character (1) static options (constant) initial (" ");
dcl  NL character (1) static options (constant) initial ("
");
dcl  LEFT_BRACKET character (1) static options (constant) initial ("[");
dcl  SEMICOLON character (1) static options (constant) initial (";");
dcl  VERTICAL_BAR character (1) static options (constant) initial ("|");
dcl  QUOTE character (1) static options (constant) initial ("""");

dcl  abbrev_data_$version character (32) unaligned external;
dcl  abbrev_data_$default_breaks_list bit (36) aligned external;
dcl  abbrev_data_$default_breaks_tct_table character (512) unaligned external;

/* format: off */
dcl (error_table_$badopt, error_table_$bad_segment, error_table_$bad_subr_arg, error_table_$command_line_overflow,
     error_table_$moderr, error_table_$noarg, error_table_$noentry, error_table_$not_act_fnc,
     error_table_$request_not_recognized, error_table_$unbalanced_quotes, error_table_$unimplemented_version)
	fixed binary (35) external;
/* format: on */

dcl  sys_info$max_seg_size fixed binary (19) external;

dcl  active_fnc_err_$suppress_name entry () options (variable);
dcl  com_err_ entry () options (variable);
dcl  com_err_$suppress_name entry () options (variable);
dcl  command_processor_ entry (pointer, fixed binary (21), fixed binary (35));
dcl  command_query_$yes_no entry () options (variable);
dcl  cu_$af_return_arg_rel entry (fixed binary, pointer, fixed binary (21), fixed binary (35), pointer);
dcl  cu_$arg_list_ptr entry () returns (pointer);
dcl  cu_$arg_ptr_rel entry (fixed binary, pointer, fixed binary (21), fixed binary (35), pointer);
dcl  cu_$cp entry (pointer, fixed binary (21), fixed binary (35));
dcl  cu_$get_command_processor entry (entry (pointer, fixed binary (21), fixed binary (35)));
dcl  cu_$grow_stack_frame entry (fixed binary (18), pointer, fixed binary (35));
dcl  cu_$set_command_processor entry (entry (pointer, fixed binary (21), fixed binary (35)));
dcl  cu_$shrink_stack_frame entry (pointer, fixed binary (35));
dcl  debug entry () options (variable);
dcl  expand_pathname_$add_suffix entry (character (*), character (*), character (*), character (*), fixed binary (35));
dcl  probe entry () options (variable);
dcl  get_system_free_area_ entry () returns (pointer);
dcl  get_temp_segment_ entry (character (*), pointer, fixed binary (35));
dcl  hcs_$fs_get_mode entry (pointer, fixed binary (5), fixed binary (35));
dcl  hcs_$fs_get_path_name entry (pointer, character (*), fixed binary, character (*), fixed binary (35));
dcl  initiate_file_ entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35));
dcl  initiate_file_$create
	entry (character (*), character (*), bit (*), pointer, bit (1) aligned, fixed binary (24), fixed binary (35));
dcl  ioa_ entry () options (variable);
dcl  ioa_$nnl entry () options (variable);
dcl  pathname_ entry (character (*), character (*)) returns (character (168));
dcl  qedx_ entry (pointer, fixed binary (35));
dcl  release_temp_segment_ entry (character (*), pointer, fixed binary (35));
dcl  sort_items_$char entry (pointer, fixed binary (24));
dcl  terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35));
dcl  find_char_$first_in_table entry (char (*), char (512) aligned) returns (fixed bin (21)) reducible;
dcl  user_info_ entry (character (*));
dcl  user_info_$homedir entry (character (*));

dcl  cleanup condition;

dcl  (addcharno, addr, after, baseptr, before, codeptr, currentsize, divide, fixed, hbound, high, index, lbound, length,
     low, ltrim, max, mod, null, pointer, rank, rel, reverse, rtrim, search, string, substr, verify) builtin;
%page;
/* State of abbreviation processing in this process */

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

dcl  1 abbrev_state aligned static,
       2 command_processor entry (pointer, fixed binary (21), fixed binary (35)) variable,
       2 previous_command_processor entry (pointer, fixed binary (21), fixed binary (35)) variable,
       2 profile_ptr pointer,				/* -> profile in use at command level */
       2 remembered_line,				/* data about the last expansion we did ... */
         3 remembered_line_buffer_ptr pointer,		/* ... -> buffer used to hold the lines */
         3 remembered_line_buffer_lth fixed binary (21),	/* ... length of the buffer */
         3 remembered_line_lth fixed binary (21),		/* ... length of line currently saved therein */
       2 escape_character character (1) aligned,		/* character used to trigger request line processing */
       2 flags,
         3 set_cp bit (1) unaligned,			/* ON => we have established ourselves as the CP */
         3 set_cp_explicit bit (1) unaligned,		/* ON => abbrev_$set_cp was called */
         3 remember_lines bit (1) unaligned,		/* ON => remember last expanded line */
         3 default_breaks bit (1) unaligned,		/* ON => using default break characters */
         3 pad bit (32) unaligned,
       2 breaks_info,				/* data used to find break sequences ... */
         3 user_breaks character (128) varying,		/* ... 1st characters of all sequences if not default */
         3 tct_table character (512),			/* ... used to search for above sequences if not default */
         3 breaks_list_ptr pointer;			/* ... -> breaks_list defining the sequences */

dcl  abbrev_state_tct_table_as_binary (0:511) fixed binary (9) unaligned unsigned based (addr (abbrev_state.tct_table));

dcl  1 breaks_list aligned based (abbrev_state.breaks_list_ptr),
       2 n_break_sequences fixed binary,		/* # of distinct break sequences */
       2 break_strings_lth fixed binary,		/* combined length of all break sequences */
       2 break_sequences (breaks_list_n_break_sequences refer (breaks_list.n_break_sequences)),
         3 start fixed binary,			/* ... index in break_strings where this sequence starts */
         3 lth fixed binary,				/* ... how long this sequence actually is */
       2 break_strings character (breaks_list_break_strings_lth refer (breaks_list.break_strings_lth)) unaligned;
dcl  (breaks_list_n_break_sequences, breaks_list_break_strings_lth) fixed binary;

dcl  remembered_line_buffer character (abbrev_state.remembered_line_buffer_lth)
	based (abbrev_state.remembered_line_buffer_ptr);
dcl  remembered_line character (abbrev_state.remembered_line_lth) based (abbrev_state.remembered_line_buffer_ptr);

dcl  debug_entry_variable entry () options (variable) variable static;
dcl  probe_entry_variable entry () options (variable) variable static;
%page;
dcl  abbrev_rqd (87) char (72) static options (constant)	/* For the .? abbrev request */
	init (".",				/* Three lines of print, 3rd line */
	"   displays the current version of abbrev.",	/* "" if not needed */
	"",					/* ( as for this "." request) */
	".? <request1>...<requestN>", "   describes the function and usage of the given abbrev control",
	"   request(s). If none are given, all abbrev requests are described.", ".<SP>LINE",
						/* can't be individually displayed */
	"   passes LINE directly to the current command processor without", "   expanding any embedded abbreviations.",
	".a name LINE, .af name LINE", "   adds LINE as the definition of a new abbreviation with the given",
	"   name to the current profile.  '.af' adds with no query.", ".ab name LINE, .abf name LINE",
	"   adds LINE as the definition of a new abbreviation with the given",
	"   name to the current profile.  '.abf' adds with no query.", ".debug", "   invokes debug.", "",
	".delete names, .dl names, .d names", "   deletes the given abbreviations from the current profile.", "",
	".edit name", "   invokes the qedx editor to edit the given abbreviation's", "   definition.",
	".escape {STR}, .esc {STR}", "   changes the escape character which is used to indicate that a",
	"   command line is actually an abbrev request line. ", ".forget, .f", "   disables remember mode. ", "",
	".l {names}", "   displays the names, switches, and definitions of the given",
	"   abbreviations in alphabetic order.", ".la STRs",
	"   displays the names, switches, and definitions of any abbreviations",
	"   whose name starts with one of the given strings.", ".lab STRs, .la^b STRs",
	"   displays beginning-line (.lab) or not-beginning-line (.la^b)",
	"   information for abbreviations beginning with STRs.", ".lb {names}",
	"   displays information on beginning-of-line abbreviations which",
	"   match {names}, or if no {names}, all bol abreviations.", ".l^b {names}",
	"   displays information on not-beginning-of-line abbreviations which",
	"   which match {name}, or if no {names}, all not-bol abbreviaions.", ".ls STRs",
	"   displays the names, switches, and definitions of any abbreviations", "   which contain STRs.",
	".lsb STRs, .ls^b STRs", "   displays beginning-of-line (.lsb) or not-beginning-of-line ",
	"   information of abbreviations which contain STRs.", ".lx STRs",
	"   displays information of abbreviation expansions which contain", "   STRs.", ".lxb STRs, .lx^b STRs",
	"   displays information of beginning-line abbreviation expansions",
	"   (.lxb) or not-beginning-line (.lx^b) containing STRs.", ".probe", "   invokes probe.", "", ".profile, .p",
	"   prints the pathname of the profile segment presently being used to", "   expand abbreviations.",
	".quit, .q", "   disables abbreviation processing of subsequent command lines.", "", ".remember, .r",
	"   enables remember mode.  In remember mode, abbrev saves the expansion",
	"   of the last line that it has processed.  See the '.show' request.",
	".rename old_name1 new_name1 ..., .rn old_name1 new_name1...",
	"   renames the given abbreviations.  If an abbreviation is already",
	"   defined, abbrev will query for permission to replace it.", ".show {LINE}, .s {LINE}",
	"   if LINE is given, displays the expansion of that line without",
	"   executing it.  If LINE is not given, displays the last line expanded.",
	".switch_on switch_name names, .swn switch_name names",
	"   turns on the given switch in the definitions of the given",
	"   abbreviations.  See the 'abbrev' online help file for more details.",
	".switch_off switch_name names, .swf switch_name names",
	"   turns off the given switch in the definitions of the given",
	"   abbreviations. See the 'abbrev' online help file for more details.", ".terminate_process",
	"   causes a fatal process error.  This request is intended for use ",
	"   only under special conditions. See the 'abbrev' online help file.", ".use {path}, .u {path}",
	"   changes the pathname of the profile segment.  The 'profile' suffix",
	"   is assumed.  If no {path} given, the default profile is used.");

dcl  ard (46) char (19) varying static options (constant) init
						/* control request literals table */
	(".", ".?", ". ", ".a", ".af", ".ab", ".abf", ".debug", ".delete", ".dl", ".d", ".edit", ".escape", ".esc",
	".forget", ".f", ".l", ".la", ".lab", ".la^b", ".lb", ".l^b", ".ls", ".lsb", ".ls^b", ".lx", ".lxb", ".lx^b",
	".probe", ".profile", ".p", ".quit", ".q", ".remember", ".r", ".rename", ".rn", ".show", ".s", ".switch_on",
	".swn", ".switch_off", ".swf", ".terminate_process", ".use", ".u");

dcl  ardx (46) fixed bin static options (constant) init	/* corresponding index into abbrev_rqd table */
	(1, 4, 7, 10, 10, 13, 13, 16, 19, 19, 19, 22, 25, 25, 28, 28, 31, 34, 37, 37, 40, 43, 46, 49, 49, 52, 55, 55,
	58, 61, 61, 64, 64, 67, 67, 70, 70, 73, 73, 76, 76, 79, 79, 82, 85, 85);
%page;


%page;
/* abbrev command/AF:  As a command, establishes ourself as the command processor; as an active function, returns
   true/false if command line expansion is enabled/disabled, respectively.  If enabling abbrev and there was a previous
   call to set_cp_explicit, assume that the caller always wants us to call whatever command processor he provided */

/* abbrev: ab: entry () options (variable); */

	if first_call then				/* be sure static is setup */
	     call initialize_abbrev_state ();

	call process_abbrev_command_or_af (cu_$arg_list_ptr ());

	return;



/* Does the actual work of the abbrev command/AF to keep the main stack frame as small as possible */

process_abbrev_command_or_af:
     procedure (p_argument_list) options (non_quick);

dcl  p_argument_list pointer parameter;

dcl  argument character (argument_lth) unaligned based (argument_ptr);
dcl  argument_ptr pointer;
dcl  argument_lth fixed binary (21);
dcl  (n_arguments, argument_idx) fixed binary;

dcl  return_string character (return_string_max_lth) varying based (return_string_ptr);
dcl  return_string_max_lth fixed binary (21);
dcl  return_string_ptr pointer;

dcl  active_function bit (1) aligned;

dcl  enable_abbrev bit (1) aligned;
dcl  new_escape_character character (1) aligned;

dcl  new_profile_dirname character (168);
dcl  new_profile_ename character (32);
dcl  new_profile_ptr pointer;
dcl  created_here bit (1) aligned;
dcl  try_to_create bit (1);


	call cu_$af_return_arg_rel (n_arguments, return_string_ptr, return_string_max_lth, code, p_argument_list);

	if code = 0 then active_function = "1"b;

	else if code = error_table_$not_act_fnc then active_function = "0"b;

	else do;					/* something wrong with the argument list header */
	     call com_err_ (code, ABBREV);
	     return;
	end;


	if active_function then do;			/* tell user if abbrev is on/off */
	     if n_arguments = 0 then			/* ... but only if properly invoked */
		if abbrev_state.set_cp then
		     return_string = "true";
		else return_string = "false";

	     else call active_fnc_err_$suppress_name (0, ABBREV, "Usage:  [^a]", ABBREV);

	     return;
	end;


/* Here iff invoked as a command */

	enable_abbrev = "1"b;			/* turn abbreviation processing on by default */
	new_escape_character = abbrev_state.escape_character;

	new_profile_ptr = null ();			/* for cleanup handler */
	created_here = "0"b;

	on condition (cleanup)
	     begin;
	     if new_profile_ptr ^= null () then
		if created_here then
		     call terminate_file_ (new_profile_ptr, 0, TERM_FILE_DELETE, (0));
		else call terminate_file_ (new_profile_ptr, 0, TERM_FILE_TERM, (0));
	end;


	do argument_idx = 1 to n_arguments;

	     call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, code, p_argument_list);
	     if code ^= 0 then do;
		call com_err_ (code, ABBREV, "Fetching argument #^d.", argument_idx);
		go to RETURN_FROM_ABBREV_COMMAND;
	     end;

	     if index (argument, "-") = 1 then		/* a control argument ... */
		if argument = "-on" then enable_abbrev = "1"b;
		else if argument = "-off" then enable_abbrev = "0"b;

		else if (argument = "-escape") | (argument = "-esc") then
		     if argument_idx = n_arguments then do;
			call com_err_ (error_table_$noarg, ABBREV, "Escape character after ""^a"".", argument);
			go to RETURN_FROM_ABBREV_COMMAND;
		     end;
		     else do;			/* ... there is something following it */
			argument_idx = argument_idx + 1;
			call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, code, p_argument_list);
			if code ^= 0 then do;
			     call com_err_ (code, ABBREV, "Fetching argument #^d.", argument_idx);
			     go to RETURN_FROM_ABBREV_COMMAND;
			end;
			if length (rtrim (argument)) > length (abbrev_state.escape_character) then do;
			     call com_err_ (0, ABBREV,
				"The escape sequence must be a single character; not ""^a"".", argument);
			     go to RETURN_FROM_ABBREV_COMMAND;
			end;
			new_escape_character = argument;
		     end;

		else if (argument = "-profile") | (argument = "-pf") then
		     if argument_idx = n_arguments then do;
			call com_err_ (error_table_$noarg, ABBREV, "Profile pathname after ""^a"".", argument);
			go to RETURN_FROM_ABBREV_COMMAND;
		     end;
		     else do;
			argument_idx = argument_idx + 1;
			call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, code, p_argument_list);
			if code ^= 0 then do;
			     call com_err_ (code, ABBREV, "Fetching argument #^d.", argument_idx);
			     go to RETURN_FROM_ABBREV_COMMAND;
			end;
			call expand_pathname_$add_suffix (argument, "profile", new_profile_dirname,
			     new_profile_ename, code);
			if code ^= 0 then do;
			     call com_err_ (code, ABBREV, "^a", argument);
			     go to RETURN_FROM_ABBREV_COMMAND;
			end;
			if new_profile_ptr ^= null () then
			     if created_here then	/* ... there was a previous use of -profile ... */
				call terminate_file_ (new_profile_ptr, 0, TERM_FILE_DELETE, (0));
			     else call terminate_file_ (new_profile_ptr, 0, TERM_FILE_TERM, (0));
			created_here = "0"b;
			call initiate_file_ (new_profile_dirname, new_profile_ename, R_ACCESS, new_profile_ptr, (0),
			     code);
			if code ^= 0 then		/* couldn't find it */
			     if code = error_table_$noentry then do;
				call command_query_$yes_no (try_to_create, 0, ABBREV, "",
				     "Profile ^a not found.  Do you want to create it?",
				     pathname_ (new_profile_dirname, new_profile_ename));
				if try_to_create then
				     call initiate_file_$create (new_profile_dirname, new_profile_ename,
					RW_ACCESS, new_profile_ptr, created_here, (0), code);
				else go to RETURN_FROM_ABBREV_COMMAND;
						/* user doesn't want to try */
			     end;
			if new_profile_ptr = null () then do;
			     call com_err_ (code, ABBREV, "^a", pathname_ (new_profile_dirname, new_profile_ename));
			     go to RETURN_FROM_ABBREV_COMMAND;
			end;
		     end;

		else do;
		     call com_err_ (error_table_$badopt, ABBREV, """^a""", argument);
		     go to RETURN_FROM_ABBREV_COMMAND;
		end;

	     else do;
		call com_err_$suppress_name (0, ABBREV, "Usage:  ^a {-control_args}", ABBREV);
		go to RETURN_FROM_ABBREV_COMMAND;
	     end;
	end;


/* Here iff all arguments are OK: enable/disable abbrev and switch profiles as requested */

	abbrev_state.escape_character = new_escape_character;

	if enable_abbrev then			/* turn on abbreviation processing ... */
	     if ^abbrev_state.set_cp then do;		/* ... if it wasn't already in use */
		call cu_$get_command_processor (cp_variable);
		if cp_variable ^= abbrev_processor then do;
						/* ... avoid infinite recursion if we're already enabled */
		     abbrev_state.previous_command_processor = cp_variable;
		     if ^abbrev_state.set_cp_explicit then abbrev_state.command_processor = cp_variable;
						/* ... don't override the explicitly set processor */
		     call cu_$set_command_processor (abbrev_processor);
		     abbrev_state.set_cp = "1"b;	/* ... have set ourselves up now */
		end;
	     end;

	     else ;				/* ... it was already on so this is a no-op */

	else do;					/* turn abbrev off ... */
	     if abbrev_state.set_cp then do;		/* ... and we are the command processor */
		call cu_$set_command_processor (abbrev_state.previous_command_processor);
		abbrev_state.set_cp = "0"b;
	     end;
	     if abbrev_state.profile_ptr ^= null () then	/* ... don't need it any more */
		call terminate_file_ (abbrev_state.profile_ptr, 0, TERM_FILE_TERM, (0));
	end;

	if new_profile_ptr ^= null () then do;		/* switch to the requested profile */
	     if abbrev_state.profile_ptr ^= null () then
		call terminate_file_ (abbrev_state.profile_ptr, 0, TERM_FILE_TERM, (0));
	     abbrev_state.profile_ptr, ap_ptr = new_profile_ptr;
	     new_profile_ptr = null ();		/* avoid accidently terminating what is now the profile */
	     expansion_temp_segment_ptr = null ();	/* in case initialize_profile fails ... */
	     have_return_code = "0"b;			/* ... */
	     call initialize_profile (^created_here, created_here);
	end;

RETURN_FROM_ABBREV_COMMAND:
	if new_profile_ptr ^= null () then
	     if created_here then
		call terminate_file_ (new_profile_ptr, 0, TERM_FILE_DELETE, (0));
	     else call terminate_file_ (new_profile_ptr, 0, TERM_FILE_TERM, (0));

	return;

     end process_abbrev_command_or_af;
%page;
/* Return the current version of abbrev for use by use_exl_abbrev */

get_version:
     entry () returns (character (32));

	return (abbrev_data_$version);
%page;
/* Provide an explicit entry for abbrev to use as the command processor: overrides whatever entry the abbrev command
   establishes as the previous command processor */

set_cp:
     entry (P_command_processor);

	if first_call then call initialize_abbrev_state ();

	if codeptr (P_command_processor) = null () then	/* use the default command processor */
	     abbrev_state.command_processor = command_processor_;
	else abbrev_state.command_processor = P_command_processor;

	abbrev_state.set_cp_explicit = "1"b;		/* override the abbrev command */

	return;
%page;
/* Adds the given characters as break characters */

set_break:
     entry (P_breaks);

	if first_call then call initialize_abbrev_state ();

	call add_breaks (P_breaks);

	return;



/* Do the actual work in an internal procedure to save space on the main procedure's stack */

add_breaks:
     procedure (p_breaks) options (non_quick);

dcl  p_breaks character (*) parameter;
dcl  current_breaks character (128) varying;
dcl  break_character character (1) aligned;
dcl  (idx, jdx) fixed binary (21);
dcl  added bit (1) aligned;

	if abbrev_state.default_breaks then		/* everything but "::" due to deficiencies of the interface */
	     current_breaks = before (DEFAULT_BREAKS, ":") || after (DEFAULT_BREAKS, ":");
	else current_breaks = abbrev_state.user_breaks;

	do idx = 1 to length (p_breaks);
	     break_character = substr (p_breaks, idx, 1);
	     if break_character <= high (1) then do;	/* only if it's ASCII ... */
		added = "0"b;
		do jdx = 1 to length (current_breaks) while (^added);
		     if substr (current_breaks, jdx, 1) = break_character then added = "1"b;
		     else if substr (current_breaks, jdx, 1) > break_character then do;
			current_breaks =
			     substr (current_breaks, 1, (jdx - 1)) || break_character
			     || substr (current_breaks, jdx);
			added = "1"b;
		     end;
		end;
		if ^added then			/* wasn't added in the middle: stick it on the end */
		     current_breaks = current_breaks || break_character;
	     end;
	end;

	call set_user_breaks (current_breaks);

	return;

     end add_breaks;
%page;
/* Deletes the given characters from the list of break characters */

reset_break:
     entry (P_breaks);

	if first_call then call initialize_abbrev_state ();

	call delete_breaks (P_breaks);

	return;



/* Do the actual work in an internal procedure to save space on the main procedure's stack */

delete_breaks:
     procedure (p_breaks) options (non_quick);

dcl  p_breaks character (*) parameter;
dcl  current_breaks character (128) varying;
dcl  break_character character (1) aligned;
dcl  (idx, jdx) fixed binary (21);
dcl  deleted bit (1) aligned;

	if abbrev_state.default_breaks then		/* everything but "::" due to deficiencies of the interface */
	     current_breaks = before (DEFAULT_BREAKS, ":") || after (DEFAULT_BREAKS, ":");
	else current_breaks = abbrev_state.user_breaks;

	do idx = 1 to length (p_breaks);
	     break_character = substr (p_breaks, idx, 1);
	     deleted = "0"b;
	     do jdx = 1 to length (current_breaks) while (^deleted);
		if substr (current_breaks, jdx, 1) = break_character then do;
		     current_breaks = substr (current_breaks, 1, (jdx - 1)) || substr (current_breaks, (jdx + 1));
		     deleted = "1"b;
		end;
	     end;
	end;

	call set_user_breaks (current_breaks);		/* still not the default: build the appropriate TCT table */

	return;

     end delete_breaks;
%page;
/* Sets the break sequences used by abbrev to the individual characters in the supplied string */

set_user_breaks:
     procedure (p_new_breaks) options (non_quick);

dcl  p_new_breaks character (128) varying parameter;
dcl  idx fixed binary;

	system_area_ptr = get_system_free_area_ ();

	if ^abbrev_state.default_breaks then free breaks_list in (system_area);

	breaks_list_n_break_sequences, breaks_list_break_strings_lth = length (p_new_breaks);
	allocate breaks_list in (system_area) set (abbrev_state.breaks_list_ptr);
						/* nothing but single character break sequences */

	abbrev_state.user_breaks, breaks_list.break_strings = p_new_breaks;

	abbrev_state.tct_table = low (length (abbrev_state.tct_table));

	do idx = 1 to length (abbrev_state.user_breaks);
	     abbrev_state_tct_table_as_binary (rank (substr (abbrev_state.user_breaks, idx, 1))) = idx;
	     breaks_list.break_sequences (idx).start = idx;
	     breaks_list.break_sequences (idx).lth = 1;
	end;

	abbrev_state.default_breaks = "0"b;		/* no longer using the default */

	return;

     end set_user_breaks;
%page;
/* Initialize abbrev's internal state */

initialize_abbrev_state:
     procedure () /* options (quick) */;

	code = codeptr (debug) -> based_word;		/* snap the links */
	debug_entry_variable = debug;

	code = codeptr (probe) -> based_word;		/* ... in case the linker gets wedged */
	probe_entry_variable = probe;

	string (abbrev_state.flags) = ""b;		/* turn them all off ... */
	abbrev_state.default_breaks = "1"b;		/* ... except that we use the default breaks */

	abbrev_state.profile_ptr = null ();

	abbrev_state.remembered_line_buffer_ptr = null ();
	abbrev_state.remembered_line_buffer_lth, abbrev_state.remembered_line_lth = 0;

	abbrev_state.escape_character = DEFAULT_ABBREV_ESCAPE_CHARACTER;

	abbrev_state.tct_table = abbrev_data_$default_breaks_tct_table;
	abbrev_state.breaks_list_ptr = addr (abbrev_data_$default_breaks_list);

	first_call = "0"b;

	return;

     end initialize_abbrev_state;
%page;
/* Command processor interface: called via cu_$cp to process a command line */

abbrev_:
abbrev_processor:
     entry (P_input_line_ptr, P_input_line_lth, P_code);

	abbrev_type = EXPAND_BOTH;

	input_line_ptr = P_input_line_ptr;
	input_line_lth = P_input_line_lth;

	subsystem_entry = "0"b;
	return_expansion = "0"b;
	allow_request_lines, have_return_code = "1"b;

	go to EXPAND_COMMON;



/* Subsystem request processor interface: called directly by ssu_$listen to expand and execute a subsystem request line */

subsys_process_line:
     entry (P_subsystem_name, P_sci_ptr, P_execute_request, P_subsys_cp_info_ptr, P_subsys_cp, P_default_profile_ptr,
	P_profile_ptr, P_request_line, P_code);

	abbrev_type = EXPAND_BOTH;

	input_line_ptr = addr (P_request_line);
	input_line_lth = length (P_request_line);

	subsystem_entry = "1"b;
	return_expansion = "0"b;
	allow_request_lines, have_return_code = "1"b;

	go to EXPAND_COMMON;


/* Expand only a selected abbrev type and return it to the caller */

abbrev_$expand_line:
     entry (P_abbrev_type, P_input_line_ptr, P_input_line_lth, P_workspace_ptr, P_workspace_lth, P_output_line_ptr,
	P_output_line_lth);

	abbrev_type = P_abbrev_type;
	goto EXPANDED_LINE;


/* Expand a line and return it to the caller */

abbrev_$expanded_line:				/* avoids PL/I naming rules */
     entry (P_input_line_ptr, P_input_line_lth, P_workspace_ptr, P_workspace_lth, P_output_line_ptr, P_output_line_lth);

	abbrev_type = EXPAND_BOTH;

EXPANDED_LINE:
	input_line_ptr = P_input_line_ptr;
	input_line_lth = P_input_line_lth;

	subsystem_entry = "0"b;
	return_expansion = "1"b;
	allow_request_lines, have_return_code = "0"b;

	go to EXPAND_COMMON;


/* Actual expansion starts here */

EXPAND_COMMON:
	if first_call then call initialize_abbrev_state ();

	if ^abbrev_state.set_cp & ^abbrev_state.set_cp_explicit then
	     call cu_$get_command_processor (abbrev_state.command_processor);
						/* no one had yet set a command processor to call */

	code = 0;					/* assume success */

	system_area_ptr = get_system_free_area_ ();

	extended_stack, used_temp_segment, null_line = "0"b;
	expansion_stack_space_lth = 0;		/* haven't extended the stack ... */
	expansion_temp_segment_ptr = null ();		/* ... or used a temp seg yet */

	if input_line_lth = 0 then do;		/* special case zero-length lines: avoids faults... */
	     null_line = "1"b;			/* don't remember this line if in ".r" mode */
EXPANSION_IS_INPUT_LINE:
	     expanded_line_ptr = input_line_ptr;
	     expanded_line_lth = input_line_lth;
	     go to EXPANSION_COMPLETED;
	end;

	start = verify (input_line, WHITE_SPACE_AND_NL);	/* "strip" leading white space */

	if start = 0 then do;			/* all whitespace ... */
	     null_line = "1"b;
	     go to EXPANSION_IS_INPUT_LINE;
	end;


/* format: off */

/* Check for the ".." escape here as the user might have changed the escape character:
      "..": pass the rest of the line to the current command processor; this request allows typeahead of command lines
      when one isn't sure if a subsystem or Multics proper will read the line in question */

/* format: on */

	if allow_request_lines & ^subsystem_entry then	/* only if we'll call cu_$cp eventually ... */
	     if input_line_lth > (start + 1) then	/* ... and there's enough on the line to allow ".." ... */
		if substr (input_line, start, 2) = ".." then do;
		     call cu_$cp (addcharno (input_line_ptr, (start + 1)), (input_line_lth - start - 1), code);
		     go to RETURN_FROM_ABBREV_PROCESSOR;/* ... reflect execution's error code to caller */
		end;


/* Check for and process abbrev request lines */

	if (substr (input_line, start, 1) = abbrev_state.escape_character) then
						/* a request line ... */
	     if allow_request_lines then do;		/* ... and request lines are OK */
		call process_request_line ();
		code = 0;				/* requests ALWAYS "work" */
		go to RETURN_FROM_ABBREV_PROCESSOR;
	     end;

	     else go to EXPANSION_IS_INPUT_LINE;	/* ... no request lines: just give it back */


/* Non-request line: expand the line, remember it (if appropriate), and execute/return it */

	call set_profile_ptr (return_expansion);	/* will need the profile for certain now */

	if return_expansion & (ap_ptr = null ()) then	/* no profile to expand the line with ... */
	     go to EXPANSION_IS_INPUT_LINE;

	on condition (cleanup)
	     begin;
	     if expansion_temp_segment_ptr ^= null () then
		call release_temp_segment_ (ABBREV, expansion_temp_segment_ptr, (0));
	end;

	call expand_line (abbrev_type, start);		/* grows our stack frame */

EXPANSION_COMPLETED:
	if return_expansion then do;			/* expanded_line entry ... */
	     if expanded_line_lth <= P_workspace_lth then /* ... fits into caller's buffer */
		P_output_line_ptr = P_workspace_ptr;
	     else allocate expanded_line in (system_area) set (P_output_line_ptr);
	     P_output_line_lth = expanded_line_lth;
	     P_output_line = expanded_line;
	     go to RETURN_FROM_ABBREV_PROCESSOR;
	end;

	if abbrev_state.remember_lines & ^null_line then do;
	     if abbrev_state.remembered_line_buffer_lth < expanded_line_lth then do;
		if abbrev_state.remembered_line_buffer_ptr ^= null () then
		     free remembered_line_buffer in (system_area);
		abbrev_state.remembered_line_buffer_lth = 128 * divide (expanded_line_lth + 127, 128, 21, 0);
		allocate remembered_line_buffer in (system_area) set (abbrev_state.remembered_line_buffer_ptr);
	     end;
	     abbrev_state.remembered_line_lth = expanded_line_lth;
	     remembered_line = expanded_line;
	end;

	if subsystem_entry then
	     call P_subsys_cp (P_subsystem_name, P_sci_ptr, P_execute_request, P_subsys_cp_info_ptr, expanded_line,
		code);
	else call abbrev_state.command_processor (expanded_line_ptr, expanded_line_lth, code);


RETURN_FROM_ABBREV_PROCESSOR:
	if expansion_temp_segment_ptr ^= null () then
	     call release_temp_segment_ (ABBREV, expansion_temp_segment_ptr, (0));

	if have_return_code then			/* let the caller know how we did */
	     P_code = code;

	return;
%page;
/* Returns the pathname of a profile */

profile_pathname:
     procedure () returns (character (168)) options (non_quick);

dcl  profile_dirname character (168);
dcl  profile_ename character (32);

	call hcs_$fs_get_path_name (ap_ptr, profile_dirname, (0), profile_ename, (0));

	return (pathname_ (profile_dirname, profile_ename));

     end profile_pathname;



/* Aborts abbrev with the given error message: if command level is using the profile identified by ap_ptr, abbreviation
   processing is turned off as this entry is only called when said profile is unusable */

abort_abbrev_processor:
     procedure (p_code, p_message, p_pathname) options (non_quick);

dcl  p_code fixed binary (35) parameter;
dcl  (p_message, p_pathname) character (*) parameter;

	if ap_ptr = abbrev_state.profile_ptr then do;	/* command level was using this profile */
	     if abbrev_state.set_cp then do;		/* ... and we are the command processor */
		call cu_$set_command_processor (abbrev_state.previous_command_processor);
		abbrev_state.set_cp = "0"b;
	     end;
	     if ap_ptr ^= null () then		/* ... don't need it any more */
		call terminate_file_ (ap_ptr, 0, TERM_FILE_TERM, (0));
	     abbrev_state.profile_ptr = null ();	/* ... no longer have a profile */
	end;

	call com_err_ (p_code, ABBREV, p_message, p_pathname);

	code = p_code;				/* make sure right error gets back to caller */

	go to RETURN_FROM_ABBREV_PROCESSOR;

     end abort_abbrev_processor;
%page;
/* Sets ap_ptr to locate the proper profile to be used for expansion in this case: initializes the profile if necessary;
   two versions of this procedure exist to insure that this one is quick */

set_profile_ptr:
     procedure (p_dont_create_profile) /* options (quick) */;

dcl  p_dont_create_profile bit (1) aligned;

	ap_ptr = null ();				/* start somewhere */

	if subsystem_entry then			/* subsystems use arbitrary profiles */
	     if (P_default_profile_ptr = null ()) & (P_profile_ptr = null ()) then
						/* ... use same profile as Multics command level */
		if abbrev_state.profile_ptr = null () then
		     call get_default_profile (p_dont_create_profile);
						/* ... need not succeed if called at expanded_line entry */
		else ap_ptr = abbrev_state.profile_ptr;

	     else do;				/* subsystem supplied the profile */
		if P_profile_ptr ^= null () then
		     ap_ptr = P_profile_ptr;
		else ap_ptr = P_default_profile_ptr;
		call initialize_profile ("1"b, "0"b);	/* ... make sure it's good */
	     end;

	else do;					/* command level invocation */
	     if abbrev_state.profile_ptr = null () then
		call get_default_profile (p_dont_create_profile);
						/* ... need not succeed if called at expanded_line entry */
	     else ap_ptr = abbrev_state.profile_ptr;
	end;

	return;

     end set_profile_ptr;
%page;
/* Sets the profile used by Multics command level to the default profile segment (Person.profile in the home directory):
   creates the profile if request or prints an error message and disables abbrev processing if invoked to expand and
   execute a command/request line */

get_default_profile:
     procedure (p_dont_create_profile) options (non_quick);

dcl  p_dont_create_profile bit (1) aligned parameter;
dcl  profile_dirname character (168);
dcl  (profile_ename, person_id) character (32);
dcl  created_here bit (1) aligned;

	call user_info_ (person_id);
	call user_info_$homedir (profile_dirname);

	profile_ename = rtrim (person_id) || ".profile";

	created_here = "0"b;

	call initiate_file_ (profile_dirname, profile_ename, R_ACCESS, abbrev_state.profile_ptr, (0), code);

	if code = error_table_$noentry then		/* not found ... */
	     if p_dont_create_profile then
		return;				/* ... but that's OK */
	     else do;				/* ... must be able to create it */
		call initiate_file_$create (profile_dirname, profile_ename, RW_ACCESS, abbrev_state.profile_ptr,
		     created_here, (0), code);
		if code ^= 0 then
		     call abort_abbrev_processor (code, "Profile ^a could not be created.",
			pathname_ (profile_dirname, profile_ename));
	     end;

	else if code ^= 0 then			/* wrong access, etc... */
	     call abort_abbrev_processor (code, "^a", pathname_ (profile_dirname, profile_ename));

	ap_ptr = abbrev_state.profile_ptr;		/* got it */

	call initialize_profile ("1"b, created_here);	/* make sure it's OK */

	return;

     end get_default_profile;
%page;
/* Insure that a profile segment has been properly initialized */

initialize_profile:
     procedure (p_announce, p_created_or_initialized) options (non_quick);

dcl  p_announce bit (1) aligned parameter;
dcl  p_created_or_initialized bit (1) aligned parameter;
dcl  profile_mode fixed binary (5);

	if abbrev_profile.version > 127 then		/* older style: garbage collection will fix it */
	     call compact_profile ();

	call hcs_$fs_get_mode (ap_ptr, profile_mode, code);
	if code ^= 0 then				/* have to be able to determine our access */
	     call abort_abbrev_processor (code, "Can not determine access to profile ^a", profile_pathname ());

	if abbrev_profile.next_free = 0 then		/* freshly created profile */
	     if (profile_mode = RW_ACCESS_BIN) | (profile_mode = REW_ACCESS_BIN) then do;
		if p_announce then
		     call ioa_ ("^a: Profile ^a ^[created^;initialized^].", ABBREV, profile_pathname (),
			p_created_or_initialized);
		abbrev_profile.version = ABBREV_PROFILE_VERSION_1;
		abbrev_profile.next_free = fixed (rel (addr (abbrev_profile.data_space)), 18, 0);
		call terminate_file_ (ap_ptr, (36 * abbrev_profile.next_free), TERM_FILE_TRUNC_BC, (0));
	     end;					/* truncate and set bit count in case it contained garbage */

	     else call abort_abbrev_processor (error_table_$moderr, "Can not complete initialization of profile ^a",
		     profile_pathname ());

	else if abbrev_profile.version = 0 then		/* simple upgrade to version 1 */
	     if (profile_mode = RW_ACCESS_BIN) | (profile_mode = REW_ACCESS_BIN) then
		abbrev_profile.version = ABBREV_PROFILE_VERSION_1;

	return;

     end initialize_profile;
%page;
/* Expands a line: if any expansion actually occurs, the caller's stack frame is expanded to hold the result; if the
   expanded string exceeds 16K characters, it is placed in a temporary segment instead */

expand_line:
     procedure (p_abbrev_type, p_start) /* options (quick) */;

dcl  p_abbrev_type fixed bin;				/* get the type of abbreviations to expand */
dcl  p_start fixed binary (21) parameter;		/* where in line to start expansion */

dcl  abbrev_name character (8) aligned;
dcl  break_character character (1) aligned;
dcl  (recognize_bol_abbrevs, need_break_sequence, found_end) bit (1) aligned;
dcl  (start, last_copied_idx, last_expanded_idx, last_quote_idx, break_idx, idx) fixed binary (21);
dcl  break_lth fixed binary;

	expanded_line_ptr = input_line_ptr;		/* assume we don't have to copy/expand it at all */
	expanded_line_lth = input_line_lth;

	last_copied_idx = 0;			/* haven't copied any of the line yet */
	last_expanded_idx = 0;

	recognize_bol_abbrevs = "1"b;

	start = p_start;

	do while (start <= input_line_lth);

	     begin;

dcl  rest_of_line character (input_line_lth - start + 1) unaligned defined (input_line) position (start);

		need_break_sequence = "1"b;		/* find next break sequence */
		break_idx, break_lth = 0;		/* no break sequence yet */
		do while (need_break_sequence & (break_idx <= length (rest_of_line)));
		     begin;
dcl  rest_of_rest_of_line character (length (rest_of_line) - break_idx) unaligned defined (input_line)
	position (start + break_idx);
			if abbrev_state.default_breaks then
			     idx = search (rest_of_rest_of_line, DEFAULT_BREAKS);
			else idx = find_char_$first_in_table (rest_of_rest_of_line, abbrev_state.tct_table);
		     end;
		     if idx = 0 then		/* no more break sequences present */
			break_idx = length (rest_of_line) + 1;
		     else do;			/* a possibility */
			break_idx = break_idx + idx;
			break_character = substr (rest_of_line, break_idx, 1);
						/* format: off */
			do idx = abbrev_state_tct_table_as_binary (rank (break_character))
				to breaks_list.n_break_sequences
				while (need_break_sequence &
				       (substr (breaks_list.break_strings,
					      breaks_list.break_sequences (idx).start, 1) =
				        break_character));
			     if (break_idx + breaks_list.break_sequences (idx).lth - 1) <= length (rest_of_line) then
				if substr (rest_of_line, break_idx, breaks_list.break_sequences (idx).lth) =
				   substr (breaks_list.break_strings, breaks_list.break_sequences (idx).start,
					 breaks_list.break_sequences (idx).lth)
				then do;		/* found it */
				     need_break_sequence = "0"b;
				     break_lth = breaks_list.break_sequences (idx).lth;
				end;
			end;			/* format: on */
		     end;
		end;

		if break_idx > 1 then do;		/* check for an abbreviation */
		     if break_idx <= (length (ape.name) + 1) then do;
			abbrev_name = substr (rest_of_line, 1, (break_idx - 1));
			ape_ptr = lookup_abbrev ();
			if ape_ptr ^= null () then	/* found one */
			     if (recognize_bol_abbrevs & ape.bol & (p_abbrev_type ^= EXPAND_INTERNAL_ONLY))
				| (^ape.bol & (p_abbrev_type ^= EXPAND_BOL_ONLY)) then do;
				begin;
dcl  uncopied_text character (start - last_copied_idx - 1) unaligned defined (input_line) position (last_copied_idx + 1);
				     call make_space (length (uncopied_text) + ape.value_lth);
				     expanded_line_lth = expanded_line_lth + length (uncopied_text);
				     substr (expanded_line, (last_expanded_idx + 1), length (uncopied_text)) =
					uncopied_text;
				     last_expanded_idx = last_expanded_idx + length (uncopied_text);
				     last_copied_idx = last_copied_idx + length (uncopied_text);
				end;		/* just copied in the previously uncopied text */

				expanded_line_lth = expanded_line_lth + ape.value_lth;
				substr (expanded_line, (last_expanded_idx + 1), ape.value_lth) = ape.value;
				last_expanded_idx = last_expanded_idx + ape.value_lth;
				expanded_line_lth = last_expanded_idx;
				last_copied_idx = last_copied_idx + break_idx - 1;
			     end;			/* just "copied" in the abbrev */
		     end;
		     recognize_bol_abbrevs = "0"b;	/* not anymore */
		end;
	     end;

	     start = start + break_idx + break_lth - 1;	/* to character after the break sequence */

	     if start <= input_line_lth then do;	/* something left on line: check special characters */

		if ape_ptr ^= null () then do;
		     if substr (ltrim (reverse (expanded_line)), 1, length (SEMICOLON)) = SEMICOLON
			| substr (ltrim (reverse (expanded_line)), 1, length (LEFT_BRACKET)) = LEFT_BRACKET
			| substr (ltrim (reverse (expanded_line)), 1, length (VERTICAL_BAR || SEMICOLON))
			= VERTICAL_BAR || SEMICOLON then
			recognize_bol_abbrevs = "1"b;
		end;

		if (start - 1) > 0 then		/* ... don't reference off the end */
		     break_character = substr (input_line, (start - 1), 1);
		else break_character = SP;		/* ... assume a space before the line */
		if (break_character = NL) | (break_character = SEMICOLON) | (break_character = LEFT_BRACKET) then
		     recognize_bol_abbrevs = "1"b;
		else if (break_character = VERTICAL_BAR) then do;
		     if substr (input_line, (start - length (SEMICOLON || VERTICAL_BAR)), length (SEMICOLON))
			= SEMICOLON then
			recognize_bol_abbrevs = "1"b;
		end;

		else recognize_bol_abbrevs = recognize_bol_abbrevs & (index (WHITE_SPACE, break_character) ^= 0);
		if break_character = QUOTE then do;
		     begin;
dcl  rest_of_line character (input_line_lth - start + 1) unaligned defined (input_line) position (start);
			found_end = "0"b;		/* a quoted string: ignore everything inside it */
			last_quote_idx = 0;
			do while (^found_end);
			     begin;
dcl  rest_of_rest_of_line character (length (rest_of_line) - last_quote_idx) unaligned defined (input_line)
	position (start + last_quote_idx);
				idx = index (rest_of_rest_of_line, QUOTE);
				if idx = 0 then idx = length (rest_of_rest_of_line) + 1;
				if (idx + 1) <= length (rest_of_rest_of_line) then
				     if substr (rest_of_rest_of_line, (idx + 1), 1) = QUOTE then
					last_quote_idx = last_quote_idx + idx + 1;
				     else do;
					last_quote_idx = last_quote_idx + idx;
					found_end = "1"b;
				     end;
				else do;		/* unbalanced quotes */
				     last_quote_idx = length (rest_of_line) + 1;
				     found_end = "1"b;
				end;
			     end;
			end;
		     end;
		     start = start + last_quote_idx;
		end;
	     end;
	end;

	if extended_stack | used_temp_segment then do;	/* had to copy user's input */
	     begin;
dcl  uncopied_text character (input_line_lth - last_copied_idx) unaligned defined (input_line)
	position (last_copied_idx + 1);
		call make_space (length (uncopied_text));

		expanded_line_lth = expanded_line_lth + length (uncopied_text);
		substr (expanded_line, (last_expanded_idx + 1), length (uncopied_text)) = uncopied_text;
		last_expanded_idx = last_expanded_idx + length (uncopied_text);
	     end;
	     expanded_line_lth = last_expanded_idx;
	end;

	return;
%page;
/* Searches the profile for an abbreviation (internal to expand_line): two versions of this procedure exist to insure that
   this one is quick */

lookup_abbrev:
	procedure () returns (pointer) /* options (quick) */;

dcl  offset fixed binary (18);

	     do offset = abbrev_profile.hash_table (rank (substr (abbrev_name, 1, 1))) repeat (ape.next)
		while (offset ^= 0);
		ape_ptr = pointer (ap_ptr, offset);
		if ape.name = abbrev_name then return (ape_ptr);
	     end;

	     return (null ());			/* here iff not found */

	end lookup_abbrev;
%page;
/* Insures that there is sufficient room either in the stack extension or in the temporary segment to add the requested
   number of characters to the current expansion of the command/request line (internal to expand_line) */

make_space:
	procedure (p_amount) /* options (quick) */;

dcl  p_amount fixed binary (21) parameter;
dcl  extension_ptr pointer;
dcl  new_size fixed binary (21);
dcl  amount_to_grow fixed binary (18);

	     new_size = last_expanded_idx + p_amount;

	     if (new_size <= MAX_STACK_EXTENSION) & ^used_temp_segment then
		if new_size > expansion_stack_space_lth then do;
		     amount_to_grow =		/* double extension or enough room to cover the new piece */
			16 * divide ((max (expansion_stack_space_lth, p_amount) + 63), 64, 18, 0);
		     call cu_$grow_stack_frame (amount_to_grow, extension_ptr, code);
		     if code ^= 0 then go to USE_TEMP_SEGMENT;
		     if ^extended_stack then do;	/* first time: don't set these variables unless ... */
			extended_stack = "1"b;	/* ... cu_$grow_stack_frame succeeds */
			expansion_stack_space_ptr, expanded_line_ptr = extension_ptr;
			expanded_line_lth = 0;
		     end;
		     expansion_stack_space_lth = expansion_stack_space_lth + (4 * amount_to_grow);
		end;
		else ;				/* already using stack extension and its still big enough */

	     else if new_size <= length (expansion_temp_segment) then
USE_TEMP_SEGMENT:					/* try to use a segment for the expansion */
		if ^used_temp_segment then do;	/* ... first time: get the segment ... */
		     call get_temp_segment_ (ABBREV, expansion_temp_segment_ptr, code);
		     if code ^= 0 then go to RETURN_FROM_ABBREV_PROCESSOR;
		     if extended_stack then do;	/* ... and copy whatever was on the stack */
			substr (expansion_temp_segment_ptr -> expanded_line, 1, last_expanded_idx) =
			     substr (expansion_stack_space_ptr -> expanded_line, 1, last_expanded_idx);
			call cu_$shrink_stack_frame (expansion_stack_space_ptr, (0));
			extended_stack = "0"b;
		     end;
		     expanded_line_ptr = expansion_temp_segment_ptr;
		     used_temp_segment = "1"b;
		end;
		else ;				/* already using the temporary segment */

	     else do;				/* expansion won't fit into a segment */
		code = error_table_$command_line_overflow;
		go to RETURN_FROM_ABBREV_PROCESSOR;
	     end;

	     return;

	end make_space;

     end;
%page;
/* Process an abbrev request line */

process_request_line:
     procedure () options (non_quick);

dcl  profile_dirname character (168);
dcl  (request_name, token, profile_ename) character (32);
dcl  new_escape_character character (1) aligned;
dcl  used fixed binary (21);


	start = start + 1;				/* pass over the request character */

	input_line_lth = length (rtrim (input_line, WHITE_SPACE_AND_NL));
						/* strip trailing whitespace */

	begin;

dcl  request_line character (input_line_lth - start + 1) unaligned defined (input_line) position (start);
						/* the request line (without the request character) */


/* Self-identify request ("."): not accepted in subsystems where there is usually a "." request which identifies the
   subsystem itself */

	     if length (request_line) = 0 then
		if subsystem_entry then do;
		     null_line = "1"b;		/* don't bother to remember this request line */
		     go to EXPANSION_IS_INPUT_LINE;
		end;
		else do;
		     call ioa_ ("^a ^a", ABBREV, abbrev_data_$version);
		     return;
		end;


/* Quit abbrev: doesn't require the profile to exist; not accepted in subsystems */

	     if (request_line = "quit") | (request_line = "q") then do;
		if subsystem_entry then
		     call com_err_ (0, ABBREV, """^aq"" is not valid within subsystems.",
			abbrev_state.escape_character);
		else do;				/* Multics command level */
		     if abbrev_state.set_cp then do;	/* ... we were the command processor: reset it */
			call cu_$set_command_processor (abbrev_state.previous_command_processor);
			abbrev_state.set_cp = "0"b;
		     end;
		     if abbrev_state.profile_ptr ^= null () then
			call terminate_file_ (abbrev_state.profile_ptr, 0, TERM_FILE_TERM, (0));
		end;				/* ... and we no longer know where the profile is */
		return;
	     end;


/* ". ": pass the rest of the line to the previous command processor without expansion or remembering */

	     if substr (request_line, 1, 1) = " " then
		begin;
dcl  rest_of_line character (length (request_line) - 1) unaligned defined (input_line) position (start + 1);
		if subsystem_entry then
		     call P_subsys_cp (P_subsystem_name, P_sci_ptr, P_execute_request, P_subsys_cp_info_ptr,
			rest_of_line, code);
		else call abbrev_state.command_processor (addr (rest_of_line), length (rest_of_line), code);
		go to RETURN_FROM_ABBREV_PROCESSOR;	/* reflect execution's error code to caller */
	     end;


/* Remaining requests use the parsed version of the request line */

	     used = 0;				/* haven't look at the line yet */

	     request_name = get_token ();		/* get the request name */

	     if (request_name = "use") | (request_name = "u") then do;
		call do_use_request ();		/* switch profiles */
		return;
	     end;

	     else if request_name = "terminate_process" then do;
		call validate_no_arguments ("terminate_process");
		code = pointer (baseptr (-2), "400000"b3) -> based_word;
	     end;					/* terminates the process without prejudice */

	     else if request_name = "debug" then do;
		call validate_no_arguments ("debug");
		call ioa_ ("debug:");
		call debug_entry_variable ();		/* invokes debug in a possibly damaged process */
		return;
	     end;

	     else if request_name = "probe" then do;
		call validate_no_arguments ("probe");
		call probe_entry_variable ();		/* invokes probe in a possibly damaged process */
		return;
	     end;

	     else if request_name = "?" then do;	/* display request list */
		call do_help_request ();
		return;
	     end;
	     call set_profile_ptr ("0"b);		/* all other requests require that the profile exist */


/* Print the pathname of the current profile */

	     if (request_name = "profile") | (request_name = "p") then do;
		call validate_no_arguments ("p");	/* use short name for compatibility with documentation */
		call hcs_$fs_get_path_name (ap_ptr, profile_dirname, (0), profile_ename, (0));
		call ioa_ ("^a", pathname_ (profile_dirname, profile_ename));
	     end;


/* Set/reset remember mode: in remember mode, abbrev will save the expansion of the last command/request line executed */

	     else if (request_name = "remember") | (request_name = "r") then do;
		call validate_no_arguments ("r");
		abbrev_state.remember_lines = "1"b;	/* just set the flag */
	     end;

	     else if (request_name = "forget") | (request_name = "f") then do;
		call validate_no_arguments ("f");
		abbrev_state.remember_lines = "0"b;	/* stop remembering and get rid of old remembered line ... */
		if abbrev_state.remembered_line_buffer_ptr ^= null () then
		     free remembered_line_buffer in (system_area);
		abbrev_state.remembered_line_buffer_ptr = null ();
		abbrev_state.remembered_line_buffer_lth, abbrev_state.remembered_line_lth = 0;
	     end;


/* Set the escape character which is the trigger for request lines */

	     else if (request_name = "escape") | (request_name = "esc") then do;
		token = get_token ();		/* is there a new request character? */
		if token ^= "" then			/* ... yes: make sure it's not too long */
		     if length (rtrim (token)) > length (abbrev_state.escape_character) then
			call com_err_ (0, ABBREV, "The escape sequence must be a single character; not ""^a"".",
			     token);
		     else do;			/* ... length is OK */
			new_escape_character = substr (token, 1, 1);
			token = get_token ();
			if token = "" then		/* ... nothing else on the line */
			     abbrev_state.escape_character = new_escape_character;
			else call com_err_ (0, ABBREV, "Only one escape character may be specified. ""^a""", token);
		     end;
		else call ioa_ ("Abbrev escape character: ^a", abbrev_state.escape_character);
	     end;


/* Following requests are all complex enough that they are each implemented as separate internal procedures */

	     else if (request_name = "show") | (request_name = "s") then call do_show_request ();
						/* show an expansion */

	     else if (request_name = "l") | (request_name = "la") | (request_name = "lab") | (request_name = "la^b")
		| (request_name = "lb") | (request_name = "l^b") | (request_name = "ls") | (request_name = "lsb")
		| (request_name = "ls^b") | (request_name = "lx") | (request_name = "lxb") | (request_name = "lx^b")
		then
		call do_list_request ();		/* list one or more abbrev definitions */

	     else if (request_name = "a") | (request_name = "af") | (request_name = "ab") | (request_name = "abf") then
		call do_add_request ();		/* define a new abbreviation */

	     else if (request_name = "delete") | (request_name = "dl") | (request_name = "d") then
		call do_delete_request ();		/* delete one or more abbreviations */

	     else if (request_name = "rename") | (request_name = "rn") then call do_rename_request ();
						/* rename one or more abbreviations */

	     else if request_name = "edit" then call do_edit_request ();

/* edit the definition of an abbreviation */

	     else if (request_name = "switch_on") | (request_name = "swn") then call do_switch_request ("1"b);
						/* turn on switches for one or more abbreviations */

	     else if (request_name = "switch_off") | (request_name = "swf") then call do_switch_request ("0"b);
						/* turn off switches for one or more abbreviations */


/* Here iff the request is not recognized */

	     else call com_err_ (error_table_$request_not_recognized, ABBREV, """^a^a""", abbrev_state.escape_character,
		     request_name);

	     return;
%page;
/* Switch to another profile (internal to process_request_line begin block): if no profile pathname is given, reverts to
   the default profile; otherwise, the given pathname is abbrev expanded (if possible) before we actually try to use it as
   a convenience */

do_use_request:
     procedure ();

dcl  expanded_pathname_buffer character (256);
dcl  expanded_pathname character (expanded_pathname_lth) based (expanded_pathname_ptr);
dcl  expanded_pathname_lth fixed binary (21);
dcl  expanded_pathname_ptr pointer;

dcl  new_profile_dirname character (168);
dcl  (new_profile_ename) character (32);

dcl  new_profile_ptr pointer;

dcl  created_here bit (1) aligned;
dcl  try_to_create bit (1);				/* command_query_$yes_no is declared wrong... */


	call skip_whitespace ();			/* find start of pathname */

	begin;

dcl  original_pathname character (length (request_line) - used) unaligned defined (input_line) position (start + used);

	     new_profile_ptr = null ();		/* haven't gotten it yet */

	     call set_profile_ptr ("1"b);		/* try to get the current profile */

	     if original_pathname = "" then do;		/* reset to default profile */
		call terminate_old_profile ();
		if subsystem_entry then		/* ... reset to default for this invocation */
		     P_profile_ptr = null ();
		else call get_default_profile ("1"b);
		return;
	     end;

	     if abbrev_state.profile_ptr = null () then do;
		expanded_pathname_ptr = addr (original_pathname);
		expanded_pathname_lth = length (original_pathname);
	     end;

	     else call abbrev_$expand_line (EXPAND_INTERNAL_ONLY, addr (original_pathname), length (original_pathname),
		     addr (expanded_pathname_buffer), length (expanded_pathname_buffer), expanded_pathname_ptr,
		     expanded_pathname_lth);

	     if substr (expanded_pathname, 1, length (QUOTE)) = QUOTE then
		if substr (expanded_pathname, expanded_pathname_lth, length (QUOTE)) = QUOTE then
		     expanded_pathname = substr (expanded_pathname, 2, expanded_pathname_lth - 2);
						/* remove one level of quotes */
		else do;
		     call com_err_ (error_table_$unbalanced_quotes, ABBREV, expanded_pathname);
		     return;
		end;
	     else ;

	     call expand_pathname_$add_suffix (expanded_pathname, "profile", new_profile_dirname, new_profile_ename,
		code);
	     if code ^= 0 then			/* before we release the storage */
		call com_err_ (code, ABBREV, "^a", expanded_pathname);
	     if (expanded_pathname_ptr ^= addr (original_pathname))
		& (expanded_pathname_ptr ^= addr (expanded_pathname_buffer)) then
		free expanded_pathname in (system_area);
	     if code ^= 0 then return;		/* ... message already printed */

	     created_here = "0"b;			/* assume we find it */

	     call initiate_file_ (new_profile_dirname, new_profile_ename, R_ACCESS, new_profile_ptr, (0), code);
	     if code ^= 0 then
		if code = error_table_$noentry then do;
		     call command_query_$yes_no (try_to_create, 0, ABBREV, "",
			"Profile ^a not found.  Do you want to create it?",
			pathname_ (new_profile_dirname, new_profile_ename));
		     if try_to_create then
			call initiate_file_$create (new_profile_dirname, new_profile_ename, RW_ACCESS,
			     new_profile_ptr, created_here, (0), code);
		     else return;			/* user doesn't want to try */
		end;

	     if code ^= 0 then do;
		call com_err_ (code, ABBREV, "^a", pathname_ (new_profile_dirname, new_profile_ename));
		return;				/* couldn't switch ... */
	     end;

	     call terminate_old_profile ();

	     if subsystem_entry then			/* change this invocation's profile */
		P_profile_ptr, ap_ptr = new_profile_ptr;
	     else abbrev_state.profile_ptr, ap_ptr = new_profile_ptr;
						/* change command level's profile */
	     call initialize_profile (^created_here, created_here);

	     return;
	end;



/* Terminate the old profile segment (internal to do_use_request) */

terminate_old_profile:
	procedure ();

	     if ap_ptr ^= null () then		/* terminate the old profile ... */
		if subsystem_entry then		/* ... but only if not the subsystem's default profile */
		     if (ap_ptr ^= P_default_profile_ptr)
			& ((P_default_profile_ptr ^= null ())
			| ((P_default_profile_ptr = null ()) & (P_profile_ptr ^= null ()))) then
			call terminate_file_ (ap_ptr, 0, TERM_FILE_TERM, (0));
		     else ;

		else call terminate_file_ (ap_ptr, 0, TERM_FILE_TERM, (0));

	     return;

	end terminate_old_profile;

     end do_use_request;
%page;
/* Show an expansion (internal to process_request_line begin block): if anything else is present on the line, expand it;
   otherwise, show the last expansion if remember mode is set */

do_show_request:
     procedure ();

dcl  result_line character (result_line_lth) based (result_line_ptr);
dcl  result_line_lth fixed binary (21);
dcl  result_line_ptr pointer;

	call skip_whitespace ();			/* skip to request line (if any) */

	if used < length (request_line) then
	     begin;
dcl  rest_of_line character (length (request_line) - used) unaligned defined (input_line) position (start + used);
	     call abbrev_$expanded_line (addr (rest_of_line), length (rest_of_line), null (), 0, result_line_ptr,
		result_line_lth);
	     call ioa_ ("^a", result_line);
	     free result_line in (system_area);		/* guarenteed to have been allocated */
	end;

	else if abbrev_state.remember_lines then
	     if abbrev_state.remembered_line_lth > 0 then
		call ioa_$nnl ("^a^[^/^]", remembered_line,
		     (substr (remembered_line, abbrev_state.remembered_line_lth, 1) ^= NL));
	     else call com_err_ (0, ABBREV, "Nothing has been remembered yet.");

	else call com_err_ (0, ABBREV, "Remember mode is not enabled.");

	return;

     end do_show_request;
%page;
/* List one or more abbreviation definitions (internal to process_request_line begin block): options are to list all
   abbrevs, specific abbrevs, or all abbrevs which start with a given character sequence */

do_list_request:
     procedure ();

dcl  1 list aligned based (list_segment_ptr),
       2 n_abbrevs fixed binary,
       2 pad bit (36),
       2 abbrevs (0 refer (list.n_abbrevs)) like lae;
dcl  list_segment_ptr pointer;

dcl  1 lae aligned based,
       2 name character (8),
       2 ptr pointer;

dcl  1 list_sort_list aligned based (list_sort_list_ptr),
       2 n fixed binary,
       2 ptrs (0 refer (list.n_abbrevs)) pointer unaligned;
dcl  list_sort_list_ptr pointer;

dcl  offset fixed binary (18);
dcl  (hash_slot, previous_n_abbrevs, token_lth, idx) fixed binary;
dcl  exact_match bit (1) aligned;
dcl  (la, ls, lx, bol, nbol) bit (1);
dcl  emessage char (64);


	call skip_whitespace ();			/* ".la" requires some arguments */
	if used = length (request_line) & request_name ^= "l" & request_name ^= "lb" & request_name ^= "l^b" then do;
	     call com_err_ (0, ABBREV, " Usage:  ^a^a STRs", abbrev_state.escape_character, request_name);
	     go to RETURN_FROM_PROCESS_REQUEST_LINE;
	end;

	call get_temp_segment_ (ABBREV, list_segment_ptr, code);
	if code ^= 0 then do;
	     call com_err_ (code, ABBREV, "Getting sorting space for listing abbreviations.");
	     go to RETURN_FROM_PROCESS_REQUEST_LINE;
	end;

	on condition (cleanup)
	     begin;
	     if list_segment_ptr ^= null () then call release_temp_segment_ (ABBREV, list_segment_ptr, (0));
	end;

	exact_match = request_name = "l" | request_name = "lb" | request_name = "l^b";
	la = substr (request_name, 1, 2) = "la";
	ls = substr (request_name, 1, 2) = "ls";
	lx = substr (request_name, 1, 2) = "lx";
	bol = index (request_name, "b") ^= 0 & index (request_name, "^") = 0;
	nbol = index (request_name, "b") ^= 0 & index (request_name, "^") ^= 0;

	if exact_match & (used = length (request_line)) then do;
	     list.n_abbrevs = 0;			/* list all abbreviations */
	     do hash_slot = lbound (abbrev_profile.hash_table, 1) to hbound (abbrev_profile.hash_table, 1);
		do offset = abbrev_profile.hash_table (hash_slot) repeat (ape.next) while (offset ^= 0);
		     ape_ptr = pointer (ap_ptr, offset);
		     if ape.name ^= "" then do;
			if request_name = "l" then call set_list_entry ();
			if request_name = "lb" then do;
			     if ape.bol then call set_list_entry ();
			end;
			if request_name = "l^b" then do;
			     if ^ape.bol then call set_list_entry ();
			end;
		     end;
		end;
	     end;
	     if list.n_abbrevs = 0 then do;
		call com_err_ (0, ABBREV, "No abbreviations defined.");
		go to RETURN_FROM_PROCESS_REQUEST_LINE;
	     end;					/* cleanup handler gets the temp segment */
	end;

	else if exact_match then do;			/* list explicit abbreviations */
	     list.n_abbrevs = 0;
	     do token = get_token () repeat (get_token ()) while (token ^= "");
		if length (rtrim (token)) > length (ape.name) then
		     call com_err_ (0, ABBREV, "Maximum length of an abbreviation name is ^d characters. ""^a""",
			length (ape.name), token);
		else do;
		     ape_ptr = lookup_abbrev (token);
		     if ape_ptr = null () then	/* not found */
			call com_err_ (0, ABBREV, """^a"" is not defined.", token);
		     else do;
			if request_name = "l" then call set_list_entry ();
			if request_name = "lb" then do;
			     if ape.bol then call set_list_entry ();
			end;
			if request_name = "l^b" then do;
			     if ^ape.bol then call set_list_entry ();
			end;
		     end;
		end;
	     end;
	     if list.n_abbrevs = 0 then go to RETURN_FROM_PROCESS_REQUEST_LINE;
	end;					/* didn't find any at all */

	else do;					/* list all abbreviations starting with the given string */
	     list.n_abbrevs = 0;
	     do token = get_token () repeat (get_token ()) while (token ^= "");
		previous_n_abbrevs = list.n_abbrevs;
		token_lth = length (rtrim (token));
		if (token_lth > length (ape.name)) & ^lx then
		     call com_err_ (0, ABBREV, "Maximum length of an abbreviation name is ^d characters. ""^a""",
			length (ape.name), token);
		else do;
		     do hash_slot = lbound (abbrev_profile.hash_table, 1) to hbound (abbrev_profile.hash_table, 1);
			do offset = abbrev_profile.hash_table (hash_slot) repeat (ape.next) while (offset ^= 0);
			     ape_ptr = pointer (ap_ptr, offset);
			     if ape.name ^= "" then do;
				if ^bol & ^nbol then call set_list_entry ();
				if bol & ape.bol then call set_list_entry ();
				else if nbol & ^ape.bol then call set_list_entry ();
			     end;
			end;
		     end;
		     if previous_n_abbrevs = list.n_abbrevs then do;
			emessage = "";
			if la then emessage = "No abbreviations defined which start with";
			else if lx then emessage = "No abbreviation expansions defined which contain";
			else emessage = "No abbreviations defined which contain";
			call com_err_ (0, ABBREV, "^a ""^a"".", emessage, token);
		     end;
		end;
	     end;
	     if list.n_abbrevs = 0 then go to RETURN_FROM_PROCESS_REQUEST_LINE;
	end;

	list_sort_list_ptr = pointer (list_segment_ptr, currentsize (list));
	list_sort_list.n = list.n_abbrevs;

	do idx = 1 to list_sort_list.n;
	     list_sort_list.ptrs (idx) = addr (list.abbrevs (idx).name);
	end;

	call sort_items_$char (list_sort_list_ptr, length (ape.name));

	do idx = 1 to list_sort_list.n;
	     ape_ptr = list_sort_list.ptrs (idx) -> lae.ptr;
	     call ioa_ ("^[b^;^x^]^x^a^12t^a", ape.bol, ape.name, ape.value);
	end;

	call release_temp_segment_ (ABBREV, list_segment_ptr, (0));

	return;

set_list_entry:
	proc ();

	     if ^ls & ^lx & ^la then go to set_entry;
	     if la then do;
		if token = substr (ape.name, 1, token_lth) then go to set_entry;
		return;
	     end;
	     if ls then do;
		if index (ape.name, substr (token, 1, token_lth)) ^= 0 then go to set_entry;
		return;
	     end;
	     if lx then do;
		if index (ape.value, substr (token, 1, token_lth)) ^= 0 then go to set_entry;
		return;
	     end;
set_entry:
	     list.n_abbrevs, idx = list.n_abbrevs + 1;
	     list.abbrevs (idx).name = ape.name;
	     list.abbrevs (idx).ptr = ape_ptr;

	     return;

	end set_list_entry;

     end do_list_request;
%page;
/* Defines a new abbreviation (internal to process_request_line begin block): if the abbreviation is already defined and
   the user did not explicitly request to overwrite it, ask the user if they wish to redefine the abbreviation */

do_add_request:
     procedure ();

dcl  last_ape_ptr pointer;
dcl  abbrev_name character (32);
dcl  (old_size, hash_slot) fixed binary (18);
dcl  (force, bol) bit (1) aligned;
dcl  add_it bit (1);

	if ^write_access () then do;
	     call com_err_ (error_table_$moderr, ABBREV, "Can not add abbreviations to profile ^a", profile_pathname ())
		;
	     go to RETURN_FROM_PROCESS_REQUEST_LINE;
	end;

	token = get_token ();			/* pick up name of the abbreviation */

	if token = "" then do;			/* no abbreviation */
PRINT_ADD_REQUEST_USAGE:
	     call com_err_ (0, ABBREV, " Usage:  ^a^a name expansion", abbrev_state.escape_character, request_name);
	     go to RETURN_FROM_PROCESS_REQUEST_LINE;
	end;

	abbrev_name = token;			/* save it */
	if ^validate_abbrev_name (abbrev_name) then go to RETURN_FROM_PROCESS_REQUEST_LINE;

	call skip_whitespace ();			/* find the definition */
	if used = length (request_line) then go to PRINT_ADD_REQUEST_USAGE;

	force = (request_name = "af") | (request_name = "abf");
	bol = (request_name = "ab") | (request_name = "abf");

	begin;

dcl  definition character (length (request_line) - used) unaligned defined (input_line) position (start + used);

	     ape_ptr = lookup_abbrev (abbrev_name);	/* see if it's already defined */

	     if ape_ptr ^= null () then		/* already defined ... */
		if force then do;			/* ... and the user wants it redefined */
OVERWRITE_PREVIOUS_DEFINITION:
		     if ape.value_lth >= length (definition) then do;
			old_size = currentsize (ape); /* ... enough room in old entry for new definition */
			ape.bol = bol;		/* ... redefinition could change this value */
			ape.value_lth = length (definition);
			ape.value = definition;
			abbrev_profile.garbage = abbrev_profile.garbage + old_size - currentsize (ape);
		     end;
		     else do;			/* ... not enough room: delete it and add to the end */
			ape.name = "";
			abbrev_profile.garbage = abbrev_profile.garbage + currentsize (ape);
			go to CREATE_NEW_DEFINITION;
		     end;
		end;

		else do;				/* ... user didn't know it: ask them about it */
		     call command_query_$yes_no (add_it, 0, ABBREV, "",
			"Abbreviation is already defined as:^/^3x^[b^;^x^]^x^a^15t^a^/Do you wish to redefine it?",
			ape.bol, ape.name, ape.value);
		     if add_it then go to OVERWRITE_PREVIOUS_DEFINITION;
		end;				/* if answer is no we fall through and do nothing */

	     else do;				/* brand new abbreviation ... */
CREATE_NEW_DEFINITION:
		ape_ptr = pointer (ap_ptr, abbrev_profile.next_free);
		substr (ape.name, 1, length (ape.name)) = substr (abbrev_name, 1, length (ape.name));
		ape.next = 0;			/* last abbreviation in this bucket */
		string (ape.flags) = ""b;
		ape.bol = bol;
		ape.value_lth = length (definition);
		ape.value = definition;
		abbrev_profile.next_free = abbrev_profile.next_free + currentsize (ape);
		hash_slot = rank (substr (abbrev_name, 1, 1));
		if abbrev_profile.hash_table (hash_slot) = 0 then
		     abbrev_profile.hash_table (hash_slot) = fixed (rel (ape_ptr), 18, 0);
		else do;				/* add to end of the chain */
		     do last_ape_ptr = pointer (ap_ptr, abbrev_profile.hash_table (hash_slot))
			repeat (pointer (ap_ptr, last_ape_ptr -> ape.next)) while (last_ape_ptr -> ape.next ^= 0);
		     end;
		     last_ape_ptr -> ape.next = fixed (rel (ape_ptr), 18, 0);
		end;
	     end;
	end;

	call compact_profile_if_needed ("1"b);

	return;

     end do_add_request;
%page;
/* Deletes one or more abbreviation definitions (internal to process_request_line begin block) */

do_delete_request:
     procedure ();

	if ^write_access () then do;
	     call com_err_ (error_table_$moderr, ABBREV, "Can not delete abbreviations from profile ^a",
		profile_pathname ());
	     go to RETURN_FROM_PROCESS_REQUEST_LINE;
	end;

	call skip_whitespace ();			/* make sure there are some abbreviations to delete */
	if used = length (request_line) then do;
	     call com_err_ (0, ABBREV, " Usage:  ^ad names", abbrev_state.escape_character);
	     go to RETURN_FROM_PROCESS_REQUEST_LINE;
	end;

	do token = get_token () repeat (get_token ()) while (token ^= "");
	     if length (rtrim (token)) > length (ape.name) then
		call com_err_ (0, ABBREV, "Maximum length of an abbreviation name is ^d characters. ""^a""",
		     length (ape.name), token);
	     else do;				/* abbreviation name is the right length at least */
		ape_ptr = lookup_abbrev (token);
		if ape_ptr = null () then
		     call com_err_ (0, ABBREV, """^a"" is not defined.", token);
		else do;				/* found it... */
		     ape.name = "";			/* ... mark it as deleted */
		     abbrev_profile.garbage = abbrev_profile.garbage + currentsize (ape);
		end;
	     end;
	end;

	call compact_profile_if_needed ("0"b);

	return;

     end do_delete_request;
%page;
/* Renames one or more abbreviations */

do_rename_request:
     procedure ();

dcl  (old_abbrev_name, new_abbrev_name) character (32);
dcl  (old_ape_ptr, new_ape_ptr, the_ape_ptr, prior_ape_ptr) pointer;
dcl  rename_it bit (1);
dcl  (old_hash_slot, new_hash_slot) fixed binary;

	if ^write_access () then do;
	     call com_err_ (error_table_$moderr, ABBREV, "Can not rename abbreviations in profile ^a.",
		profile_pathname ());
	     go to RETURN_FROM_PROCESS_REQUEST_LINE;
	end;

	old_abbrev_name = get_token ();

	if old_abbrev_name = "" then do;		/* nothing given at all ... */
	     call com_err_ (0, ABBREV, "Usage:  ^arename old_name1 new_name1 {... old_nameN new_nameN}",
		abbrev_state.escape_character);
	     go to RETURN_FROM_PROCESS_REQUEST_LINE;
	end;

	do while (old_abbrev_name ^= "");		/* as long as there's at least one name */

	     new_abbrev_name = get_token ();
	     if new_abbrev_name = "" then do;		/* odd number of arguments */
		call com_err_ (error_table_$noarg, ABBREV, "New name for abbreviation ""^a"".", old_abbrev_name);
		go to RETURN_FROM_PROCESS_REQUEST_LINE;
	     end;

	     old_ape_ptr = lookup_abbrev (old_abbrev_name);

	     if old_ape_ptr ^= null () then		/* really is something to rename */
		if validate_abbrev_name (new_abbrev_name) then do;
		     new_ape_ptr = lookup_abbrev (new_abbrev_name);

		     if new_ape_ptr = null () then do;	/* new name not yet used ... */
RENAME_THE_OLD_ABBREVIATION:				/* ... OK to rename */
			old_hash_slot = rank (substr (old_abbrev_name, 1, 1));
			new_hash_slot = rank (substr (new_abbrev_name, 1, 1));
			if old_hash_slot = new_hash_slot then
			     /*** same hash for both names: just rename it */
			     substr (old_ape_ptr -> ape.name, 1, length (old_ape_ptr -> ape.name)) =
				substr (new_abbrev_name, 1, length (old_ape_ptr -> ape.name));
			else do;
			     /*** different hash: splice the abbrev out of the old chain ... */
			     prior_ape_ptr = null ();
			     do the_ape_ptr = pointer (ap_ptr, abbrev_profile.hash_table (old_hash_slot))
				repeat (pointer (ap_ptr, the_ape_ptr -> ape.next))
				while ((the_ape_ptr ^= old_ape_ptr) & (the_ape_ptr -> ape.next ^= 0));
				prior_ape_ptr = the_ape_ptr;
			     end;
			     if the_ape_ptr ^= old_ape_ptr then
				call abort_abbrev_processor (error_table_$bad_segment, "^a", profile_pathname ());
			     if prior_ape_ptr = null () then
				abbrev_profile.hash_table (old_hash_slot) = old_ape_ptr -> ape.next;
			     else prior_ape_ptr -> ape.next = old_ape_ptr -> ape.next;
			     /*** ... and add it to the end of its new chain */
			     substr (old_ape_ptr -> ape.name, 1, length (old_ape_ptr -> ape.name)) =
				substr (new_abbrev_name, 1, length (old_ape_ptr -> ape.name));
			     old_ape_ptr -> ape.next = 0;
			     if abbrev_profile.hash_table (new_hash_slot) = 0 then
				abbrev_profile.hash_table (new_hash_slot) = fixed (rel (old_ape_ptr), 18, 0);
			     else do;
				do prior_ape_ptr = pointer (ap_ptr, abbrev_profile.hash_table (new_hash_slot))
				     repeat (pointer (ap_ptr, prior_ape_ptr -> ape.next))
				     while (prior_ape_ptr -> ape.next ^= 0);
				end;
				prior_ape_ptr -> ape.next = fixed (rel (old_ape_ptr), 18, 0);
			     end;
			end;
		     end;

		     else do;			/* new name already used: get permission to redefine */
			call command_query_$yes_no (rename_it, 0, ABBREV, "",
			     "Abbreviation is already defined as:^/^3x^[b^;^x^]^x^a^15t^a^/Do you wish to redefine it by renaming:^/^3x^[b^;^x^]^x^a^15t^a^/to ""^a""?",
			     new_ape_ptr -> ape.bol, new_ape_ptr -> ape.name, new_ape_ptr -> ape.value,
			     old_ape_ptr -> ape.bol, old_ape_ptr -> ape.name, old_ape_ptr -> ape.value,
			     new_ape_ptr -> ape.name);
			if rename_it then do;	/* ... delete the old definition */
			     new_ape_ptr -> ape.name = "";
			     abbrev_profile.garbage = abbrev_profile.garbage + currentsize (new_ape_ptr -> ape);
			     go to RENAME_THE_OLD_ABBREVIATION;
			end;
		     end;				/* ... a no falls through to do next rename (if any) */
		end;

		else ;				/* validate_abbrev_name has already complained */

	     else call com_err_ (0, ABBREV, """^a"" is not defined.", old_abbrev_name);

	     old_abbrev_name = get_token ();
	end;

	call compact_profile_if_needed ("0"b);

	return;

     end do_rename_request;
%page;
/* Edits the definition of one or more abbreviations (internal to process_request_line begin block) via qedx_ */

do_edit_request:
     procedure ();

dcl  1 local_qi aligned,				/* data to invoke the editor */
       2 header like qedx_info.header,
       2 buffer like qedx_info.buffers;
dcl  initial_abbrev_name character (32);


	if ^write_access () then do;
	     call com_err_ (error_table_$moderr, ABBREV, "Can not edit abbreviations in profile ^a.",
		profile_pathname ());
	     go to RETURN_FROM_PROCESS_REQUEST_LINE;
	end;


/* Parse arguments: exactly one allowed -- the name of an existing abbreviation */

	initial_abbrev_name = get_token ();		/* get name of abbreviation to start editing */

	if initial_abbrev_name = "" then do;
PRINT_EDIT_REQUEST_USAGE:
	     call com_err_ (0, ABBREV, "Usage:  ^aedit name", abbrev_state.escape_character);
	     go to RETURN_FROM_PROCESS_REQUEST_LINE;
	end;

	token = get_token ();			/* shouldn't be anything else... */
	if token ^= "" then go to PRINT_EDIT_REQUEST_USAGE;

	if ^validate_abbrev_name (initial_abbrev_name) then go to RETURN_FROM_PROCESS_REQUEST_LINE;
						/* invalid name */

	ape_ptr = lookup_abbrev (initial_abbrev_name);
	if ape_ptr = null () then do;			/* the abbreviation must exist */
	     call com_err_ (0, ABBREV, """^a"" is not defined.", initial_abbrev_name);
	     go to RETURN_FROM_PROCESS_REQUEST_LINE;
	end;


/* Print the abbreviation's definition and the editor prompt */

	call ioa_ ("^[b^;^x^]^x^a^12t^a", ape.bol, ape.name, ape.value);
	call ioa_ ("Edit:");


/* Setup and invoke the editor */

	local_qi.version = QEDX_INFO_VERSION_1;
	local_qi.editor_name = ABBREV;
	local_qi.buffer_io = abbrev_io;		/* we will read/write definitions directly */

	string (local_qi.header.flags) = ""b;
	local_qi.query_if_modified, local_qi.caller_does_io = "1"b;

	local_qi.n_buffers = 1;
	local_qi.buffer_name = "0";			/* buffer "0": the default buffer */
	local_qi.buffer_pathname = initial_abbrev_name;	/* ... fill it with definition user wants edited */
	string (local_qi.buffer.flags) = ""b;		/* ... let the caller switch abbreviations */

	call qedx_ (addr (local_qi), (0));		/* do it */

	return;					/* needn't check the code */
%page;
/* Read/write an abbreviation's definition to the editor's buffer (internal to do_edit_request) */

abbrev_io:
	procedure (p_qbii_ptr, p_ok);

dcl  p_qbii_ptr pointer parameter;
dcl  p_ok bit (1) aligned parameter;

dcl  1 qbii aligned based (qbii_ptr) like qedx_buffer_io_info;
dcl  qbii_value character (qbii.buffer_lth) based (qbii.buffer_ptr);
dcl  last_ape_ptr pointer;
dcl  (old_size, hash_slot) fixed binary (18);
dcl  bol bit (1) aligned;
dcl  redefine_it bit (1);


	     qbii_ptr = p_qbii_ptr;

	     if qbii.version ^= QEDX_BUFFER_IO_INFO_VERSION_1 then do;
		call com_err_ (error_table_$unimplemented_version, ABBREV, "Buffer I/O from qedx_.");
		p_ok = "0"b;
	     end;


	     else if qbii.direction = QEDX_READ_FILE then do;

/* Fetch abbreviation definition from profile */

		if validate_abbrev_name (rtrim (qbii.pathname)) then do;
		     ape_ptr = lookup_abbrev (rtrim (qbii.pathname));

		     if ape_ptr ^= null () then	/* ... it exists */
			if (ape.value_lth + 1) <= qbii.buffer_max_lth then do;
			     qbii.buffer_lth = ape.value_lth;
			     qbii_value = ape.value;
			     if substr (qbii_value, qbii.buffer_lth, 1) ^= NL then do;
				qbii.buffer_lth = qbii.buffer_lth + 1;
				substr (qbii_value, qbii.buffer_lth, 1) = NL;
			     end;
			     p_ok = "1"b;		/* ... success */
			end;

			else do;			/* ... won't fit */
			     call com_err_ (0, qbii.editor_name,
				"Definition of ""^a"" is too large for the editor.", qbii.pathname);
			     p_ok = "0"b;
			end;

		     else do;			/* ... no such abbreviation */
			call com_err_ (0, qbii.editor_name, """^a"" is not defined.", qbii.pathname);
			p_ok = "0"b;
		     end;
		end;

		else p_ok = "0"b;			/* ... illegal abbreviation name */
	     end;


	     else if qbii.direction = QEDX_WRITE_FILE then do;

/* Write the editor's buffer as the definition of an abbreviation: if the abbreviation doesn't already exist, it will be
   created as an expand-anywhere abbrevation */

		if validate_abbrev_name (rtrim (qbii.pathname)) then do;
		     if substr (qbii_value, qbii.buffer_lth, 1) = NL then qbii.buffer_lth = qbii.buffer_lth - 1;
						/* strip trailing newline added for convenience */

		     ape_ptr = lookup_abbrev (rtrim (qbii.pathname));

		     if ape_ptr ^= null () then do;	/* already defined ... */
			bol = ape.bol;		/* ... in case we have to move it elsewhere */

			if ^qbii.default_pathname then do;
						/* ... not the abbrev being edited by default: query ... */
			     call command_query_$yes_no (redefine_it, 0, ABBREV, "",
				"Abbreviation is already defined as:^/^3x^[b^;^x^]^x^a^15t^a^/Do you wish to redefine it?",
				ape.bol, ape.name, ape.value);
			     if ^redefine_it then do; /* ... ... user didn't realize and didn't mean it */
				p_ok = "0"b;
				return;
			     end;
			end;			/* ... ...user says it's OK anyway */

			if ape.value_lth >= qbii.buffer_lth then do;
			     old_size = currentsize (ape);
			     ape.value_lth = qbii.buffer_lth;
			     ape.value = qbii_value;
			     abbrev_profile.garbage = abbrev_profile.garbage + old_size - currentsize (ape);
			end;
			else do;			/* ... not enough room: delete it and add to the end */
			     ape.name = "";
			     abbrev_profile.garbage = abbrev_profile.garbage + currentsize (ape);
			     go to CREATE_NEW_DEFINITION;
			end;
		     end;

		     else do;			/* ... brand new abbreviation ... */
			bol = "0"b;		/* ... defaults to anywhere on line expansion */
CREATE_NEW_DEFINITION:
			ape_ptr = pointer (ap_ptr, abbrev_profile.next_free);
			substr (ape.name, 1, length (ape.name)) = substr (qbii.pathname, 1, length (ape.name));
			ape.next = 0;		/* ... last abbreviation in this bucket */
			string (ape.flags) = ""b;
			ape.bol = bol;
			ape.value_lth = qbii.buffer_lth;
			ape.value = qbii_value;
			abbrev_profile.next_free = abbrev_profile.next_free + currentsize (ape);
			hash_slot = rank (substr (qbii.pathname, 1, 1));
			if abbrev_profile.hash_table (hash_slot) = 0 then
			     abbrev_profile.hash_table (hash_slot) = fixed (rel (ape_ptr), 18, 0);
			else do;			/* ... add to end of the chain */
			     do last_ape_ptr = pointer (ap_ptr, abbrev_profile.hash_table (hash_slot))
				repeat (pointer (ap_ptr, last_ape_ptr -> ape.next))
				while (last_ape_ptr -> ape.next ^= 0);
			     end;
			     last_ape_ptr -> ape.next = fixed (rel (ape_ptr), 18, 0);
			end;
		     end;

		     call compact_profile_if_needed ("1"b);

		     p_ok = "1"b;			/* success */
		end;

		else p_ok = "0"b;			/* ... illegal abbreviation name */
	     end;


	     else do;				/* will never get here, but ... */
		call com_err_ (error_table_$bad_subr_arg, qbii.editor_name, "Buffer operation type ^d.",
		     qbii.direction);
		p_ok = "0"b;
	     end;

	     return;

	end abbrev_io;

     end do_edit_request;
%page;
/* Turns the specified switch of one or more abbreviations on or off (internal to process_request_line begin block) */

do_switch_request:
     procedure (p_switch_value);

dcl  p_switch_value bit (1) aligned parameter;		/* new value for the switch */

dcl  (request_name, the_switch, abbrev_name) character (32);
dcl  switch_idx fixed binary;
dcl  (have_switch, first_abbrev) bit (1) aligned;

/* format: off */
dcl  SWITCH_NAMES (1, 2) character (32) static options (constant) initial (
	"beginning_of_line",	"bol");
/* format: on */

	if ^write_access () then do;
	     call com_err_ (error_table_$moderr, ABBREV, "Can not change abbreviation switches in profile ^a.",
		profile_pathname ());
	     go to RETURN_FROM_PROCESS_REQUEST_LINE;
	end;

	if p_switch_value then
	     request_name = "switch_on";
	else request_name = "switch_off";


/* Get the name of the switch */

	the_switch = get_token ();

	if the_switch = "" then do;
PRINT_SWITCH_REQUEST_USAGE:
	     call com_err_ (0, ABBREV, "Usage:  ^a^a switch_name abbrev_names", abbrev_state.escape_character,
		request_name);
	     go to RETURN_FROM_PROCESS_REQUEST_LINE;
	end;

	have_switch = "0"b;				/* let's lookup the name */
	switch_idx = 0;

	do while (^have_switch & (switch_idx < hbound (SWITCH_NAMES, 1)));
	     switch_idx = switch_idx + 1;		/* ... PL/I do loop would do an extra increment */
	     if (the_switch = SWITCH_NAMES (switch_idx, 1)) | (the_switch = SWITCH_NAMES (switch_idx, 2)) then
		have_switch = "1"b;			/* ... a good name */
	end;

	if ^have_switch then do;			/* foo */
	     call com_err_ (0, ABBREV, "Unrecognized switch name.  ""^a""", the_switch);
	     go to RETURN_FROM_PROCESS_REQUEST_LINE;
	end;


/* Now do it to the switch for the specified abbreviations */

	first_abbrev = "1"b;			/* for error message (later) */

	abbrev_name = "foo";			/* PL/I lacks do until */

	do while (abbrev_name ^= "");			/* while there are names left on the request line ... */
	     abbrev_name = get_token ();		/* next abbreviation please */

	     if abbrev_name ^= "" then do;
		first_abbrev = "0"b;		/* won't need a Usage message anymore */

		if validate_abbrev_name (abbrev_name) then do;
		     ape_ptr = lookup_abbrev (abbrev_name);

		     if ape_ptr ^= null () then do;
			go to SET_SWITCH (switch_idx);

SET_SWITCH (1):					/* beginning of line */
			ape.bol = p_switch_value;
			go to PROCEED_WITH_NEXT_ABBREVIATION;

PROCEED_WITH_NEXT_ABBREVIATION:
		     end;

		     else call com_err_ (0, ABBREV, """^a"" is not defined.", abbrev_name);
		end;
	     end;
	end;

	if first_abbrev then go to PRINT_SWITCH_REQUEST_USAGE;

	return;

     end do_switch_request;
%page;
/* Returns "1"b if the user has effective write access to the profile (internal to process_request_line begin block) */

write_access:
     procedure () returns (bit (1) aligned);

dcl  profile_mode fixed binary (5);

	call hcs_$fs_get_mode (ap_ptr, profile_mode, code);
	if code ^= 0 then do;
	     call com_err_ (code, ABBREV, "Can not determine access to profile ^a", profile_pathname ());
	     go to RETURN_FROM_PROCESS_REQUEST_LINE;
	end;

	return ((profile_mode = RW_ACCESS_BIN) | (profile_mode = REW_ACCESS_BIN));

     end write_access;



/* Validates that the given abbreviation name is legal */

validate_abbrev_name:
     procedure (p_abbrev_name) returns (bit (1) aligned);

dcl  p_abbrev_name character (32) parameter;		/* the candidate abbreviation name */
dcl  abbrev_name character (32) varying;
dcl  idx fixed binary;

	if length (rtrim (p_abbrev_name)) > length (ape.name) then do;
	     call com_err_ (0, ABBREV, "Maximum length of an abbreviation name is ^d characters. ""^a""",
		length (ape.name), p_abbrev_name);
	     return ("0"b);
	end;

	abbrev_name = rtrim (p_abbrev_name);		/* copy it to strip trailing whitespace */

	do idx = 1 to breaks_list.n_break_sequences;
	     begin;
dcl  break_sequence character (breaks_list.break_sequences (idx).lth) unaligned
	defined (breaks_list.break_strings) position (breaks_list.break_sequences (idx).start);
		if index (abbrev_name, break_sequence) ^= 0 then do;
		     call com_err_ (0, ABBREV, "Abbreviation names may not contain break sequences. ^a in ""^a""",
			break_sequence, abbrev_name);
		     return ("0"b);
		end;
	     end;
	end;

	return ("1"b);				/* it's OK */

     end validate_abbrev_name;
%page;
/* Skips to next non-white character in the request line (internal to process_request_line begin block) */

skip_whitespace:
     procedure ();

dcl  idx fixed binary (21);

	idx = verify (substr (request_line, (used + 1)), WHITE_SPACE_AND_NL);

	if idx = 0 then				/* rest of the line is whitespace */
	     used = length (request_line);
	else used = used + idx - 1;			/* found something */

	return;

     end skip_whitespace;



/* Returns the next token in the request line; tokens are delimited by whitespace (internal to process_request_line begin
   block) */

get_token:
     procedure () returns (character (32));

dcl  (token_start, token_lth, idx) fixed binary (21);

	call skip_whitespace ();			/* skip any leading whitespace */

	if used = length (request_line) then		/* nothing left ... */
	     return ("");

	idx = search (substr (request_line, (used + 1)), WHITE_SPACE);
	if idx = 0 then				/* rest of the line is the token */
	     idx = length (request_line) - used + 1;

	token_start = used + 1;
	token_lth = idx - 1;

	used = used + token_lth;			/* update amount we've looked at */

	return (substr (request_line, token_start, token_lth));

     end get_token;
%page;
/* Sets ap_ptr to locate the proper profile to be used for expansion in this case (internal to process_request_line begin
   block): initializes the profile if necessary; two versions of this procedure exist to insure that the one used during
   command/request line expansion is quick */

set_profile_ptr:
     procedure (p_dont_create_profile) /* options (quick) */;

dcl  p_dont_create_profile bit (1) aligned;

	ap_ptr = null ();				/* start somewhere */

	if subsystem_entry then			/* subsystems use arbitrary profiles */
	     if (P_default_profile_ptr = null ()) & (P_profile_ptr = null ()) then
						/* ... use same profile as Multics command level */
		if abbrev_state.profile_ptr = null () then
		     call get_default_profile (p_dont_create_profile);
						/* ... need not succeed if called at expanded_line entry */
		else ap_ptr = abbrev_state.profile_ptr;

	     else do;				/* subsystem supplied the profile */
		if P_profile_ptr ^= null () then
		     ap_ptr = P_profile_ptr;
		else ap_ptr = P_default_profile_ptr;
		call initialize_profile ("1"b, "0"b);	/* ... make sure it's good */
	     end;

	else do;					/* command level invocation */
	     if abbrev_state.profile_ptr = null () then
		call get_default_profile (p_dont_create_profile);
						/* ... need not succeed if called at expanded_line entry */
	     else ap_ptr = abbrev_state.profile_ptr;
	end;

	return;

     end set_profile_ptr;



/* Searches the profile for an abbreviation (internal to process_request_line begin block): two versions of this procedure
   exist to insure that the one used by the expand_line procedure is quick */

lookup_abbrev:
     procedure (p_name) returns (pointer) /* options (quick) */;

dcl  p_name character (32) parameter;
dcl  offset fixed binary (18);

	do offset = abbrev_profile.hash_table (rank (substr (p_name, 1, 1))) repeat (ape.next) while (offset ^= 0);
	     ape_ptr = pointer (ap_ptr, offset);
	     if ape.name = p_name then return (ape_ptr);
	end;

	return (null ());				/* here iff not found */

     end lookup_abbrev;
%page;
/* Validates that the remainder of the request line is blank and prints an error if it isn't (internal to
   process_request_line begin block) */

validate_no_arguments:
     procedure (p_request_name);

dcl  p_request_name character (*) parameter;

	call skip_whitespace ();

	if used ^= length (request_line) then do;
	     call com_err_ (0, ABBREV, "The ""^a^a"" request does not accept arguments.", abbrev_state.escape_character,
		p_request_name);
	     go to RETURN_FROM_PROCESS_REQUEST_LINE;
	end;

	return;

     end validate_no_arguments;



/* Compact the profile if needed (internal to process_request_line begin block) */

compact_profile_if_needed:
     procedure (p_set_bit_count);

dcl  p_set_bit_count bit (1) aligned parameter;

	if (((4 * abbrev_profile.garbage) > abbrev_profile.next_free) | (abbrev_profile.garbage > 512))
	     & (abbrev_profile.garbage > mod (abbrev_profile.next_free, 1024)) then
	     call compact_profile ();			/* compact at 25% or half page wasted but only if the
						   compaction will make it shorter */

	else if p_set_bit_count then			/* caller added something to the end: be sure bit count OK */
	     call terminate_file_ (ap_ptr, (36 * abbrev_profile.next_free), TERM_FILE_BC, (0));

	return;

     end compact_profile_if_needed;
%page;
do_help_request:
     proc ();					/* The ? (help) request */

dcl  (element, ndx) fixed binary;

	call skip_whitespace ();

	if used = length (request_line) then do;	/* No requests, do all */
	     call ioa_ ("Abbrev requests:");
	     do element = 1 to hbound (abbrev_rqd, 1);
		call display_help_line (abbrev_rqd (element));
	     end;
	end;

	else do token = get_token () repeat (get_token ()) while (token ^= "");
						/* request(s) */
	     do element = 1 to hbound (ard, 1);
		if ard (element) = rtrim (token) then go to found_request;
	     end;
	     call com_err_ (0, ABBREV, """^a"" is not a legal abbrev request.", token);
	     go to end_request_lookup;
found_request:
	     element = ardx (element);
	     do ndx = 0 to 2;
		call display_help_line (abbrev_rqd (element + ndx));
	     end;
end_request_lookup:
	end;

	return;

display_help_line:
	proc (display_line);

dcl  display_line char (*) parameter;

	     if display_line ^= "" then call ioa_ ("^a", display_line);

	     return;

	end display_help_line;

     end do_help_request;

	end;

RETURN_FROM_PROCESS_REQUEST_LINE:
	return;
%page;
%include qedx_info;
%page;
%include qedx_buffer_io_info;

     end process_request_line;
%page;
/* Garbage collect a profile */

compact_profile:
     procedure () options (non_quick);

dcl  1 new_profile aligned based (new_profile_ptr) like abbrev_profile;
dcl  new_profile_ptr pointer;

dcl  new_profile_words (new_profile.next_free) bit (36) aligned based (new_profile_ptr);

dcl  1 new_ape aligned based (new_ape_ptr),
       2 header like ape.header,
       2 value character (0 refer (new_ape.value_lth));
dcl  new_ape_ptr pointer;

dcl  1 old_profile aligned based (old_profile_ptr) like abbrev_profile;
dcl  1 old_old_profile aligned based (old_profile_ptr),	/* prior version */
       2 next_free fixed binary (18),
       2 pad (3) bit (36),
       2 hash_table (4:127) fixed binary (18);
dcl  old_profile_ptr pointer;

dcl  1 old_ape aligned based (old_ape_ptr),
       2 header like ape.header,
       2 value character (0 refer (old_ape.value_lth));
dcl  old_ape_ptr pointer;

dcl  old_style_profile bit (1) aligned;
dcl  old_profile_mode fixed binary (5);
dcl  (hash_slot, lower_hash_bound) fixed binary;
dcl  (first_offset, old_offset) fixed binary (18);
dcl  last_new_ape_ptr pointer;


	old_profile_ptr = ap_ptr;
	old_style_profile = (old_profile.version > 127);

	call hcs_$fs_get_mode (old_profile_ptr, old_profile_mode, code);
	if code ^= 0 then
	     call abort_abbrev_processor (code, "Can not determine access to profile ^a", profile_pathname ());

	if (old_profile_mode ^= RW_ACCESS_BIN) & (old_profile_mode ^= REW_ACCESS_BIN) then
	     if old_style_profile then		/* can't upgrade an old profile: can't use it */
		call abort_abbrev_processor (error_table_$moderr, "Can not upgrade profile ^a to current version.",
		     profile_pathname ());
	     else return;				/* can't garbage collect it: doesn't matter */

	call get_temp_segment_ (ABBREV, new_profile_ptr, code);
	if code ^= 0 then return;

	on condition (cleanup)
	     begin;
	     if new_profile_ptr ^= null () then call release_temp_segment_ (ABBREV, new_profile_ptr, code);
	end;

	new_profile.version = ABBREV_PROFILE_VERSION_1;
	new_profile.next_free = fixed (rel (addr (new_profile.data_space)), 18, 0);

	if old_style_profile then			/* get right lower bound; upper bounds are the same */
	     lower_hash_bound = lbound (old_old_profile.hash_table, 1);
	else lower_hash_bound = lbound (old_profile.hash_table, 1);

	do hash_slot = lower_hash_bound to hbound (new_profile.hash_table, 1);
	     last_new_ape_ptr = null ();
	     if old_style_profile then		/* get starting offset */
		first_offset = old_old_profile.hash_table (hash_slot);
	     else first_offset = old_profile.hash_table (hash_slot);
	     do old_offset = first_offset repeat (old_ape.next) while (old_offset ^= 0);
		old_ape_ptr = pointer (old_profile_ptr, old_offset);
		if old_ape.name ^= "" then do;	/* copy only if not deleted */
		     new_ape_ptr = pointer (new_profile_ptr, new_profile.next_free);
		     new_ape.header = old_ape.header;	/* makes refer extents work */
		     new_ape.next = 0;		/* but no forward thread yet */
		     new_ape.value = old_ape.value;
		     new_profile.next_free = new_profile.next_free + currentsize (new_ape);
		     if last_new_ape_ptr = null () then /* first entry in this hash slot */
			new_profile.hash_table (hash_slot) = fixed (rel (new_ape_ptr), 18, 0);
		     else last_new_ape_ptr -> new_ape.next = fixed (rel (new_ape_ptr), 18, 0);
		     last_new_ape_ptr = new_ape_ptr;
		end;
	     end;
	end;

	old_profile_ptr -> new_profile_words = new_profile_ptr -> new_profile_words;
						/* put the new one in place */
	call terminate_file_ (old_profile_ptr, (36 * new_profile.next_free), TERM_FILE_TRUNC_BC, (0));

	call release_temp_segment_ (ABBREV, new_profile_ptr, (0));

	return;

     end compact_profile;
%page;
%include "_abbrev_profile";
%page;
%include access_mode_values;

%include terminate_file;

     end abbrev;




		    abbrev_data_.cds                03/20/87  1234.3rew 03/20/87  1233.3       34695



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

/* format: off */

/* Constant data used by the Multics abbrevation processor */

/* Created:  March 1983 by G. Palter */

/* HISTORY COMMENTS:
  1) change(86-06-20,Gilcrease), approve(86-06-25,MCR7409),
     audit(86-07-29,GWMay), install(86-08-04,MR12.0-1112):
     For hcom...
     Modified: June 1984 by G. Palter to add version string
  2) change(86-06-20,Gilcrease), approve(86-06-25,MCR7409),
     audit(86-07-29,GWMay), install(86-08-04,MR12.0-1112):
               Install version 3.1a abbrev, change version constant.
  3) change(86-07-24,Gilcrease), approve(86-06-25,MCR7409),
     audit(86-07-29,GWMay), install(86-08-04,MR12.0-1112):
               Update version constnat for find_chars_ rather than tct_,
               by Margolin emergency fix.
  4) change(86-10-10,Gilcrease), approve(87-02-27,MCR7626),
     audit(87-03-09,Parisek), install(87-03-20,MR12.1-1005):
               Add version 2 list requests.
                                                   END HISTORY COMMENTS */


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


abbrev_data_:
     procedure () options (variable);


dcl  1 abbrev_data aligned,
       2 version character (32) unaligned,
       2 default_breaks_list aligned like DEFAULT_BREAKS_LIST,
       2 default_breaks_tct_table character (512) unaligned;

dcl  abbrev_data_default_breaks_tct_table_as_binary (0:511) fixed binary (9) unaligned unsigned
	based (addr (abbrev_data.default_breaks_tct_table));

dcl  DEFAULT_BREAKS character (21) static options (constant) initial ("	
 ""$'().:;<>[]`{|}");				/* HT NL VT FF SP QUOTE, etc: must be in collating sequence */

dcl  1 DEFAULT_BREAKS_LIST aligned static options (constant),
       2 n_break_sequences fixed binary initial (21),
       2 break_strings_lth fixed binary initial (22),
       2 break_sequences (21),
         3 start fixed binary initial (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 14, 15, 16, 17, 18, 19, 20, 21, 22),
         3 lth fixed binary initial (1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1),
       2 break_strings character (22) unaligned initial ("	
 ""$'().::;<>[]`{|}");

dcl  1 cds_data aligned like cds_args;

dcl  code fixed binary (35);
dcl  idx fixed binary;

dcl  ABBREV_DATA_ character (32) static options (constant) initial ("abbrev_data_");

dcl  com_err_ entry () options (variable);
dcl  create_data_segment_ entry (pointer, fixed binary (35));

dcl  (addr, currentsize, length, low, null, rank, string, substr) builtin;
%page;
/* Fill in the data structure */

	abbrev_data.version = "3.2";

	abbrev_data.default_breaks_list = DEFAULT_BREAKS_LIST;

	abbrev_data.default_breaks_tct_table = low (length (abbrev_data.default_breaks_tct_table));

	do idx = 1 to length (DEFAULT_BREAKS);		/* exactly one sequence starting with each character */
	     abbrev_data_default_breaks_tct_table_as_binary (rank (substr (DEFAULT_BREAKS, idx, 1))) = idx;
	end;


/* Set up arguments for call to create_data_segment_ */

	cds_data.sections (1).p = addr (abbrev_data);
	cds_data.sections (1).len = currentsize (abbrev_data);
	cds_data.sections (1).struct_name = "abbrev_data";

	cds_data.seg_name = ABBREV_DATA_;

	cds_data.num_exclude_names = 0;
	cds_data.exclude_array_ptr = null ();

	string (cds_data.switches) = ""b;
	cds_data.switches.have_text = "1"b;		/* only constants */


/* Call create_data_segment_ */

	call create_data_segment_ (addr (cds_data), code);

	if code ^= 0 then call com_err_ (code, ABBREV_DATA_);

	return;
%page;
%include cds_args;

     end abbrev_data_;




		    get_to_cl_.pl1                  01/16/85  1240.7r w 01/16/85  1239.3       45567



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


/* format: style2 */
get_to_cl_:
     procedure (flags);

/* Procedure invoked before calls to the command listener.
   Called by standard system default error handler when
   a quit occurs.
*/

/* Completely re-written 1 December 1980 Richard Mark Soley */
/* Changed to move_attach architecture 3 December 1980 RMSoley */
/* munged for new iox BIM June 1981 */
/* Modified 1984-10-26 BIM to not do control orders under the ips mask. */

/* System Entries */
	dcl     unique_chars_	 entry (bit (*)) returns (character (15));
	dcl     listen_$release_stack	 entry (bit (1) aligned);
	dcl     iox_$init_standard_iocbs
				 entry;
	dcl     (
	        hcs_$set_ips_mask,
	        hcs_$reset_ips_mask
	        )			 entry (bit (36) aligned, bit (36) aligned);
	dcl     terminate_process_	 entry (character (*), pointer);
	dcl     continue_to_signal_	 entry (fixed bin (35));
	dcl     error_table_$unable_to_do_io
				 fixed bin (35) external static;

/* Conditions */
	dcl     cleanup		 condition;
	dcl     any_other		 condition;

/* Builtin */
	dcl     null		 builtin;

/* Automatic */

	dcl     1 info		 aligned automatic,
		2 iocb_ptrs	 (3) pointer,
		2 modes		 character (512) unaligned;

	dcl     ips_mask		 bit (36) aligned;
	dcl     switch		 character (32);
	dcl     code		 fixed bin (35);
	dcl     i			 fixed bin;
	dcl     temp		 pointer;
	dcl     1 flags		 aligned,
		2 reset_sw	 bit (1) unaligned,
		2 pad		 bit (35) unaligned;
	dcl     restore_attachments	 bit (1) aligned initial ("1"b);

/* Include Files */
%include iox_entries;

unclaimed_signal:
quit:
     entry (flags);

/* Throw away type-ahead if wanted. */

	if flags.reset_sw
	then call iox_$control (iox_$user_input, "resetread", null (), code);

/* Save attachments. */

	call save_io;

/* Set up cleanup handler. */

	on cleanup call free_save_iocbs ();

/* Now we can call the actual listener. */

	call listen_$release_stack (restore_attachments);

/* Control returns here on "start" command.  First we
	   avoid lost wakeups, then restore
	   attachments if listen_ wants. */

	call iox_$control (iox_$user_io, "start", null (), code);
	if restore_attachments
	then call restore_io ();
	else call free_save_iocbs ();			/* Return to whatever we're "start"ing. */

	return;

save_io:
     procedure ();

/* Procedure to push the current switch attachments on the
   attachment stack */


	ips_mask = ""b;

	on any_other call fault_while_masked;

	info.modes = "";
	call iox_$modes (iox_$user_io, "default", info.modes, (0));

	call hcs_$set_ips_mask (""b, ips_mask);

	/*** This code should be upgraded to save whatever
	   it finds in the iox_ iocb info for standard attachments.
	   for now, saving the usual 3 will do */

/* Save current attachments. */

	i = 0;
	do temp = iox_$user_input, iox_$user_output, iox_$error_output;

	     i = i + 1;
	     switch = "cl_save_" || unique_chars_ (""b);

	     call iox_$find_iocb (switch, info.iocb_ptrs (i), code);

	     call iox_$move_attach (temp, info.iocb_ptrs (i), code);
	end;

/* Restore default attachments. */

	call iox_$init_standard_iocbs;

/* Turn on printer. */

	call hcs_$reset_ips_mask (ips_mask, ""b);
	revert any_other;

	call iox_$control (iox_$user_io, "printer_on", null (), code);
     end save_io;

restore_io:
     procedure ();

/* Procedure to re-instate old saved attachments. */

	ips_mask = ""b;
	on any_other call fault_while_masked;

	if info.modes ^= ""
	then call iox_$modes (iox_$user_io, info.modes, (""), (0));

	call hcs_$set_ips_mask (""b, ips_mask);

	i = 0;
	do temp = iox_$user_input, iox_$user_output, iox_$error_output;
	     i = i + 1;

	     call iox_$close (temp, code);		/* will normally fail */

	     call iox_$detach_iocb (temp, code);

	     call iox_$move_attach (info.iocb_ptrs (i), temp, code);

	     call iox_$destroy_iocb (info.iocb_ptrs (i), code);

	end;

	call hcs_$reset_ips_mask (ips_mask, ""b);
	revert any_other;

     end restore_io;

free_save_iocbs:
     procedure;


/* This is called in the -no_restore case */


	do i = 1 to 3;
	     call iox_$detach_iocb (info.iocb_ptrs (i), (0));
	     call iox_$destroy_iocb (info.iocb_ptrs (i), (0));
	end;

     end free_save_iocbs;



fault_while_masked:
     procedure;

	dcl     1 ti		 aligned,
		2 version		 fixed bin,
		2 status_code	 fixed bin (35);

	if substr (ips_mask, 36, 1) = "0"b
	then call continue_to_signal_ (0);
	else do;
		ti.version = 0;
		ti.status_code = error_table_$unable_to_do_io;
		call terminate_process_ ("fatal_error", addr (ti));
	     end;
     end fault_while_masked;
     end get_to_cl_;




		    listen_.pl1                     11/06/86  0757.5r w 11/04/86  1033.9       93429



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


/* format: style2 */
listen_:
     procedure (initial_command_line);

/* Multics Listener */
/* initially coded in June 1969 by R. Daley */
/* converted to pl1 and improved for new command loop in December 1969 by R. Daley */
/* changed to reject input lines that are too long by V. Voydock in April 1970 */
/* changed to truncate the stack  on every release
   on August 12,1970 by V. Voydock */
/* Changed to execute a start up exec_com and print the message of the
   day on September 4,1970 by R. J. Feiertag */
/* Extensively modified as part of redesign of user ring process initialization
   by V. Voydock on October 27,1970 */
/* Modified in June 1971 by V. Voydock to call cu_$ready_proc, to add "rl -all",
   to use "system_free_" instead of "free_", to not blow up if
   release_stack entry is somehow invoked before listen_ entry, and to make
   the listen_ entry behave the same way every time it is called in a process */
/* Modified in July 1971 by V. Voydock to make start command have control argument
   which causes it not to restore the old io attachments */
/* Modified in September 1971 by V. Voydock to not truncate free storage area after a release */
/* Modified in February 1972 by V. Voydock to accept an arbitrarily long command line as input */
/* Extensively modified in May 1972 by V. Voydock as part of fast command loop. Many pieces
   of listen_ were moved to other procedures */
/* Modified in September 1973 by M. Weaver to add level numbers, eliminate
   the automatic release, and to make start and release work directly
   with labels. */
/* Modified in December 1974 by S. Webber to redo the buffering of the input
   line. */
/* Opened in November 1981 for video system support by Benson I. Margulies */
/* Modified February 1984 by Jim Lippard to fix bug in call to iox_signal_ */
/* Changed to use listener_info.incl.pl1 12/07/84 Steve Herbst */
%page;
/* DECLARATIONS */

	dcl     (
	        buffer_ptr,				/* ptr to first char of workspace used by iox_$get_line */
	        read_ptr		 ptr,		/* pointer to actual position in input buffer for read */
	        dummy_ptr		 ptr,		/* dummy return pointer from cu_$grow_stack_frame calls */
	        old_sp
	        )			 pointer aligned;

	dcl     (input_length, buffer_length)
				 fixed bin (21);
	dcl     total_input_length	 fixed bin (21);
	dcl     entry,				/* 0->$listen_, 1->$release_stack */
	        i			 fixed bin aligned;
	dcl     code		 fixed bin (35);

	dcl     initial_command_line	 char (*) var,	/* first command line to be executed */
	        command_line	 char (input_length) aligned based (buffer_ptr);

	dcl     spno		 bit (18) aligned,	/* used to store stack segno */
	        should_restore_attachments
				 bit (1) aligned;

	dcl     1 x		 based (buffer_ptr) aligned,
		2 ch		 (0:65536) char (1) unaligned;


	dcl     1 listener_control	 aligned like based_listener_control;


	dcl     iox_signal_		 entry (ptr, fixed bin (35));
	dcl     com_err_		 entry options (variable);
	dcl     cu_$cp		 ext entry (ptr, fixed bin (21), fixed bin (35));
	dcl     cu_$ready_proc	 ext entry ();
	dcl     cu_$grow_stack_frame	 entry (fixed bin (21), ptr, fixed bin (35));
	dcl     get_system_free_area_	 entry returns (ptr);

	dcl     (addr, baseno, codeptr, divide, environmentptr, fixed, length, min, null, ptr, rel, stackframeptr,
	        stackbaseptr)	 builtin;
	dcl     cleanup		 condition;
	dcl     error_table_$long_record
				 ext static fixed bin (35);
%page;
/* Establish this frame as the "top" of the listener frame thread, so this
   frame cannot be "released" around. */

	entry = 0;
	go to re_enter;

/* Entry called after processing quit or unclaimed signal: */

release_stack:
     entry (should_restore_attachments);

	entry = 1;

/* Save pointer to previous listener control information, save return point
   for subsequent invocations of the listener, and initialize switches */

re_enter:
	if listen_static_data_.first_level_sw
	then do;					/* no previous invocation to work from */
		listener_control.prev_ptr = null;
		listener_control.level = 1;		/* this is first invocation */
		sp = stackframeptr ();
		spno = baseno (sp);			/* get segno for comparing */
		i = 0;
		do while (baseno (sp -> stack_frame.prev_sp) = spno & sp ^= null);
		     i = i + 1;
		     sp = sp -> stack_frame.prev_sp;
		end;
		listener_control.frame = i;
	     end;
	else do;					/* can use info from previous invocation */
		listener_control.prev_ptr = listen_static_data_.control_ptr;
		listener_control.level = listen_static_data_.control_ptr -> based_listener_control.level + 1;
		old_sp = environmentptr (listen_static_data_.control_ptr -> based_listener_control.start);
		sp = stackframeptr ();
		i = listen_static_data_.control_ptr -> based_listener_control.frame;
		do while (sp ^= old_sp & sp ^= null);	/* find # of intervening frames */
		     i = i + 1;
		     sp = sp -> stack_frame.prev_sp;	/* back ptr is safer to use */
		end;
		listener_control.frame = i;
	     end;

/* fill in labels for release and start */
	if (entry = 0) | listen_static_data_.first_level_sw
	then do;
		listener_control.release_all, listener_control.release, listener_control.new_release = READY_LABEL;
		listen_static_data_.first_level_sw = "0"b;
	     end;
	else do;					/* will want to release to invocation before this one */
		listener_control.release = listen_static_data_.control_ptr -> based_listener_control.new_release;
		listener_control.new_release = READY_LABEL;
		listener_control.release_all = listen_static_data_.control_ptr -> based_listener_control.release_all;
	     end;
	listener_control.start = START_LABEL;

	listen_static_data_.control_ptr = addr (listener_control);	/* have finished getting info from old frame */

	listener_control.flags.dont_restore_sw = "0"b;

/* set ptrs to current control info and to buffer in which to read in command line */
	buffer_length = 32;				/* start with 128 char input buffer */
	call cu_$grow_stack_frame (buffer_length, buffer_ptr, code);
						/* get storage for initial buffer */

/* Establish cleanup procedure to restore control structure thread */
	on condition (cleanup)
	     begin;
		listen_static_data_.control_ptr =
		     listen_static_data_.control_ptr -> based_listener_control.prev_ptr;  /* pop level */
		if listen_static_data_.control_ptr = null
		then listen_static_data_.first_level_sw = "1"b;			/* used mainly in test case */
	     end;

/* If called at the listen_ entry, set up initial command line. */
	if entry = 0
	then do;
		if initial_command_line ^= ""
		then do;
			if length (initial_command_line) > buffer_length * 4
			then do;
				call com_err_ (0, "listen_", "Initial command line is too long. Max=^d chars.",
				     buffer_length * 4);
				go to READY_LABEL;
			     end;
			input_length = length (initial_command_line);
			command_line = initial_command_line;
			total_input_length = 0;
			go to CALL_CP;
		     end;
	     end;
%page;
/* ******************************START OF BASIC LISTENER LOOP ****************************** */

/* Call the "ready procedure".  The standard one prints the ready message. */
/* In case of video system, restore output. */

READY_LABEL:
	call iox_$control (iox_$user_input, "reset_more", null (), (0));
	call cu_$ready_proc ();

/* Read the next command line */
readnew:
	read_ptr = buffer_ptr;
	total_input_length = 0;			/* extra input line character count */
read:
	call iox_$get_line (iox_$user_input, read_ptr, buffer_length * 4 - total_input_length, input_length, code);
	if code ^= 0
	then do;
		if code ^= error_table_$long_record
		then call iox_signal_ (iox_$user_input, code);
		else do;
			if input_length < buffer_length * 4 - total_input_length
			then goto CALL_CP;
			call cu_$grow_stack_frame (buffer_length, dummy_ptr, code);
						/* double size of buffer */
			buffer_length = buffer_length + buffer_length;
			read_ptr = addr (read_ptr -> ch (input_length));
			total_input_length = total_input_length + input_length;
		     end;
		goto read;
	     end;

CALL_CP:
	call cu_$cp (buffer_ptr, total_input_length + input_length, code);
	if code = 100
	then go to readnew;				/* ignore null command line */
	go to READY_LABEL;

/* ****************************** END OF BASIC LISTENER LOOP ****************************** */
%page;
START_LABEL:					/* start command goes here */
	if listener_control.flags.dont_restore_sw
	then should_restore_attachments = "0"b;
	listen_static_data_.control_ptr = listen_static_data_.control_ptr -> based_listener_control.prev_ptr;
	return;
%page;
get_pct:
     entry (P_listener_control_ptr);

	dcl     P_listener_control_ptr		 ptr;

/* Return pointer to control structure */
	P_listener_control_ptr = listen_static_data_.control_ptr;
	return;
%page;
get_level:
     entry (level_no, frame_no);

/* return command level number and stack frame number of caller's caller */

	dcl     (level_no, frame_no)	 fixed bin;

	if listen_static_data_.control_ptr = null
	then do;					/* no previous invocation */
		level_no = 0;
		old_sp = stackbaseptr () -> stack_header.stack_begin_ptr;
						/* in case we're not in highest ring */
		frame_no = 0;
	     end;
	else do;					/* count only up to previous listener */
		level_no = listen_static_data_.control_ptr -> based_listener_control.level;
		old_sp = environmentptr (listen_static_data_.control_ptr -> based_listener_control.start);
		frame_no = listen_static_data_.control_ptr -> based_listener_control.frame;
	     end;

	sp = stackframeptr () -> stack_frame.prev_sp -> stack_frame.prev_sp;
						/* want frame no of caller's caller */
	do while (sp ^= old_sp);
	     frame_no = frame_no + 1;
	     sp = sp -> stack_frame.prev_sp;
	end;
	return;
%page;
get_area:
     entry returns (ptr);

	return (get_system_free_area_ ());
%page;
%include iox_entries;
%page;
%include listener_info;
%page;
%include stack_frame;
%page;
%include stack_header;


end listen_;




		    print_ready_message_.pl1        11/04/82  2004.3rew 11/04/82  1610.1       34254



/* ***********************************************************
   *                                                         *
   * 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 */
print_ready_message_:
     procedure (flags) options (separate_static);

/* The print_ready_message_ procedure is the standard system "ready procedure".
   It prints the ready message and then returns */

/* Initially coded as an internal procedure of the listener by R. C. Daley in December 1969 */
/* Converted to an external procedure as part of the introduction of cu_$ready_proc by
   V. L. Voydock in June 1971 */
/* Modified for 6180 to display virtual cpu, memory units, and demand paging by J. Keller, 4/11/73 */
/* Modified to print command level and frame numbers by M. Weaver  9/73 */
/* Steve Herbst 06/25/79 changed msg to: r hh:mm .vcpu dpages {level n} */
/* Modified April 1980 by C. Hornig for per-process time zones */

dcl  rdy_string varying char (48) aligned;
dcl  out_string char (48) aligned;

dcl  1 time_picture unaligned,
       2 r char (2),
       2 hours picture "99",
       2 colon char (1),
       2 minutes picture "99",
       2 sp char (1);
dcl  vcpu picture "(5)-9v.999";
dcl  dpages picture "(8)z9";
dcl  level picture "(2)z9";
dcl  NLNL char (2) int static options (constant) init ("

");

dcl  1 flags aligned,
       2 ready_sw bit (1) unaligned,
       2 pad bit (35) unaligned;

dcl  (hour, minute) fixed bin;
dcl  cpu fixed bin (71);
dcl  (ec, npages) fixed bin (35);
dcl  (frame_no, level_no) fixed bin;

dcl  iox_$user_output ptr ext;

dcl  (addr, addrel, clock, length, ltrim, string) builtin;

dcl  decode_clock_value_$time
	entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin (71), char (3), fixed bin (35));
dcl  hcs_$get_process_usage entry (ptr, fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  listen_$get_level entry (fixed bin, fixed bin);

dcl  1 data internal static,
       2 wanted fixed bin initial (5),
       2 can_get fixed bin,
       2 cpu_usage fixed bin (71) init (0),
       2 memory fixed bin (71) init (0),
       2 demand_page fixed bin (35) init (0),
       2 pre_page fixed bin (35) init (0),
       2 virtual_cpu fixed bin (71) init (0);

/**/
/* If ready messages are turned off, just return */

	if ^flags.ready_sw then return;

	call decode_clock_value_$time (clock (), hour, minute, (0), (0), (""), ec);
	string (time_picture) = "r 00:00 ";
	time_picture.hours = hour;
	time_picture.minutes = minute;

	cpu = data.virtual_cpu;			/* pick up virtual time, mem units, and paging */
	npages = data.demand_page;
	call hcs_$get_process_usage (addr (data), ec);
	vcpu = (data.virtual_cpu - cpu) * 1e-6;		/* virtual cpu in seconds */
	dpages = data.demand_page - npages;		/* pages demand paged since last ready */
	call listen_$get_level (level_no, frame_no);	/* find command level */

	rdy_string = string (time_picture);
	rdy_string = rdy_string || ltrim (vcpu);
	rdy_string = rdy_string || " ";
	rdy_string = rdy_string || ltrim (dpages);
	if level_no > 1 then do;
	     rdy_string = rdy_string || " level ";
	     level = level_no;
	     rdy_string = rdy_string || ltrim (level);
	     end;
	rdy_string = rdy_string || NLNL;
	substr (out_string, 1, length (rdy_string)) = rdy_string;

	call iox_$put_chars (iox_$user_output, addr (out_string), length (rdy_string), ec);

	return;

     end print_ready_message_;




		    release.pl1                     12/20/84  0852.4rew 12/20/84  0833.0       30060



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


release: rl:	proc;

/* This procedure implements the start and release commands. It exists so that
   the code involved does not have to be in the main body of listen_ */

/* Initially coded in May 1972 by V. Voydock as part of the fast command loop */
/* Fixed to reject extra arguments 06/30/82 S. Herbst */
/* Changed to use listener_info.incl.pl1 12/11/84 Steve Herbst */


dcl	ioa_ ext entry options(variable);

dcl	temp_ptr ptr;

dcl	arg_count fixed bin;
dcl	arg_length fixed bin (21);
dcl	(code,
	 error_table_$badopt external
					) fixed bin(35);

dcl	argument char(arg_length) based(temp_ptr);

dcl	cu_$arg_count entry (fixed bin);
dcl	cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl	(com_err_, com_err_$suppress_name) ext entry options(variable);

dcl	(null, substr) builtin;
%page;
/* If there is no frame to release to, print message and return. */
/*
	if listen_static_data_.control_ptr -> based_listener_control.prev_ptr=null() then do;
	     call ioa_("""release"" ignored.");
	     return;
	end;
*/

/* See if we are to release to "top". That is "rl -all" was typed */

	call cu_$arg_count (arg_count);
	if arg_count > 1 then do;
RL_USAGE:	     call com_err_$suppress_name (0, "release", "Usage:  release {-control_arg}");
	     return;
	end;

	call cu_$arg_ptr(1,temp_ptr,arg_length,code);
	if code=0 then
	     if (argument = "-all") | (argument = "-a") then
		go to listen_static_data_.control_ptr -> based_listener_control.release_all;
	     else if substr (argument, 1, 1) = "-" then do;
		call com_err_ (error_table_$badopt, "release", argument);
		return;
	     end;
	     else go to RL_USAGE;

/* Set the release switch */

	go to listen_static_data_.control_ptr -> based_listener_control.release;
%page;
start: sr: entry;

/* If there is no frame to "start" to, print message and return */

	if listen_static_data_.control_ptr -> based_listener_control.release =
	     listen_static_data_.control_ptr -> based_listener_control.new_release then do;
	     call ioa_("""start"" ignored.");
	     return;
	end;

/* See if we are to not restore io attachments (that is, "start -no_restore" was typed) */

	call cu_$arg_count (arg_count);
	if arg_count > 1 then do;
SR_USAGE:	     call com_err_$suppress_name (0, "start", "Usage:  start {-control_arg}");
	     return;
	end;

	call cu_$arg_ptr(1,temp_ptr,arg_length,code);
	if code=0 then
	     if (argument="-no_restore") | (argument="-nr") then
		listen_static_data_.control_ptr -> based_listener_control.dont_restore_sw = "1"b;
	     else if substr (argument, 1, 1) = "-" then do;
		call com_err_ (error_table_$badopt, "start", argument);
		return;
	     end;
	     else go to SR_USAGE;

/* Set the start switch */

	go to listen_static_data_.control_ptr -> based_listener_control.start;
%page;
%include listener_info;


end release;




		    tty_.pl1                        10/17/90  0820.5rew 10/17/90  0815.7      352998



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1990   *
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */

/* the user ring tty io module --- tty_ */

/* format: style2 */
tty_:
     procedure;
	return;

/*  iox_ dim for terminal i/o written 1/75 by S.E. Barr */
/*  Modified 9/26/75 by S.E. Barr to ensure buffer pointer is word aligned for calls to hardcore. */
/* Modified 760608 by PG to get tty_get_line to work when in raw input mode */
/* Modified 5/31/77 by J. Stern to add set_term_type and send_initial_string orders */
/* Modified 5/4/78 by Robert Coren to call hcs_$tty_get_line and to return whatever's there for get_chars */
/* Modified July 1979 by Larry Johnson to automatically attempt to attach to a
   new channel if the user's login channel hangs up. Part of process
   preservation across hangup project. */
/* Modified by C. Hornig for dial_manager_ intelligence */
/* Modified November 1980 by B. Margulies for user event channels and no block */
/* Modified: 12 November 1980 by G. Palter to implement MCS suggestion #65 -- truncate modes string at nearest whole mode
	      if it doesn't fit into the caller's string */
/* Modified December 1980 by B. Margulies for new preservation and general cleanup */
/* Further Modified January 1, 1981 to split tty_ and tty_io_ to reduce gravidity of this program */
/* Modified October 1981 by C. Hornig to allow -dial_id. */
/* Modified March 1982 by C. Hornig to fix hangup_on_detach */
/* Modified August 1982 by E. N. Kittlitz to initialize mask in set_up */
/* Modified April 1983 by Robert Coren to handle -required_access_class */
/* Modified September 1983 by Robert Coren to fix bug that ignored -required_access_class "" */
/* Modified 1984-10-29 BIM to only call dial_manager_ if ring 0 admits that
	  the channel is plausible. */
/* Modified December 1984 by Robert Coren to disable line status for login channel. */
/* Modified January 1985 by G. Palter to establish a handler for signals from the answering service */
/* Modified: 7 February 1985 by G. Palter to not attempt to release the channel if convert_dial_message_$return_io_module
      reports an error during the attachment */
/* Modified: 19 February 1985 by G. Palter to not try to dial_manager_ release the channel if hcs_$tty_detach fails */
/* Modified: 26 February 1985 by G. Palter to always delete the dial_manager_ IPC channel */
/* Modified: 8 March 1985 by G. Palter to make the close entrypoint not zero event_wait.channel_id(1).  See the comment in
      the code for an explanation */


/****^  HISTORY COMMENTS:
  1) change(85-06-23,Negaret), approve(87-07-23,MCR7742),
     audit(87-07-23,GDixon), install(87-08-04,MR12.1-1055):
     Handle DSA network connections.
  2) change(90-09-20,Bubric), approve(90-10-01,MCR8211), audit(90-10-01,Itani),
     install(90-10-17,MR12.4-1044):
     Have the calls to the routine 'nothing' changed to calls to the routine
     'null_entry_'.
                                                   END HISTORY COMMENTS */


/* Parameters */

	dcl     arg_iocbp		 ptr;		/* ptr to iocb (input) */
	dcl     code		 fixed bin (35);	/* Multics standard error code (output) */
	dcl     com_err_switch	 bit (1);		/* ON if should call com_err_ for errors (input) */
	dcl     extend_bit		 bit (1);		/* Obsolete open argument */
	dcl     mode		 fixed bin;
	dcl     option_array	 (*) char (*) var;
	dcl     arg_event_call_info_ptr
				 pointer parameter;


/* Automatic */

	dcl     access_class	 bit (72) aligned;	/* binary form of required access class */
	dcl     access_class_range	 (2) bit (72) aligned;
	dcl     access_class_specified bit (1);		/* indicates whether attach description includes access class */
	dcl     access_class_string	 char (864);	/* access class string passed in attach description */
	dcl     actual_iocbp	 ptr;		/* copy of iocb.actual_ioc_ptr */
	dcl     atd		 char (128) var;
	dcl     billing_id		 char (12);
	dcl     billing_id_given	 bit (1);
	dcl     device		 char (32);
	dcl     dial_id		 char (32);
	dcl     do_not_block	 bit (1);
	dcl     dsa_connection_info_ptr
				 ptr;
	dcl     dsa_connection_info_len
				 fixed bin (21);
	dcl     i			 fixed bin;
	dcl     iocbp		 ptr;		/* copy of arg_iocb_ptr */
	dcl     hangup		 bit (1);
	dcl     local_code		 fixed binary (35);
	dcl     login_channel	 bit (1);
	dcl     mask		 bit (36) aligned;	/* ips mask */
	dcl     phone_no		 char (32);	/* phone to which to dial */
	dcl     password		 char (12);
	dcl     password_given	 bit (1);
	dcl     person_id		 char (12);
	dcl     person_id_given	 bit (1);
	dcl     project_id		 char (12);
	dcl     project_id_given	 bit (1);
	dcl     resource_description	 character (256);
	dcl     state		 fixed bin;	/* state returned by hcs_$tty_ calls */
	dcl     suppress_dial_manager	 bit (1) aligned;


/* Automatic Structures */

	dcl     1 dma		 aligned like dial_manager_arg;

	dcl     1 dm_flags		 aligned,
		2 dialup		 bit (1) unal,
		2 hungup		 bit (1) unal,
		2 control		 bit (1) unal,
		2 pad		 bit (33) unal;

	dcl     1 event_message	 like event_wait_info aligned;

	dcl     1 ipcas		 aligned like ipc_create_arg_structure;

	dcl     1 local_eci		 aligned like event_call_info;

	dcl     1 user_id		 like submitter_id aligned;


/* builtins */

	dcl     (addr, char, hbound, index, lbound, length, null, rtrim,
	         string, substr)
				 builtin;

/* Internal Static */

	dcl     dim_name		 char (4) int static options (constant) init ("tty_");
						/* used by com_err_ and setting attach descrip */
	dcl     system_free_area_ptr	 pointer int static init(null);
	dcl     ZERO_BIT		 bit (1) int static options (constant) init ("0"b);

/* Based */

	dcl     connection_info	 (dsa_connection_info_len) fixed bin (35) based (dsa_connection_info_ptr);
	dcl     system_free_area	 area based (system_free_area_ptr);

/* External Static */

	dcl     (
	        error_table_$action_not_performed,
	        error_table_$bad_mode,
	        error_table_$badopt,
	        error_table_$inconsistent,
	        error_table_$io_no_permission,
	        error_table_$noarg,
	        error_table_$not_detached,
	        error_table_$resource_attached,
	        error_table_$too_many_args,
	        error_table_$wrong_no_of_args
	        )			 fixed bin (35) ext;

	dcl     (any_other, cleanup)	 condition;

/* Procedures */

	dcl     com_err_		 entry options (variable);
	dcl     convert_access_class_$from_string
				 entry (bit (72) aligned, char (*), fixed bin (35));
	dcl     convert_dial_message_$return_io_module
				 entry (fixed bin (71), char (*), char (*), fixed bin, 1 structure aligned,
				 2 bit (1) unal, 2 bit (1) unal, 2 bit (1) unal, 2 bit (33) unal, fixed bin (35));
	dcl     (
	        dial_manager_$allow_dials,
	        dial_manager_$dial_out,
	        dial_manager_$privileged_attach,
	        dial_manager_$registered_server,
	        dial_manager_$release_channel,
	        dial_manager_$release_channel_no_hangup,
	        dial_manager_$release_dial_id,
	        dial_manager_$terminate_dial_out
	        )			 entry (ptr, fixed bin (35));
	dcl     dsa_tty_$attach	 entry (char (*), fixed bin (71), fixed bin (35), fixed bin, fixed bin (35));
	dcl     dsa_tty_$connect	 entry (char (*), ptr, fixed bin (71), char (*) var, ptr, char (*),
				 fixed bin (35), ptr, fixed bin (21), char (*) var, (2) bit (72) aligned,
				 fixed bin (35));
	dcl     dsa_tty_$detach	 entry (fixed bin (35), fixed bin, fixed bin, fixed bin (35));
	dcl     dsa_tty_$event	 entry (fixed bin (35), fixed bin (71), fixed bin, fixed bin (35));
	dcl     dsa_tty_$order	 entry (fixed bin (35), character (*), pointer, fixed bin, fixed bin (35));
	dcl     dsa_tty_io_$control	 entry (ptr, char (*), ptr, fixed bin (35));
	dcl     (
	        dsa_tty_io_$put_chars,
	        dsa_tty_io_$get_chars,
	        dsa_tty_io_$get_line,
	        dsa_tty_io_$modes,
	        dsa_tty_io_$position,
	        dsa_tty_io_$control_not_open
	        )			 ext entry;
	dcl     get_process_id_	 entry () returns (bit (36));
	dcl     get_system_free_area_	 entry () returns (pointer);
	dcl     ipc_$decl_ev_call_chn	 entry (fixed bin (71), entry, ptr, fixed bin, fixed bin (35));
	dcl     ipc_$decl_ev_wait_chn	 entry (fixed bin (71), fixed bin (35));
	dcl     ipc_$delete_ev_chn	 entry (fixed bin (71), fixed bin (35));
	dcl     hcs_$delete_channel	 entry (fixed bin (71), fixed bin (35));
	dcl     hcs_$reset_ips_mask	 entry (bit (36) aligned, bit (36) aligned);
	dcl     hcs_$set_ips_mask	 entry (bit (36) aligned, bit (36) aligned);
	dcl     hcs_$tty_attach	 entry (char (*), fixed bin (71), fixed bin, fixed bin, fixed bin (35));
	dcl     hcs_$tty_detach	 entry (fixed bin, fixed bin, fixed bin, fixed bin (35));
	dcl     hcs_$tty_event	 entry (fixed bin, fixed bin (71), fixed bin, fixed bin (35));
	dcl     hcs_$tty_order	 entry (fixed bin, character (*), pointer, fixed bin, fixed bin (35));
	dcl     hcs_$wakeup		 entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
	dcl     ioa_$rsnnl		 entry options (variable);
	dcl     ipc_$create_ev_chn	 entry (fixed bin (71), fixed bin (35));
	dcl     ipc_$create_event_channel
				 entry (ptr, fixed bin (71), fixed bin (35));
	dcl     ipc_$block		 entry (ptr, ptr, fixed bin (35));
	dcl     (
	        ipc_$mask_ev_calls,
	        ipc_$unmask_ev_calls
	        )			 entry (fixed bin (35));
	dcl     null_entry_		 entry ();
	dcl     (
	        tty_io_$put_chars,
	        tty_io_$get_chars,
	        tty_io_$get_line,
	        tty_io_$modes,
	        tty_io_$position,
	        tty_io_$control,
	        tty_io_$control_not_open
	        )			 ext entry;
	dcl     user_info_$terminal_data
				 entry (char (*), char (*), char (*), fixed bin, char (*));

/* include files */
%page;
/*  tty_attach  */

tty_attach:
     entry (arg_iocbp, option_array, com_err_switch, code);

	code = 0;
	mask = ""b;
	iocbp = arg_iocbp;
	resource_description, device, phone_no, dial_id, access_class_string = "";
	password, person_id, billing_id, project_id = "";
	password_given, person_id_given, billing_id_given, project_id_given = "0"b;
	access_class_specified = ""b;
	login_channel, do_not_block = ""b;
	hangup = "1"b;				/* hangup is default */
	suppress_dial_manager = "0"b;
	attach_data_ptr = null ();
	on cleanup call clean_up_attach;

	system_free_area_ptr = get_system_free_area_ ();

	if hbound (option_array, 1) < 1
	then call error (error_table_$noarg, "Usage: tty_ {device} {-control_args}");

	if iocbp -> iocb.attach_descrip_ptr ^= null ()
	then call error (error_table_$not_detached, "");

	do i = lbound (option_array, 1) to hbound (option_array, 1);
	     if /* case */ index (option_array (i), "-") ^= 1
	     then do;				/* channel name */
		     if device ^= ""
		     then call error (error_table_$wrong_no_of_args, "Multiple devices specified.");
		     device = option_array (i);
		end;

	     else if option_array (i) = "-login_channel"
	     then login_channel = "1"b;

	     else if option_array (i) = "-hangup_on_detach"
	     then hangup = "1"b;
	     else if option_array (i) = "-no_hangup_on_detach"
	     then hangup = "0"b;

	     else if option_array (i) = "-resource" | option_array (i) = "-rsc"
	     then do;
		     i = i + 1;
		     if resource_description ^= ""
		     then call error (error_table_$too_many_args, "A second resource description was given.");
		     if i > hbound (option_array, 1)
		     then if char (option_array (i), 1) = "-"
			then call error (error_table_$noarg,
				"Control argument found in place of resource description.");
			else call error (error_table_$noarg, "-resource given without a description.");
		     else ;
		     resource_description = option_array (i);
		end;

	     else if option_array (i) = "-destination" | option_array (i) = "-ds"
	     then do;
		     i = i + 1;
		     if phone_no ^= ""
		     then call error (error_table_$too_many_args, "Multiple dial_out destinations given.");
		     if i > hbound (option_array, 1)
		     then call error (error_table_$noarg, "Phone number.");
		     phone_no = option_array (i);
		end;

	     else if option_array (i) = "-password" | option_array (i) = "-pwd" | option_array (i) = "-pw"
	     then do;
		     i = i + 1;
		     if i > hbound (option_array, 1)
		     then call error (error_table_$noarg, "Password.");
		     password = option_array (i);
		     password_given = "1"b;
		end;

	     else if option_array (i) = "-billing" | option_array (i) = "-bill" | option_array (i) = "-blg"
	     then do;
		     i = i + 1;
		     if i > hbound (option_array, 1)
		     then call error (error_table_$noarg, "Billing.");
		     billing_id = option_array (i);
		     billing_id_given = "1"b;
		end;

	     else if option_array (i) = "-project" | option_array (i) = "-proj" | option_array (i) = "-pj"
	     then do;
		     i = i + 1;
		     if i > hbound (option_array, 1)
		     then call error (error_table_$noarg, "Project.");
		     project_id = option_array (i);
		     project_id_given = "1"b;
		end;


	     else if option_array (i) = "-person_id" | option_array (i) = "-prsid"
	     then do;
		     i = i + 1;
		     if i > hbound (option_array, 1)
		     then call error (error_table_$noarg, "Person_id.");
		     person_id = option_array (i);
		     person_id_given = "1"b;
		end;


	     else if option_array (i) = "-dial_id"
	     then do;
		     i = i + 1;
		     if dial_id ^= ""
		     then call error (error_table_$too_many_args, "Multiple dial ID's given.");
		     if i > hbound (option_array, 1)
		     then call error (error_table_$noarg, "Dial ID.");
		     dial_id = option_array (i);
		end;

	     else if option_array (i) = "-no_block"
	     then do;
		     do_not_block = "1"b;
		end;

	     else if option_array (i) = "-required_access_class"
	     then do;
		     i = i + 1;
		     if access_class_specified
		     then call error (error_table_$too_many_args, "Multiple access classes destinations given.");
		     if i > hbound (option_array, 1)
		     then call error (error_table_$noarg, "Access class.");
		     access_class_string = option_array (i);
		     access_class_specified = "1"b;
		end;

	     else if option_array (i) = "-suppress_dial_manager"
	     then suppress_dial_manager = "1"b;
	     else if option_array (i) = "-no_suppress_dial_manager"
	     then suppress_dial_manager = "0"b;
	     else call error (error_table_$badopt, (option_array (i)));
	end;

	if login_channel
	     & ((phone_no ^= "") | (device ^= "") | (resource_description ^= "") | (dial_id ^= "") | (password ^= "")
	     | (billing_id ^= "") | (project_id ^= "") | (person_id ^= "") | access_class_specified)
	then call error (error_table_$inconsistent, "-login_channel and other control arguments.");
	if (dial_id ^= "") & ((phone_no ^= ""))
	then call error (error_table_$inconsistent, "-dial_id and -destination.");

	if access_class_specified
	then do;
		call convert_access_class_$from_string (access_class, access_class_string, code);
		if code ^= 0
		then call error (code, access_class_string);
	     end;

	if login_channel
	then call user_info_$terminal_data ("", "", device, (0), "");

	tty_max_mode_length = 512;			/* probably long enough, but we will check */
	allocate attach_data in (system_free_area);

	string (attach_data.flags) = ""b;
	attach_data.device_id = device;
	attach_data.device_used = device;		/* unless dm_ changes it */
	attach_data.resource_desc = resource_description;
	attach_data.dial_phone = phone_no;
	attach_data.phone_given = (phone_no ^= "");
	attach_data.dial_id = dial_id;
	attach_data.accept_dial = (dial_id ^= "");
	attach_data.login_channel = login_channel;
	attach_data.no_block = do_not_block;
	if login_channel then			/* hangup does not apply to login channel. */
	     attach_data.hangup = "0"b;
	else 
	     attach_data.hangup = hangup;		/* DSA: hangup instead of "0"b */
	attach_data.operation_hlock = 0;
	attach_data.tty_index, attach_data.tty_handle, attach_data.event_wait.channel_id (1),
	     attach_data.dial_manager_event.channel_id (1) = 0;
%page;


/* The network_type is determined by the structure of the channel name. */
/* If "accept_dial" there is no channel name, so we must first call     */
/* "try_dial_manager_attach" to obtain a channel name, and then we      */
/* can call "try_hcs_attach".                                           */

	if attach_data.flags.accept_dial
	then do;

		if suppress_dial_manager
		then call error (code, "hcs_ terminal attachment failed.");

		call try_dial_manager_attach (code);
		if code ^= 0
		then call error (code, "Could not assign channel.");

		call try_hcs_attach (code);
		if code ^= 0
		then call error (code, "Could not attach channel.");
	     end;

	else do;

/* If we have a channel name, we always try to get the channel      */
/* with hcs_, to avoid changing the dial_manager_ event channel     */
/* if we do not have to. All we could do wrong here is successfully */
/* attach a channel with the wrong reservation characteristics etc. */

		call try_hcs_attach (code);
		if code ^= 0
		then do;

			if attach_data.login_channel
			then call error (code, "Cannot attach login channel.");

			if suppress_dial_manager
			then call error (code, "hcs_ terminal attachment failed.");

			if attach_data.network_type = DSA_NETWORK_TYPE
			then do;			/* Prepare the submitter_id structure */

				subidp = addr (user_id);
				user_id.version = SUBMITTER_ID_V1;
				user_id.person_id = person_id;
				user_id.project_id = project_id;
				user_id.billing_id = billing_id;
				user_id.password = password;

				dsa_connection_info_ptr = null;
				call dsa_tty_$connect (attach_data.device_id, system_free_area_ptr, 0,
				     attach_data.dial_phone, subidp, attach_data.device_used, (0),
				     dsa_connection_info_ptr, dsa_connection_info_len, atd, access_class_range,
				     code);
				if code ^= 0
				then call error (code, "Could not connect channel.");

				/*** free the connection info */

				if dsa_connection_info_ptr ^= null then
				     free connection_info in (system_free_area);
			     end;

			else do;			/* MCS_NETWORK_TYPE */
				call try_dial_manager_attach (code);
				if code ^= 0
				then call error (code, "Could not assign channel.");
			     end;

			call try_hcs_attach (code);
			if code ^= 0
			then call error (code, "Could not attach channel.");
		     end;
	     end;

	call make_atd;

	call check_mode_length;			/* this may re-allocate the attach_data structure. */

	on any_other call handler;			/* should be on */

	call hcs_$set_ips_mask (""b, mask);
	iocbp -> iocb.attach_descrip_ptr = addr (attach_data.attach_descrip);
	iocbp -> iocb.attach_data_ptr = attach_data_ptr;
	iocbp -> iocb.detach_iocb = tty_detach;
	iocbp -> iocb.open = tty_open;

	if attach_data.network_type = DSA_NETWORK_TYPE
	then iocbp -> iocb.control = dsa_tty_io_$control_not_open;
	else /*  MCS */
	     iocbp -> iocb.control = tty_io_$control_not_open;

	call iox_$propagate (iocbp);
	revert any_other;
	call hcs_$reset_ips_mask (mask, mask);


RETURN:
	return;



make_atd:
     procedure;					/* format: off */

	call ioa_$rsnnl (
"^a ^[-login_channel^s^;^a^]^[ -resource ^a^;^s^]^[ -destination ^a^;^s^]" ||
"^[ -password^;^]^[ -person_id ^a^;^s^]^[ -project ^a^;^s^]" || 
"^[ -billing ^a^;^s^]^[ -dial_id ^a^;^s^]^[ -no_block^]" ||
"^[ ^[-no_hangup_on_detach^;-hangup_on_detach^]^]^[ -suppress_dial_manager^]",
	     attach_data.attach_descrip, (0),
	     dim_name,
	     attach_data.login_channel, attach_data.device_used,
	     (attach_data.resource_desc ^= ""), attach_data.resource_desc,
	     attach_data.phone_given, attach_data.dial_phone,
	     password_given,
	     person_id_given, person_id,
	     project_id_given, project_id,
	     billing_id_given, billing_id,
	     attach_data.accept_dial, attach_data.dial_id,
	     attach_data.no_block,
	     ^attach_data.login_channel,
	     ^attach_data.hangup,
	     suppress_dial_manager);

/* format: ^off */

     end make_atd;


/* Error calls com_err_ if the loud switch is set and goes to the attach return */

error:
     proc (err_code, message);

	dcl     err_code		 fixed bin (35);	/* Multics standard error code */
	dcl     message		 char (*);	/* Additional error information */

	if com_err_switch
	then call com_err_ (err_code, dim_name, "^a  ^a", iocbp -> iocb.name, message);
	code = err_code;

	call clean_up_attach;
	goto RETURN;

     end error;
%page;
/* This entry detaches the terminal and frees the information about it.  It ignores the code and does
   the following:

   1.  The event channel is released.
   2.  The channel is released if it was attached with dial_manager_.
   3.  The table space in this dim for the attachment is freed iff the hlock is clear.
*/

tty_detach:
     entry (arg_iocbp, code);

	call set_up;				/* set no lock, but get actual_iocb_ptr */

	call hcs_detach;

	call release_channel;			/* if we got it with dm_, let it go */

	on any_other call handler;			/* should be on */
	call hcs_$set_ips_mask (""b, mask);
	actual_iocbp -> iocb.attach_descrip_ptr = null ();
	actual_iocbp -> iocb.attach_data_ptr = null ();
	actual_iocbp -> iocb.detach_iocb = iox_$err_not_attached;
	actual_iocbp -> iocb.open = iox_$err_not_attached;
	actual_iocbp -> iocb.control = iox_$err_not_attached;
	call iox_$propagate (actual_iocbp);
	call hcs_$reset_ips_mask (mask, mask);
	revert any_other;				/* avoid unneccessary fatal errors */
	if attach_data.operation_hlock = 0
	then free attach_data in (system_free_area);
	else attach_data.async_detach = "1"b;		/* warn other incarnations */

	return;
%page;
/*  This entry sets the open description and the legal operation entries in the iocb.  The operations permitted:

   all the time:	close, control, modes
   input:		get_chars, get_line, position
   output:	put_chars
*/

tty_open:
     entry (arg_iocbp, mode, extend_bit, code);


	call set_up;

	if mode = Stream_input | mode = Stream_output | mode = Stream_input_output
	then attach_data.open_descrip = iox_modes (mode);
	else do;
		code = error_table_$bad_mode;
		return;
	     end;

	call allocate_ev_channel (code);		/* in case user supplied with set_event */
	if code ^= 0
	then return;

	call ipc_$mask_ev_calls (code);		/* do not let user code run till we are really open */
	if code ^= 0
	then return;

	if attach_data.async_hangup
	then code = error_table_$io_no_permission;	/* we lost it during these last few statements */

	else do;
		if attach_data.network_type = DSA_NETWORK_TYPE
		then call dsa_tty_$event (attach_data.tty_handle, attach_data.event_wait.channel_id (1), (0), code);
		else /* MCS */
		     call hcs_$tty_event (attach_data.tty_index, attach_data.event_wait.channel_id (1), (0), code);
	     end;

	if code ^= 0
	then do;
		call ipc_$unmask_ev_calls ((0));
		return;
	     end;


	on any_other call handler;
	call hcs_$set_ips_mask (""b, mask);

	actual_iocbp -> iocb.open_descrip_ptr = addr (attach_data.open_descrip);
	actual_iocbp -> iocb.detach_iocb = iox_$err_not_closed;
	actual_iocbp -> iocb.open = iox_$err_not_closed;
	actual_iocbp -> iocb.close = tty_close;

	if attach_data.network_type = DSA_NETWORK_TYPE
	then do;					/* DSA */

		actual_iocbp -> iocb.modes = dsa_tty_io_$modes;
		actual_iocbp -> iocb.control = dsa_tty_io_$control;

		if mode ^= Stream_output
		then do;
			actual_iocbp -> iocb.get_line = dsa_tty_io_$get_line;
			actual_iocbp -> iocb.get_chars = dsa_tty_io_$get_chars;
			actual_iocbp -> iocb.position = dsa_tty_io_$position;
		     end;

		if mode ^= Stream_input
		then actual_iocbp -> iocb.put_chars = dsa_tty_io_$put_chars;
	     end;

	else do;					/* MCS*/

		actual_iocbp -> iocb.modes = tty_io_$modes;
		actual_iocbp -> iocb.control = tty_io_$control;

		if mode ^= Stream_output
		then do;
			actual_iocbp -> iocb.get_line = tty_io_$get_line;
			actual_iocbp -> iocb.get_chars = tty_io_$get_chars;
			actual_iocbp -> iocb.position = tty_io_$position;
		     end;

		if mode ^= Stream_input
		then actual_iocbp -> iocb.put_chars = tty_io_$put_chars;
	     end;

	call iox_$propagate (actual_iocbp);
	call hcs_$reset_ips_mask (mask, mask);
	revert any_other;
	call ipc_$unmask_ev_calls ((0));

	if attach_data.network_type = DSA_NETWORK_TYPE
	then call dsa_tty_$order (attach_data.tty_handle, "start", null (), state, code);
	else /* MCS */
	     call hcs_$tty_order (attach_data.tty_index, "start", null (), state, code);

/* If this is a DSA login connection, the terminal type is already known, */
/* the tables are not initialized for this terminal type;  So, we have    */
/* to initialize the conversion tables, the TCB, SCB, etc ... as they are */
/* in the login server for this connection.  We use a new control order:  */
/* init_term_type.                                                        */

	if attach_data.network_type = DSA_NETWORK_TYPE
	then do;
		call dsa_tty_io_$control (actual_iocbp, "init_term_type", null (), code);
		if code ^= 0
		then call error (code, "init_term_type");
	     end;

	code = 0;
	return;
%page;
/*  This procedure closes the io switch and returns a zero code. */

tty_close:
     entry (arg_iocbp, code);

	call set_up;
	if attach_data.operation_hlock ^= 0
	then attach_data.async_close = "1"b;

/* turn off wakeups from the channel */

	if ^attach_data.async_hangup			/* don't bother if it's not ours */
	then do;

		if attach_data.network_type = DSA_NETWORK_TYPE
		then call dsa_tty_$event (attach_data.tty_handle, (0), (0), (0));
		else /* MCS */
		     call hcs_$tty_event (attach_data.tty_index, (0), (0), (0));
	     end;

	/*** If tty_ created the event channel, we will now destroy it.  However, we do not zero
	     event_wait.channel_id(1) because, if an I/O was in progress on the switch which called ipc_$block and the
	     user disconnects the channel, when he reconnects and types "start", control will return to ipc_$block which
	     will attempt to validate the channel name.  If we zero the channel name, this will fail and the restart
	     will not work properly. */

	if attach_data.assigned_ev_channel		/* fast channel, give back to hardcore */
	then do;
		call hcs_$delete_channel (attach_data.event_wait.channel_id (1), code);
		attach_data.have_ev_channel, attach_data.assigned_ev_channel = "0"b;
	     end;
	else if attach_data.created_ev_channel		/* we created regular channel */
	then do;
		call ipc_$delete_ev_chn (attach_data.event_wait.channel_id (1), code);
		attach_data.have_ev_channel, attach_data.created_ev_channel = "0"b;
	     end;
	else ;					/* user supplied event channel remains until detached */

	on any_other call handler;			/* should be on */
	call hcs_$set_ips_mask (""b, mask);

	actual_iocbp -> iocb.open_descrip_ptr = null;
	actual_iocbp -> iocb.detach_iocb = tty_detach;
	actual_iocbp -> iocb.open = tty_open;

	if attach_data.network_type = DSA_NETWORK_TYPE
	then actual_iocbp -> iocb.control = dsa_tty_io_$control_not_open;
	else /* MCS */
	     actual_iocbp -> iocb.control = tty_io_$control_not_open;

	actual_iocbp -> iocb.modes = iox_$err_not_open;

	call iox_$propagate (actual_iocbp);

	call hcs_$reset_ips_mask (mask, mask);
	return;
%page;
/*  Internal procedure to handle faults while IPS interrupts are masked.  For a fault while masked, the process
   is terminated (with the reason "unable to do critical I/O") because the I/O control blocks are in an
   inconsistent state.
*/

handler:
     procedure options (non_quick);			/* visible in azm */

	dcl     error_table_$unable_to_do_io
				 fixed (35) ext;

	if mask ^= ""b
	then call terminate_this_process (error_table_$unable_to_do_io);

     end handler;


terminate_this_process:
     procedure (cd);

	dcl     cd		 fixed bin (35);
	dcl     terminate_process_	 ext entry (char (*), ptr);
	dcl     1 ti		 aligned automatic,
		2 version		 fixed,
		2 code		 fixed (35);


	ti.version = 0;
	ti.code = cd;
	call terminate_process_ ("fatal_error", addr (ti));

     end terminate_this_process;
%page;
allocate_ev_channel:
     procedure (code);				/*  Assign event channel */

	dcl     code		 fixed binary (35) parameter;

	code = 0;

	if attach_data.have_ev_channel		/* user supplied a channel via "set_event" order */
	then return;

	/*** Try to get a fast channel, first;      */
	/*** If no success create an event channel. */

	ipcas.version = ipc_create_arg_structure_v1;
	ipcas.channel_type = FAST_EVENT_CHANNEL_TYPE;
	ipcas.call_entry = null_entry_;
	ipcas.call_data_ptr = null ();
	ipcas.call_priority = 0;
	call ipc_$create_event_channel (addr (ipcas), attach_data.event_wait.channel_id (1), code);
	if code = 0
	then attach_data.assigned_ev_channel = "1"b;
	else do;
		ipcas.channel_type = WAIT_EVENT_CHANNEL_TYPE;
		call ipc_$create_event_channel (addr (ipcas), attach_data.event_wait.channel_id (1), code);
		if code = 0
		then attach_data.created_ev_channel = "1"b;
		else return;
	     end;

	attach_data.have_ev_channel = "1"b;		/* here if we created a channel */
	return;

     end allocate_ev_channel;


try_hcs_attach:
     procedure (code);

	dcl     code		 fixed bin (35);

	code = 0;

/* The network_type is initialized here.                      */
/* set no event -- it will be set with tty_event at open time */

	if substr (device, 1, 4) = "dsa."		/* DSA */
	then do;
		attach_data.network_type = DSA_NETWORK_TYPE;
		call dsa_tty_$attach (attach_data.device_used, 0, attach_data.tty_handle, state, code);
	     end;

	else do;					/* MCS */
		attach_data.network_type = MCS_NETWORK_TYPE;
		call hcs_$tty_attach (attach_data.device_used, 0, attach_data.tty_index, state, code);
	     end;

	if code = 0
	then if attach_data.login_channel
	     then do;
		     if attach_data.network_type = DSA_NETWORK_TYPE
		     then /* DSA */
			call dsa_tty_$order (attach_data.tty_handle, "set_line_status_enabled", addr (ZERO_BIT),
			     state, code);
		     else /* MCS */
			call hcs_$tty_order (attach_data.tty_index, "set_line_status_enabled", addr (ZERO_BIT),
			     state, code);
		end;

     end try_hcs_attach;
%page;
try_dial_manager_attach:
     procedure (code);

	dcl     code		 fixed bin (35);

	code = 0;
	call ipc_$create_ev_chn (attach_data.dial_manager_event.channel_id (1), code);
	if code ^= 0
	then return;
	dma.version = dial_manager_arg_version_3;
	dma.dial_channel = attach_data.dial_manager_event.channel_id (1);
(nostrz):
	dma.dial_qualifier = attach_data.dial_id;
	dma.channel_name = attach_data.device_id;
	dma.dial_out_destination = attach_data.dial_phone;
	dma.reservation_string = resource_description;

	if ^access_class_specified
	then dma.access_class, dma.access_class_required = "0"b;
	else do;
		dma.access_class = access_class;
		dma.access_class_required = "1"b;
	     end;

	if attach_data.flags.phone_given
	then call dial_manager_$dial_out (addr (dma), code);
	else if attach_data.flags.accept_dial
	then do;
		call dial_manager_$registered_server (addr (dma), code);
		if code ^= 0
		then call dial_manager_$allow_dials (addr (dma), code);
	     end;
	else call dial_manager_$privileged_attach (addr (dma), code);

/*
  If this is a priv_attach, then if we already have it then everything
  is fine. If user specified the destination, then we must dial to it.
*/

	if (code = error_table_$resource_attached) & ^attach_data.flags.phone_given
	then do;	/*** must release is still "0"b at this point */
		code = 0;				/* do not go blocked, as has nothing further to say */
		return;
	     end;
	if code ^= 0				/* couldn't get the channel at all */
	then do;
dm_attachment_failed_:
		call ipc_$delete_ev_chn (attach_data.dial_manager_event.channel_id (1), (0));
		attach_data.dial_manager_event.channel_id (1) = 0;
		attach_data.flags.must_release = "0"b;
		return;
	     end;

	attach_data.flags.must_release = "1"b;		/* in case of cleanup during block */

	call ipc_$block (addr (attach_data.dial_manager_event), addr (event_message), code);
						/* wait for news from initializer */
	if code ^= 0
	then go to dm_attachment_failed_;

	call convert_dial_message_$return_io_module (event_message.message, device, (""), (0), dm_flags, code);
	if code ^= 0
	then go to dm_attachment_failed_;
	if ^dm_flags.dialup
	then do;
		code = error_table_$action_not_performed;
		go to dm_attachment_failed_;
	     end;

	attach_data.flags.must_release = "1"b;
	attach_data.flags.hangup = hangup;
	attach_data.device_used = device;		/* starnames unstarred here */

	if attach_data.flags.accept_dial
	then do;
		call dial_manager_$release_dial_id (addr (dma), code);
		if code ^= 0			/* we still have to release the channel */
		then return;
	     end;

	call ipc_$decl_ev_call_chn (attach_data.dial_manager_event.channel_id (1), tty_as_signal_handler,
	     attach_data_ptr, 1 /* NOTE: what's a reasonable priority? */, code);
	if code ^= 0
	then do;					/* this must work for proper operation */
		code = error_table_$action_not_performed;
		return;				/* ... but we must still release the channel */
	     end;

	return;

     end try_dial_manager_attach;
%page;
/* This entrypoint is called whenever an IPC signal is sent by the Answering
   Service for a channel which we had attached via dial_manager_.  We check
   the message to determine the type of event and, if the event is a hangup,
   we set the async_hangup flag, disable any subsequent attempts to release
   the channel as we no longer own it, send a wakeup on the I/O event channel
   to unblock any interrupted I/O, and invoke the user's hangup procedure
   (if any). */

tty_as_signal_handler:
     entry (arg_event_call_info_ptr);

	event_call_info_ptr = arg_event_call_info_ptr;
	attach_data_ptr = event_call_info.data_ptr;

	call convert_dial_message_$return_io_module (event_call_info.message, device, (""), (0), dm_flags, local_code);
	if local_code ^= 0				/* ignore signals we can't interpret */
	then return;

	if device ^= attach_data.device_used		/* ignore signals for other channels */
	then return;

	if ^dm_flags.hungup				/* ignore anything other than hangup signals */
	then return;

	attach_data.async_hangup = "1"b;
	attach_data.must_release = "0"b;		/* it's no longer ours */

	if attach_data.operation_hlock > 0		/* try to unblock pending I/O */
	then call hcs_$wakeup (get_process_id_ (), attach_data.event_wait.channel_id (1), 0, (0));

	if attach_data.have_user_hangup_proc		/* let the user do his thing */
	then do;
		local_eci = event_call_info;		/* ... user needs to get same info but with his data_ptr */
		local_eci.data_ptr = attach_data.user_hangup_proc.data_ptr;
		call attach_data.user_hangup_proc.procedure (addr (local_eci));
	     end;

	return;
%page;
release_channel:
     procedure;

	declare code		 fixed bin (35);

	if attach_data.flags.must_release
	then do;
		dma.version = dial_manager_arg_version_3;
		dma.channel_name = attach_data.device_used;
		dma.dial_channel = attach_data.dial_manager_event.channel_id (1);
		call ipc_$decl_ev_wait_chn (dma.dial_channel, code);

		if /* case */ attach_data.flags.phone_given
		then call dial_manager_$terminate_dial_out (addr (dma), code);
		else if attach_data.flags.hangup
		then call dial_manager_$release_channel (addr (dma), code);
		else call dial_manager_$release_channel_no_hangup (addr (dma), code);

		attach_data.flags.must_release = "0"b;
	     end;

	if attach_data.dial_manager_event.channel_id (1) ^= 0
	then do;
		call ipc_$delete_ev_chn (attach_data.dial_manager_event.channel_id (1), code);
		attach_data.dial_manager_event.channel_id (1) = 0;
	     end;

	return;

     end release_channel;


hcs_detach:
     procedure;

	if ((attach_data.tty_index > 0) | (attach_data.tty_handle > 0)) & ^attach_data.async_hangup
	then do;					/* don't bother detaching if it's no longer ours */

		if attach_data.network_type = DSA_NETWORK_TYPE
		then do;	/*** If no_hangup_on_detach we just detach in tty_ (dflag = 0);     */
			/*** else we terminate the session in session control  (dflag = 1) */

			if attach_data.hangup
			then call dsa_tty_$detach (attach_data.tty_handle, 1, (0), local_code);
			else call dsa_tty_$detach (attach_data.tty_handle, 0, (0), local_code);
		     end;

		else /* MCS */
		     call hcs_$tty_detach (attach_data.tty_index, 0, (0), local_code);

		if local_code ^= 0			/* lost the channel after last block */
		then attach_data.flags.must_release = "0"b;
	     end;

	attach_data.tty_index = 0;			/* definitely not ours anymore */

     end hcs_detach;


check_mode_length:
     procedure;

/**** Here we see if the hardcore returns more than our hard-coded guess
      of the maximum mode length. This code is here to avoid coordinating
      changes between this program and the hardcore, and to allow sites
      to have multiplexers that have long mode strings without neccessarily
      having to change this program. Clearly, having to reallocate all the
      time would be pretty poor. */

	declare 1 very_long_mode_info	 aligned,
		2 max_length	 fixed bin (21),
		2 mode_string	 char (2000);

	declare new_attach_data_ptr	 pointer;

	very_long_mode_info.max_length = 2000;
	very_long_mode_info.mode_string = "";

	if attach_data.network_type = DSA_NETWORK_TYPE
	then call dsa_tty_$order (attach_data.tty_handle, "modes", addr (very_long_mode_info), state, local_code);
	else /* MCS */
	     call hcs_$tty_order (attach_data.tty_index, "modes", addr (very_long_mode_info), state, local_code);

	if local_code ^= 0 | length (rtrim (very_long_mode_info.mode_string)) <= attach_data.max_mode_length
	then return;

	tty_max_mode_length = length (rtrim (very_long_mode_info.mode_string)) + 100;
						/* room to grow some */
	allocate attach_data in (system_free_area) set (new_attach_data_ptr);
	new_attach_data_ptr -> attach_data = attach_data; /* copy away */
	new_attach_data_ptr -> attach_data.max_mode_length = tty_max_mode_length;
	free attach_data in (system_free_area);
	attach_data_ptr = new_attach_data_ptr;
	return;

     end check_mode_length;


set_up:
     procedure;

	code = 0;
	mask = ""b;
	actual_iocbp = arg_iocbp -> iocb.actual_iocb_ptr;
	attach_data_ptr = actual_iocbp -> iocb.attach_data_ptr;
	return;

     end set_up;


clean_up_attach:
     procedure;

	if attach_data_ptr = null ()
	then return;

	if (attach_data.tty_index > 0) | (attach_data.tty_handle > 0)
	then call hcs_detach;

	call release_channel ();

     end clean_up_attach;
%page; %include dial_manager_arg;
%page; %include dsa_scu_sec_info;
%page; %include event_call_info;
%page; %include event_wait_info;
%page; %include iocb;
%page; %include iox_entries;
%page; %include iox_modes;
%page; %include ipc_create_arg;
%page; %include net_event_message;
%page; %include set_term_type_info;
%page; %include tty_attach_data_;
%page; %include tty_states;
     end tty_;





		    tty_io_.pl1                     08/08/88  1552.2r w 08/08/88  1409.3      348084



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

/* tty_io_ is the part of the tty_ io module that is used in
   actual io operation. */


/****^  HISTORY COMMENTS:
  1) change(81-03-17,BMargulies), approve(), audit(), install():
     Created.
     Modified October 1981 by C. Hornig to time out on write_status calls.
     Modified May 1982 by Robert Coren to accept (set get)_event_channel.
     Modified 8 Sepctember 1982 by Richard Lamson to add timeout code.
     Modified June 1983 by Robert Coren to make "get_channel_info" order
        return device_used rather than device_id.
     Modified April 1984 by Jon A. Rochlis to special case the "reconnection"
        control order so tty_ reconnections don't hang with the new
        reconnection strategy.
     Modified 1984-10-29 BIM to remove constant non-local gotos.
     Modified January 1985 by G. Palter for new treatment of dial_manager_
        attached channels.
     Modified 1985-02-01, BIM: fixed timeout not to wait forever.
     Modified 1985-02-19, BIM: added get_com_channel_info.
     Modified: 26 February 1985 by G. Palter to fix the "set_event_channel"
        control order to properly release any created-by-tty_ IPC channel.
  2) change(87-03-17,LJAdams), approve(87-04-03,MCR7646),
     audit(87-05-05,Gilcrease), install(87-05-14,MR12.1-1030):
     Changed ttd_version to ttd_version_3.
                                                   END HISTORY COMMENTS */


/* format: style2 */

tty_io_:
     procedure;
	return;

	declare (
	        arg_iocbp		 pointer,
	        arg_buf_ptr		 ptr,		/* ptr to user buffer (input) */
	        arg_buf_len		 fixed bin (21),	/* length of user buffer (input) */
	        (a_new_modes, a_old_modes)
				 char (*),	/* arguments to modes operation */
	        code		 fixed bin (35),	/* the usual */
	        chars_trans		 fixed bin (21),	/* no. of characters transmitted  (output) */
	        info_ptr		 ptr,		/* ptr to info (input) */
	        no_of_records	 fixed bin (21),	/* no. of lines to be skipped.  tty_position (input) */
	        order		 char (*),	/* name of order.  tty_control  (input) */
	        mode		 fixed bin	/* position mode */
	        )			 parameter;

	dcl     timed_out		 bit (1) aligned;
	dcl     temp_code		 fixed bin (35);
	dcl     temp_state		 fixed bin;

	dcl     create_ips_mask_	 entry (ptr, fixed bin, bit (36) aligned);
	dcl     get_com_channel_info_	 entry (pointer, fixed binary (35));
	dcl     hcs_$delete_channel	 entry (fixed bin (71), fixed bin (35));
	dcl     (
	        hcs_$set_ips_mask,
	        hcs_$reset_ips_mask
	        )			 entry (bit (36) aligned, bit (36) aligned);
	dcl     hcs_$tty_abort	 entry (fixed bin, fixed bin, fixed bin, fixed bin (35));
	dcl     hcs_$tty_event	 entry (fixed bin, fixed bin (71), fixed bin, fixed bin (35));
	dcl     hcs_$tty_get_line	 entry (fixed bin, ptr, fixed bin (21), fixed bin (21), fixed bin (21), bit (1),
				 fixed bin, fixed bin (35));
	dcl     hcs_$tty_order	 entry (fixed bin, char (*), ptr, fixed bin, fixed bin (35));
	dcl     hcs_$tty_read	 entry (fixed bin, ptr, fixed bin (21), fixed bin (21), fixed bin (21), fixed bin,
				 fixed bin (35));
	dcl     hcs_$tty_state	 entry (fixed bin, fixed bin, fixed bin (35));
	dcl     hcs_$tty_write	 entry (fixed bin, ptr, fixed bin (21), fixed bin (21), fixed bin (21), fixed bin,
				 fixed bin (35));
	dcl     ipc_$block		 entry (ptr, ptr, fixed bin (35));
	dcl     ipc_$create_ev_chn	 entry (fixed bin (71), fixed bin (35));
	dcl     ipc_$decl_ev_call_chn	 entry (fixed bin (71), entry, ptr, fixed bin, fixed bin (35));
	dcl     ipc_$delete_ev_chn	 entry (fixed bin (71), fixed bin (35));
	dcl     timer_manager_$alarm_wakeup
				 entry (fixed bin (71), bit (2), fixed bin (71));
	dcl     timer_manager_$reset_alarm_wakeup
				 entry (fixed bin (71));
	dcl     timer_manager_$sleep	 entry (fixed binary (71), bit (2));
	dcl     tty_$tty_as_signal_handler
				 entry (pointer);
	dcl     (
	        tty_io_call_control_,
	        tty_io_call_control_$not_open
	        )			 entry (ptr, char (*), ptr, fixed bin (35));
	dcl     ttt_info_$terminal_data
				 entry (char (*), fixed bin, fixed bin, ptr, fixed bin (35));
	dcl     ttt_info_$initial_string
				 entry (char (*), char (512) varying, fixed bin (35));
	dcl     ttt_info_$modes	 entry (char (*), char (*), fixed bin (35));

	dcl     (addr, addrel, index, length, mod, null, reverse, rtrim, substr, charno, addcharno)
				 builtin;

	dcl     actual_iocbp	 ptr;		/* copy of iocb.actual_ioc_ptr */
	dcl     buffer_ptr		 ptr;		/* ptr to the base of the segment pointed to by arg_buf_ptr */
	dcl     control_not_open	 bit (1);
	dcl     event_channel	 fixed bin (71) based;
	dcl     event_wait_ptr	 pointer;
	dcl     (i, amt_trans)	 fixed bin (21);
	dcl     iox_op_in_progress	 fixed bin;
	dcl     initial_string	 char (512) varying;/* terminal initialization string */
	dcl     ltype		 fixed bin;
	dcl     modes_ptr		 ptr;		/* points to modes structure for hcs_$tty_order */
	dcl     modes_need_restoration bit (1) aligned;
	dcl     nl_returned		 bit (1);
	dcl     num_to_read		 fixed bin (21);	/* chars to request from hcs_$tty_read */
	dcl     num_read		 fixed bin (21);	/* number of chars returned from ring 0 */
	dcl     offset		 fixed bin (21);	/* offset from 0 for hcs_$tty_ calls */

	dcl     Relative_Microseconds	 bit (2) static init ("10"b) options (constant);
	dcl     scratch_buffer_ptr	 pointer;
	dcl     scratch_buffer	 char (2000) aligned based (scratch_buffer_ptr);
	dcl     sis_version		 fixed bin int static options (constant) init (1);
						/* version of send_initial_string_info structure */
	dcl     sus_trm_names	 (3) char (32) int static options (constant) init ("sus_", "trm_", "alrm");
	dcl     set_type_order	 bit (1) aligned;	/* ON for set_type order, OFF for set_term_type */
	dcl     state		 fixed bin;	/* state returned by hcs_$tty_ calls */

	declare 1 timeout_event_wait	 aligned,
		2 n_channels	 fixed binary,
		2 padding		 fixed binary,
		2 channel_id	 (2) fixed binary (71);

	dcl     total_amt_trans	 fixed bin (21);	/* number of characters transferred */

	declare old_type		 fixed bin based (info_ptr);

	dcl     1 ttd		 aligned like terminal_type_data;
						/* info structure for set_terminal_data order (ring 0) */

	declare 1 send_initial_string_info
				 aligned like tty_send_initial_string_info based (info_ptr);

	declare 1 get_channel_info	 aligned based (info_ptr) like tty_get_channel_info;

	dcl     1 status_struc	 aligned based (info_ptr),
		2 ev_chn		 fixed bin (71),
		2 data_available	 bit (1) unaligned;

	dcl     1 t_info		 aligned like terminal_info;
						/* info structure for terminal_info order */

	dcl     1 event_message	 aligned like event_wait_info;

	dcl     based_state		 fixed bin based;

	dcl     1 hangup_proc_data	 aligned based (info_ptr),
		2 entry_var	 entry variable,
		2 data_ptr	 ptr,
		2 prior		 fixed bin;

	dcl     (
	        error_table_$null_info_ptr,
	        error_table_$action_not_performed,
	        error_table_$timeout,
	        error_table_$out_of_sequence,
	        error_table_$smallarg,
	        error_table_$bad_arg,
	        error_table_$long_record,
	        error_table_$no_operation,
	        error_table_$not_open,
	        error_table_$unimplemented_version,
	        error_table_$undefined_order_request,
	        error_table_$no_initial_string,
	        error_table_$io_no_permission
	        )			 fixed bin (35) external static;

	dcl     cleanup		 condition;
%page;
/* format: off */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/* The new reconnection strategy is described here. At the entry to any of the i/o	*/
	/* entries (all but attach, open, close, detach) we increment			*/
	/* attach_data.operation_hlock. We then check attach_data.async_close and async_detach.	*/
	/* These indicate that we have had our switch removed out from under us. If the hlock is	*/
	/* one, meaning that we are the only operation suspended, and async_detach is on, then	*/
	/* we free the attach data. Otherwise we decrement the hlock. (half lock). Then, if the	*/
	/* iocb is in fact attached and opened, we call iox_ to do our operation on the new	*/
	/* switch, and return that result. There is a race window here, in that the async	*/
	/* operation could happen before we bump the counter. In that case the attach data would	*/
	/* be invalid and unpredictable. This seems unlikely, and is not handled in this	*/
	/* implementation.								*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* format: ^off */

/* CONVENTIONS:
   proper_io_return (code) does not return, and should be used
   to return to caller of tty_io_.

   check_for_disconnect (code) checks for io_no_permission. If found
   in goes and does reconnection and does not return.
   If it does return, the code is the valid error code */
%page;
control_not_open:
     entry (arg_iocbp, order, info_ptr, code);
	control_not_open = "1"b;
	goto CONTROL_JOIN;

control:
     entry (arg_iocbp, order, info_ptr, code);
	control_not_open = ""b;

CONTROL_JOIN:
	if (order = "get_chars_timeout") | (order = "get_line_timeout") | (order = "put_chars_timeout")
	then do;					/* need to initialize output value in info structure */
		if info_ptr = null ()
		then call proper_io_return (error_table_$null_info_ptr);
		if order = "put_chars_timeout"
		then info_ptr -> output_timeout_info.characters_written = 0;
		else /*** if (order = "get_chars_timeout") | (order = "get_line_timeout") then */
		     info_ptr -> input_timeout_info.characters_read = 0;
	     end;

	call set_up_io (4);				/* will abort the operation if there was an async hangup */
	on cleanup call clean_up;

	if order = "reconnection"
	then call proper_io_return (error_table_$unimplemented_version);

	if order = "io_call" | order = "io_call_af"
	then do;
		if control_not_open
		then call tty_io_call_control_$not_open (actual_iocbp, order, info_ptr, code);
		else call tty_io_call_control_ (actual_iocbp, order, info_ptr, code);
		call proper_io_return (code);
	     end;

	if order = "set_event" | order = "set_event_channel"
	then do;					/* user wants to get wakeups */
		if control_not_open
		then do;
			attach_data.event_wait.channel_id = info_ptr -> event_channel;
			attach_data.have_ev_channel = "1"b;
		     end;
		else do;

/* see tty_ for explanation of this stuff about fast and slow channels */

			if attach_data.assigned_ev_channel
			then do;
				call hcs_$delete_channel (attach_data.event_wait.channel_id (1), code);
				attach_data.assigned_ev_channel = "0"b;
			     end;
			else if attach_data.created_ev_channel
			then do;
				call ipc_$delete_ev_chn (attach_data.event_wait.channel_id (1), code);
				attach_data.created_ev_channel = "0"b;
			     end;
			attach_data.event_wait.channel_id (1) = info_ptr -> event_channel;
			call hcs_$tty_event (attach_data.tty_index, attach_data.event_wait.channel_id (1), state,
			     code);
			if code ^= 0
			then call check_for_disconnect (code);
			call call_order ("start", null (), state, code);
			if code ^= 0
			then call check_for_disconnect (code);
		     end;
		call proper_io_return (code);
	     end;
	if order = "get_event" | order = "get_event_channel"
	then do;
		if ^attach_data.have_ev_channel
		then call proper_io_return (error_table_$out_of_sequence);
		info_ptr -> event_channel = attach_data.event_wait.channel_id (1);
		call proper_io_return (code);
	     end;


	if order = "state"
	then do;
		if info_ptr = null ()
		then call proper_io_return (error_table_$null_info_ptr);
		call hcs_$tty_state (attach_data.tty_index, temp_state, temp_code);
		info_ptr -> based_state = temp_state;
		call proper_io_return (0);
	     end;

	if order = "get_com_channel_info"
	then do;
		if info_ptr = null ()
		then call proper_io_return (error_table_$null_info_ptr);
		info_ptr -> as_com_channel_info.channel_name = attach_data.device_used;
		call get_com_channel_info_ (info_ptr, code);
		call proper_io_return (code);
	     end;

	if control_not_open				/* no other orders for closed switches */
	then call proper_io_return (error_table_$not_open);


	if order = "modes"
	then do;					/* turn this into a tty_modes call */
		call call_order ("modes", info_ptr, state, code);
		call proper_io_return (code);
	     end;

	if order = "resetread"
	then call abort (1, code);			/* abort dont return */
	if order = "resetwrite"
	then call abort (2, code);
	if order = "abort"
	then call abort (3, code);

	if order = "get_line_timeout"
	then do;
		timeout_info_ptr = info_ptr;
		call timer_setup (input_timeout_info.timeout);
		call get_line (input_timeout_info.buffer_pointer, input_timeout_info.buffer_length,
		     input_timeout_info.characters_read, input_timeout_info.timeout);
	     end;

	if order = "get_chars_timeout"
	then do;
		timeout_info_ptr = info_ptr;
		call timer_setup (input_timeout_info.timeout);
		call get_chars (input_timeout_info.buffer_pointer, input_timeout_info.buffer_length,
		     input_timeout_info.characters_read, input_timeout_info.timeout);
						/* And it never returns -- calls proper_io_return */
	     end;

	if order = "put_chars_timeout"
	then do;
		timeout_info_ptr = info_ptr;
		call timer_setup (output_timeout_info.timeout);

		call put_chars (output_timeout_info.buffer_pointer, output_timeout_info.buffer_length,
		     output_timeout_info.characters_written, output_timeout_info.timeout);
						/* Never returns -- calls proper_io_return */
	     end;

	if order = "event_info"
	then do;
		info_ptr -> event_channel = attach_data.event_wait.channel_id (1);
		call proper_io_return (0);
	     end;

	if order = "set_term_type"
	then do;
		sttip = info_ptr;
		if set_term_type_info.version ^= stti_version_1
		then call proper_io_return (error_table_$unimplemented_version);
		call get_terminal_info;
		t_info.term_type = set_term_type_info.name;
		if set_term_type_info.flags.ignore_line_type
		then ltype = 0;
		else ltype = t_info.line_type;
		set_type_order = "0"b;

TYPE:
		ttd.version = ttd_version_3;
		call ttt_info_$terminal_data (t_info.term_type, ltype, t_info.baud_rate, addr (ttd), code);
		if code ^= 0
		then call proper_io_return (code);

		call call_order ("set_terminal_data", addr (ttd), state, code);
		if code ^= 0
		then call proper_io_return (code);

		if set_type_order
		then call proper_io_return (code);

		if set_term_type_info.flags.set_modes
		then do;
			call set_default_modes ("force,", code);
			if code ^= 0
			then call proper_io_return (code);
		     end;

		if set_term_type_info.flags.send_initial_string
		then do;
			call send_default_initial_string (code);
			if code ^= 0
			then if code = error_table_$no_initial_string
			     then code = 0;
		     end;

		call proper_io_return (code);
	     end;

	if order = "set_default_modes"
	then do;
		call get_terminal_info;
		call set_default_modes ("init,force,", code);
		call proper_io_return (code);
	     end;

	if order = "send_initial_string"
	then do;
		if info_ptr = null ()
		then do;
			call get_terminal_info;
			call send_default_initial_string (code);
		     end;
		else do;
			if send_initial_string_info.version ^= sis_version
			then call proper_io_return (error_table_$unimplemented_version);
			initial_string = send_initial_string_info.initial_string;
			call send_initial_string (initial_string, code);
		     end;
		call proper_io_return (code);
	     end;

	if order = "set_type" | order = "set_terminal_type"
						/* obsolete, map into set_term_type */
	then do;
		if old_type < 1 | old_type > max_tty_type
		then call proper_io_return (error_table_$undefined_order_request);
		call get_terminal_info;
		t_info.term_type = tty_dev_type (old_type);
		ltype = 0;
		set_type_order = "1"b;
		go to TYPE;
	     end;

	if order = "get_channel_info"
	then do;
		if get_channel_info.version ^= 1
		then call proper_io_return (error_table_$unimplemented_version);
		get_channel_info.devx = attach_data.tty_index;
		get_channel_info.channel_name = attach_data.device_used;
		call proper_io_return (0);
	     end;

	if order = "hangup_proc"
	then do;
		if attach_data.dial_manager_event.channel_id (1) = 0
		then call proper_io_return (error_table_$action_not_performed);
		attach_data.user_hangup_proc.procedure = hangup_proc_data.entry_var;
		attach_data.user_hangup_proc.data_ptr = hangup_proc_data.data_ptr;
		attach_data.have_user_hangup_proc = "1"b;
		call ipc_$decl_ev_call_chn (attach_data.dial_manager_event.channel_id (1), tty_$tty_as_signal_handler,
		     attach_data_ptr, hangup_proc_data.prior, code);
		call proper_io_return (code);		/* change the priority to the requested value */
	     end;

	do;
	     call call_order (order, info_ptr, state, code);
						/* see if hardcore knows it */
	     if code ^= 0
	     then call proper_io_return (code);

	     if order = "read_status"			/* our part of this bargain */
	     then status_struc.ev_chn = attach_data.event_wait.channel_id (1);
	     if order = "write_status"
	     then do;
		     status_struc.ev_chn = attach_data.event_wait.channel_id (1);
		     if status_struc.data_available
		     then call timer_manager_$alarm_wakeup (1, "11"b, status_struc.ev_chn);
		end;
	end;
	call proper_io_return (code);			/* assume hardcore sets code for unknown order */
%page;
/* The user makes a modes call with two strings:  one for new modes and one for old modes.
   The hardcore overwrites the new modes with the old modes, so the user's mode string must be copied
   into a scratch buffer for the hardcore call.
*/

modes:
     entry (arg_iocbp, a_new_modes, a_old_modes, code);

	call set_up_io (6);
	on cleanup call clean_up;

	call set_modes ("", a_new_modes, a_old_modes, code);
	call proper_io_return (code);
%page;
/* The only request that makes sense for terminals is forward skip of records.
   mode = 0		     skip records
   no_of_records >=  0	     forward skip
*/

tty_io_$position:
     entry (arg_iocbp, mode, no_of_records, code);

	call set_up_io (5);
	if mode ^= 0 | no_of_records < 0
	then call proper_io_return (error_table_$no_operation);

	on cleanup call clean_up;

	if no_of_records > 0
	then do;
		allocate scratch_buffer;		/* freed by proper_io_return_ */
		event_wait_ptr = addr (attach_data.event_wait);
		i = 0;

		do while (i < no_of_records);

		     call read (addr (scratch_buffer), length (scratch_buffer), amt_trans, 0, "1"b, code);
		     if code ^= 0
		     then call proper_io_return (code);
		     if nl_returned
		     then i = i + 1;
		end;
	     end;
	call proper_io_return (code);
%page;
/* This procedure sets the pointer to the actual iocb ptr and sets the attach_data_ptr.
*/

set_up:
     procedure;

	code = 0;
	actual_iocbp = arg_iocbp -> iocb.actual_iocb_ptr;
	attach_data_ptr = actual_iocbp -> iocb.attach_data_ptr;
	timeout_info_ptr = null ();
	modes_need_restoration = "0"b;
	scratch_buffer_ptr = null ();
	return;

     end set_up;


set_up_io:
     procedure (which_op);

	dcl     which_op		 fixed bin;

	call set_up;
	attach_data.operation_hlock = attach_data.operation_hlock + 1;
	iox_op_in_progress = which_op;		/* allow us to retry this op -- see IOX* labels */
	call check_async;
	return;
     end set_up_io;
%page;
get_terminal_info:
     proc;					/* performs ring 0 terminal_info order */

	t_info.version = terminal_info_version;

	call call_order ("terminal_info", addr (t_info), state, code);
	if code ^= 0
	then call proper_io_return (code);
     end get_terminal_info;
%page;
/* Internal procedure to set default or user-specified modes */

set_default_modes:
     proc (prefix, code);				/* assumes terminal type given by t_info.term_type */

	dcl     prefix		 char (*);
	dcl     code		 fixed bin (35);

	call ttt_info_$modes (t_info.term_type, attach_data.temp_mode_string, code);
						/* get default modes */
	if code ^= 0 | attach_data.temp_mode_string = ""
	then return;

	call set_modes (prefix, attach_data.temp_mode_string, "", code);
     end set_default_modes;

set_modes:
     procedure (new_mode_prefix, new_modes, old_modes, code);

	dcl     (new_mode_prefix, new_modes, old_modes)
				 char (*);
	dcl     code		 fixed bin (35);
	dcl     commax		 fixed bin (21);
	dcl     prefix_in_use	 bit (1) aligned;	/* the prefix arg avoids concatenation stack extensions in our callers */
	dcl     returned_length	 fixed bin (21);

	if new_mode_prefix ^= ""
	then prefix_in_use = "1"b;
	else prefix_in_use = "0"b;

	modes_ptr = addr (attach_data.mode_string_info);

	if prefix_in_use
	then attach_data.mode_string_info.mode_string = new_mode_prefix || new_modes;
	else attach_data.mode_string_info.mode_string = new_modes;

	call call_order ("modes", modes_ptr, state, code);

	if code ^= 0 & code ^= error_table_$smallarg
	then do;
		old_modes = attach_data.mode_string_info.mode_string;
						/* the mode(s) in error are in here */
		return;
	     end;

	if length (old_modes) = 0
	then do;
		code = 0;				/* censor smallarg on "" old_modes */
		return;
	     end;

	returned_length = length (rtrim (attach_data.mode_string_info.mode_string));
	if returned_length = 0			/* nothing in either direction */
	then do;
		code = 0;
		old_modes = "";
		return;
	     end;

/* from this point on we can have a smallarg */

	code = 0;					/* but we do not admit it. */

/**** Note -- attach_data.mode_string is maintained to be long enough
      for whatever the hardcore could possibly say, unless someone
      invents a funny mpx that gave wildly different mode string lengths.
      So we assume that attach_data.mode_string is not truncated,
      and don't bother checking for the "."

      So long as the user gave us as much space, we have faith that
      no manipulations of the string are needed. */

	if returned_length <= length (old_modes)
	then do;
		old_modes = attach_data.mode_string_info.mode_string;
		return;
	     end;

/**** Here, we want to truncate to the last full mode */

	commax = index (reverse (substr (attach_data.mode_string_info.mode_string, 1, length (old_modes))), ",");
	if commax = 0				/** hmmm, no room for an modes at all */
	then old_modes = ".";
	else do;
		substr (old_modes, 1, length (old_modes) - commax) =
		     substr (attach_data.mode_string_info.mode_string, 1, length (old_modes) - commax);
		substr (old_modes, length (old_modes) - commax + 1) = ".";
						/* fill with spaces */
	     end;
	return;
     end set_modes;

/* Internal procedure to set default and user-specified initial_string */

send_default_initial_string:
     proc (code);					/* assumes terminal type given by t_info.term_type */

	dcl     code		 fixed bin (35);

	call ttt_info_$initial_string (t_info.term_type, initial_string, code);
	if code ^= 0
	then return;
	if length (initial_string) = 0
	then do;
		code = error_table_$no_initial_string;
		return;
	     end;

	go to sis_common;

send_initial_string:
     entry (a_initial_string, code);

	dcl     a_initial_string	 character (*) varying;

	initial_string = a_initial_string;

sis_common:
	attach_data.temp_mode_string = "";
	modes_need_restoration = "1"b;

	call set_modes ("", "rawo", attach_data.temp_mode_string, code);
	if code ^= 0
	then return;				/* Recurse, recurse */
	call tty_io_$put_chars (arg_iocbp, addrel (addr (initial_string), 1), length (initial_string), code);
						/* skip varying string. YCCH */
						/* not to mention no_block implications... */
						/* this should be coded as call to write_chars, all things considered */

	call set_modes ("", attach_data.temp_mode_string, "", (0));
						/* best work */
	modes_need_restoration = "0"b;
	return;
     end send_default_initial_string;

%page;
/* this procedure is called after any hcs_$tty_ entry.
   if we are not a login_channel, then we return.
   if we are, then
   in the io no permission case, it waits 10 seconds for sus_ to happen.
   if the async bits are set, then the reconnection came off. if not, we
   we wait again. using -login_channel if you do not mean it is not recommended,
   as the async bits would never get set. sus_signal_handler_ will take care of anyone
   who is attached with -login_channel. */

check_for_disconnect:
     procedure (code);

	dcl     temp_state		 fixed bin;
	dcl     temp_code		 fixed bin (35);
	dcl     mask_to_set		 bit (36) aligned;
	dcl     mask_to_reset	 bit (36) aligned;
	dcl     code		 fixed bin (35);

	if ^attach_data.login_channel
	then return;				/* not our problem */
	if attach_data.async_detach
	then go to fake_operation_and_return;

	call hcs_$tty_state (attach_data.tty_index, temp_state, temp_code);
						/* is it ours? */
	if temp_code = 0
	then return;				/* we still own channel, must be some other error */

/* we dont own channel, but no bits. must be we havent got sus_'ed */
	call create_ips_mask_ (addr (sus_trm_names), 3, mask_to_set);
						/* better include alrm, for timing */
	mask_to_set = ^mask_to_set;			/* form enable mask */

/* sit in a loop and wait for the answering service to goose us.
   the answering service should suspend us, and then afterwards
   take us out.
*/
	call hcs_$set_ips_mask (mask_to_set, mask_to_reset);
						/* mask to AS signals only */

	do while (^attach_data.async_detach);
	     call timer_manager_$sleep (1, "11"b);
	end;

	call hcs_$reset_ips_mask (mask_to_reset, (36)"0"b);

	goto fake_operation_and_return;
%page;
check_async:
     entry;

	if attach_data.async_detach
	then go to fake_operation_and_return;
	else if attach_data.async_hangup
	then call proper_io_return (error_table_$io_no_permission);
	else return;

     end check_for_disconnect;



fake_operation_and_return:				/* label since we really return */
	revert cleanup;				/* do not try to run unlock_hlock on freed attach data */
	if attach_data.operation_hlock = 1
	then free attach_data;			/* and we are the last */
	else call unlock_hlock;

	goto IOX_OPERATION (iox_op_in_progress);

IOX_OPERATION (1):					/* get_chars */
	call iox_$get_chars (actual_iocbp, arg_buf_ptr, arg_buf_len, chars_trans, code);
	return;

IOX_OPERATION (2):					/* get_line */
	call iox_$get_line (actual_iocbp, arg_buf_ptr, arg_buf_len, chars_trans, code);
	return;

IOX_OPERATION (3):					/* put_chars */
	call iox_$put_chars (actual_iocbp, arg_buf_ptr, arg_buf_len, code);
	return;

IOX_OPERATION (4):					/* control */
	call iox_$control (actual_iocbp, order, info_ptr, code);
	return;

IOX_OPERATION (5):					/* position */
	call iox_$position (actual_iocbp, mode, no_of_records, code);
	return;

IOX_OPERATION (6):					/* modes */
	call iox_$modes (actual_iocbp, a_old_modes, a_new_modes, code);
	return;
%page;
unlock_hlock:
     procedure;
	attach_data.operation_hlock = attach_data.operation_hlock - 1;
     end unlock_hlock;

proper_io_return:
     procedure (r_code);
	declare r_code		 fixed bin (35);

	code = r_code;
	go to proper_io_return_label_;
     end proper_io_return;

proper_io_return_label_:
	if timeout_info_ptr ^= null ()
	then call timer_cleanup;
	call modes_cleanup;
	if scratch_buffer_ptr ^= null ()
	then free scratch_buffer;
	call unlock_hlock;
	return;
%page;
tty_io_$get_chars:
     entry (arg_iocbp, arg_buf_ptr, arg_buf_len, chars_trans, code);

	chars_trans = 0;				/* initialize output value in case set_up_io aborts */
	call set_up_io (1);				/* manage half-lock and get actual_iocb_ptr, attach_data */
	on cleanup call clean_up;			/* never freed */

	call get_chars (arg_buf_ptr, arg_buf_len, chars_trans, -1);
						/* It never returns -- calls proper_io_return */

get_chars:
     procedure (arg_buf_ptr, arg_buf_len, chars_trans, arg_timeout);

	declare (
	        arg_buf_ptr		 pointer,
	        (arg_buf_len, chars_trans)
				 fixed binary (21),
	        arg_timeout		 fixed binary (71)
	        )			 parameter;

	if arg_timeout < 0
	then event_wait_ptr = addr (attach_data.event_wait);
	else if arg_timeout = 0
	then event_wait_ptr = null ();

	chars_trans = 0;
	if arg_buf_len < 0
	then call proper_io_return (error_table_$bad_arg);
	buffer_ptr = arg_buf_ptr;
	offset = mod (charno (buffer_ptr), 4);
	buffer_ptr = addcharno (buffer_ptr, -offset);
	call read (buffer_ptr, arg_buf_len, chars_trans, offset, "0"b, code);
	call proper_io_return (code);

     end get_chars;
%page;
tty_io_$get_line:
     entry (arg_iocbp, arg_buf_ptr, arg_buf_len, chars_trans, code);

	chars_trans = 0;				/* initialize output value in case set_up_io aborts */
	call set_up_io (2);
	on cleanup call clean_up;

	call get_line (arg_buf_ptr, arg_buf_len, chars_trans, -1);

get_line:
     procedure (arg_buf_ptr, arg_buf_len, chars_trans, arg_timeout);

	declare (
	        arg_buf_ptr		 pointer,
	        (arg_buf_len, chars_trans)
				 fixed binary (21),
	        arg_timeout		 fixed binary (71)
	        )			 parameter;

	if arg_timeout < 0
	then event_wait_ptr = addr (attach_data.event_wait);
	else if arg_timeout = 0
	then event_wait_ptr = null ();		/* no blocking */

	chars_trans = 0;
	if arg_buf_len < 0
	then call proper_io_return (error_table_$bad_arg);
	if arg_buf_len = 0
	then call proper_io_return (0);

	buffer_ptr = arg_buf_ptr;
	offset = mod (charno (buffer_ptr), 4);
	buffer_ptr = addcharno (buffer_ptr, -offset);
	num_to_read = arg_buf_len;

	do while (num_to_read > 0);			/* until we get a newline or run out of space */
	     call read (buffer_ptr, num_to_read, num_read, offset, "1"b, code);
	     chars_trans = chars_trans + num_read;	/* BEFORE we check the code, so that long_record and timeout and such correctly return the number we read */

	     if code ^= 0
	     then call proper_io_return (code);

	     if nl_returned
	     then call proper_io_return (0);		/* ring 0 will say whether it found newline */

	     if attach_data.no_block | arg_timeout = 0
	     then call proper_io_return (0);		/* nothing counts as a line for get line */
	     offset = offset + num_read;		/* no newline, read some more */
	     num_to_read = num_to_read - num_read;
	end;

	call proper_io_return (error_table_$long_record); /* never got a newline */
     end get_line;
%page;
/* This entry is called to output characters.  The hardcore dim may output less than was requested
   and may have to be called more than once.  These conditions may occur if the hardcore did not
   complete the request:

   .	code = 0		The hardcore was given more characters than it could process;  the process goes
   .			blocked and makes another output request after the wakeup.

   .	code ^= 0		The process has lost the attachment to the terminal.  The error code no_io_permission is
   .			returned.

   .	state ^= TTY_STATE_DIALED_UP this only will come back in the Real Owner's process, currently
   the Initializer.
   The terminal has hungup.  The error code no_io_permission is returned.
*/

tty_io_$put_chars:
     entry (arg_iocbp, arg_buf_ptr, arg_buf_len, code);

	call set_up_io (3);
	on cleanup call clean_up;

	call put_chars (arg_buf_ptr, arg_buf_len, (0), -1);
						/* It never returns -- calls proper_io_return */
put_chars:
     procedure (arg_buf_ptr, arg_buf_len, arg_chars_written, arg_timeout);

	declare (
	        arg_buf_ptr		 pointer,
	        arg_buf_len		 fixed binary (21),
	        arg_chars_written	 fixed binary (21),
	        arg_timeout		 fixed binary (71)
	        )			 parameter;

	if arg_timeout < 0
	then event_wait_ptr = addr (attach_data.event_wait);
	else if arg_timeout = 0
	then event_wait_ptr = null ();
	/*** else set by timer_setup */

	if arg_buf_len < 0
	then call proper_io_return (error_table_$bad_arg);

	if arg_buf_len = 0
	then call proper_io_return (0);

	buffer_ptr = arg_buf_ptr;
	offset = mod (charno (buffer_ptr), 4);
	buffer_ptr = addcharno (buffer_ptr, -offset);
	total_amt_trans = 0;

	timed_out = "0"b;				/* we retry the operation after the time out interval even without a detectable wakeup */
	do while ("1"b);
	     amt_trans = 0;
	     call write_chars (buffer_ptr, offset, arg_buf_len - total_amt_trans, amt_trans, state, code);
	     if code ^= 0
	     then do;
		     arg_chars_written = total_amt_trans;
		     call proper_io_return (code);
		end;
	     total_amt_trans = total_amt_trans + amt_trans;
	     if total_amt_trans >= arg_buf_len
	     then do;
		     arg_chars_written = total_amt_trans;
		     call proper_io_return (0);	/* done! */
		end;

	     if arg_timeout >= 0			/* timeout requires output args */
	     then do;
		     arg_chars_written = total_amt_trans;
		     if arg_timeout = 0 | timed_out	/* timed_out --> that we timed out already but are just giving one more push */
		     then call proper_io_return (error_table_$timeout);
		end;
	     else if attach_data.no_block		/* no_block + timeout = block on timer only */
	     then do;
		     if arg_buf_len > total_amt_trans
		     then code = total_amt_trans - arg_buf_len;
						/* - (number not transmitted) */
		     arg_chars_written = total_amt_trans;
		     call proper_io_return (code);
		end;
	     offset = offset + amt_trans;
	     call ipc_$block (event_wait_ptr, addr (event_message), code);
	     if code ^= 0
	     then call proper_io_return (code);		/* ipc failure? this is bad luck, perhaps should signal */
	     call check_async ();			/* check for having lost the channel while blocked */
	     if event_message.channel_id ^= attach_data.event_wait.channel_id (1)
	     then timed_out = "1"b;			/* attach_data.event_wait.channel_id (1) is ALWAYS the tty itself, and the only other possibility is the timer event */
						/* setting this flag causes it to try to write one more time before returning. */

	end;
     end put_chars;
%page;
write_chars:
     procedure (bufferp, buffero, n_to_write, n_wrote, statex, code);

	declare (
	        bufferp		 ptr,
	        (buffero, n_to_write, n_wrote)
				 fixed bin (21),
	        statex		 fixed bin,
	        code		 fixed bin (35)
	        )			 parameter;

	call hcs_$tty_write (attach_data.tty_index, bufferp, buffero, n_to_write, n_wrote, statex, code);
	if code ^= 0
	then call check_for_disconnect (code);
	return;
     end write_chars;
%page;
/*  This procedure reads one line of data or "amt_to_read" characters whichever is smaller. */

read:
     proc (buffer_ptr, amt_to_read, amt_read, offset, get_line_called, code);

	dcl     buffer_ptr		 ptr;
	dcl     amt_to_read		 fixed bin (21);
	dcl     amt_read		 fixed bin (21);
	dcl     offset		 fixed bin (21);
	dcl     get_line_called	 bit (1);
	dcl     code		 fixed bin (35);

	amt_read = 0;

	timed_out = "0"b;
	do while ("1"b);
	     if get_line_called
	     then call hcs_$tty_get_line (attach_data.tty_index, buffer_ptr, offset, amt_to_read, amt_read, nl_returned,
		     state, code);
	     else call hcs_$tty_read (attach_data.tty_index, buffer_ptr, offset, amt_to_read, amt_read, state, code);

	     if code ^= 0
	     then do;
		     call check_for_disconnect (code);	/* will NOT return if io_no_permission */
		     return;
		end;

	     if amt_read > 0
	     then return;
	     if event_wait_ptr = null () /* 0 timeout */ | timed_out
						/* we hung out a read, it timed out, we tried one last time, got nothing, and so away we go */
	     then call proper_io_return (error_table_$timeout);

	     if attach_data.no_block
	     then return;				/* the n-chars-read will be zero, no problem, no code needed */
	     call ipc_$block (event_wait_ptr, addr (event_message), code);
	     if code ^= 0
	     then return;
	     call check_async ();			/* check for having lost the channel while blocked */
	     if event_message.channel_id ^= attach_data.event_wait.channel_id (1)
	     then timed_out = "1"b;
	end;
     end read;

%page;
timer_setup:
     procedure (arg_timeout);

	declare arg_timeout		 fixed bin (71);
	declare channel		 fixed bin (71);

	if arg_timeout = 0
	then return;				/* timeout of zero special */
	call ipc_$create_ev_chn (channel, code);
	if code ^= 0
	then call proper_io_return (code);
	if attach_data.no_block
	then do;
		timeout_event_wait.channel_id (1) = channel;
		timeout_event_wait.n_channels = 1;
	     end;
	else do;
		timeout_event_wait.channel_id (1) = attach_data.event_wait.channel_id (1);
		timeout_event_wait.channel_id (2) = channel;
		timeout_event_wait.n_channels = 2;
	     end;
	call timer_manager_$alarm_wakeup (arg_timeout, Relative_Microseconds, timeout_event_wait.channel_id (2));
	event_wait_ptr = addr (timeout_event_wait);
	return;
     end timer_setup;

modes_cleanup:
     procedure;

/**** Restore modes by hand to avoid forcing a bunch of useful
      procedures to be non-quick. */

	if ^modes_need_restoration
	then return;
	attach_data.mode_string_info.mode_string = attach_data.temp_mode_string;
	call hcs_$tty_order (attach_data.tty_index, "modes", addr (attach_data.mode_string_info), state, code);

	return;
     end modes_cleanup;

timer_cleanup:
     procedure;

	if timeout_info_ptr = null ()
	then return;
	call timer_manager_$reset_alarm_wakeup (timeout_event_wait.channel_id (2));
	call ipc_$delete_ev_chn (timeout_event_wait.channel_id (2), (0));
	return;

     end timer_cleanup;

abort:
     procedure (abort_type, code);

	dcl     abort_type		 fixed bin;
	dcl     code		 fixed bin (35);

	call hcs_$tty_abort (attach_data.tty_index, (abort_type), state, code);
	if code ^= 0
	then call check_for_disconnect (code);
	call proper_io_return (code);
     end abort;

call_order:
     procedure (order, info_ptr, state, code);

	dcl     order		 char (*);
	dcl     info_ptr		 ptr;
	dcl     state		 fixed bin;
	dcl     code		 fixed bin (35);

	call hcs_$tty_order (attach_data.tty_index, order, info_ptr, state, code);
	if code ^= 0
	then call check_for_disconnect (code);
     end call_order;

clean_up:
     procedure;

	call timer_cleanup;
	call modes_cleanup;
	if scratch_buffer_ptr ^= null ()
	then free scratch_buffer;
	call unlock_hlock;
     end clean_up;


%page;
%include as_com_channel_info;
%include event_wait_info;
%include iocb;
%include iox_entries;
%include tty_attach_data_;
%include tty_read_status_info;
%include tty_get_channel_info;
%include io_timeout_info;
%include tty_control_orders_info;
%include terminal_type_data;
%include terminal_info;
%include set_term_type_info;
%include ttyp;

     end tty_io_;




		    tty_io_call_control_.pl1        08/08/88  1552.2r w 08/08/88  1409.4      139977



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


/* This procedure sets up info structures to execute tty_ control orders on behalf of the
   io_call command. */

/* Written April 1976 by Larry Johnson */
/* Modified May 1978 to add suppport for active function and new orders */
/* Modified November 1980 by Benson I. Margulies for set_event_channel */
/* Modified 1985-02-19, BIM: get_com_channel_info */

/* format: style2 */
tty_io_call_control_:
     proc (iocbp, io_call_order, io_call_infop, code);

/* Parameters */

	dcl     iocbp		 ptr;		/* Pointer to the IOCB */
	dcl     io_call_order	 char (*);	/* Can be io_call or io_call_af */
	dcl     code		 fixed bin (35);	/* Standard system status code */

/* Automatic storage */

	dcl     not_open_sw		 bit (1);
	dcl     af_sw		 bit (1);		/* Set if doing active function */
	dcl     i			 fixed bin;
	dcl     temp_type		 char (16);
	dcl     new_id		 char (4);	/* Info structure for storeid order */
	dcl     (err, rpt)		 entry variable options (variable);
	dcl     caller		 char (32);
	dcl     order		 char (32);
	dcl     n_args		 fixed bin;
	dcl     line_length		 fixed bin (9);
	dcl     ev_channel		 fixed bin (71);

	dcl     1 ascci		 aligned like as_com_channel_info;
	dcl     1 read_status	 aligned like tty_read_status_info;
	dcl     1 write_status	 aligned like tty_read_status_info;
	dcl     1 info		 aligned like tty_info;
	dcl     new_type		 fixed bin (35);

	dcl     1 modes		 aligned,
		2 str_len		 fixed bin,
		2 str		 char (512);

	dcl     1 auto_terminal_info	 like terminal_info automatic;
	dcl     1 auto_set_term_type_info
				 like set_term_type_info automatic;

/* External stuff */

	dcl     iox_$control	 entry (ptr, char (*), ptr, fixed bin (35));
	dcl     convert_access_class_$to_string_short
				 entry (bit (72) aligned, char (*), fixed bin (35));
	dcl     convert_access_class_$to_string_range_short
				 entry ((2) bit (72) aligned, char (*), fixed bin (35));
	dcl     cv_dec_check_	 entry (char (*), fixed bin) returns (fixed bin (35));
	dcl     ioa_$rsnnl		 entry options (variable);

	dcl     (
	        error_table_$badopt,
	        error_table_$noarg,
	        error_table_$bad_conversion,
	        error_table_$too_many_args,
	        error_table_$not_open,
	        error_table_$undefined_order_request
	        )			 ext fixed bin (35);

/* internal static */
/* orders that require info that we will not supply */

	dcl     info_orders		 (27) char (32) int static options (constant)
				 init ("set_delay", "get_channel_info", "get_delay", "set_editing_chars",
				 "get_editing_chars", "set_input_translation", "set_input_conversion",
				 "set_output_translation", "set_output_conversion", "get_input_translation",
				 "get_input_conversion", "get_output_translation", "get_output_conversion",
				 "set_special", "get_special", "set_framing_chars", "get_framing_chars",
				 "send_initial_string", "set_default_modes", "set_input_message_size",
				 "get_input_message_size", "input_flow_control_chars",
				 "output_flow_control_chars", "get_echo_break_table", "set_wakeup_table",
				 "set_prompt", "hangup_proc");

	declare conversion		 condition;

/* builtins */

	dcl     (addr, binary, character, hbound, lbound, length, null, rtrim, string, substr, translate, unspec)
				 builtin;

%include as_com_channel_info;
%include io_call_info;
%include tty_read_status_info;
%include tty_get_channel_info;
%include tty_control_orders_info;
%include ttyp;
%include terminal_info;
%include set_term_type_info;
%include line_types;


	not_open_sw = ""b;
	goto JOIN;

not_open:
     entry (iocbp, io_call_order, io_call_infop, code);
	not_open_sw = "1"b;

JOIN:
	af_sw = (io_call_order = "io_call_af");
	err = io_call_info.error;
	rpt = io_call_info.report;
	order = io_call_info.order_name;
	n_args = io_call_info.nargs;
	caller = io_call_info.caller_name;

/* not_open orders first */
/* set_event order */

	if order = "set_event"
	then do;
		if af_sw
		then go to not_af;
		if n_args = 0
		then do;
			call err (error_table_$noarg, caller, "Event channel.");
			code = 0;
			goto RETURN;
		     end;
		if n_args > 1
		then do;
			call err (error_table_$too_many_args, caller, "Only an event channel may be given.");
			code = 0;
			goto RETURN;
		     end;
		if substr (io_call_info.args (1), 1, 1) = "-"
		then do;
			call err (error_table_$badopt, caller, "^a", io_call_info.args (1));
			code = 0;
			goto RETURN;
		     end;
		on conversion
		     begin;			/* cv_foo_check_ wont do 71 bits */
			call err (error_table_$bad_conversion, caller, "Bad event channel ^a.",
			     io_call_info.args (1));
			code = 0;
			goto RETURN;
		     end;
		ev_channel = binary (io_call_info.args (1));
						/* Default is 71, 0 */
		call iox_$control (iocbp, "set_event", addr (ev_channel), code);
		goto RETURN;
	     end;

	else if order = "get_event"
	then do;
		if n_args > 0
		then do;
			call err (error_table_$too_many_args, caller, "The get_event order takes no arguments.");
			code = 0;
			goto RETURN;
		     end;
		call iox_$control (iocbp, "get_event", addr (ev_channel), code);
		if code ^= 0
		then do;
			call err (code, caller, "No event channel info available.");
			code = 0;
			goto RETURN;
		     end;
		if af_sw
		then io_call_af_ret = character (ev_channel);
						/* work in decimal for set_ev and ipc_call */
		else call rpt ("^a: Event channel=^d (decimal).", caller, ev_channel);
		code = 0;
		goto RETURN;
	     end;

	else if order = "get_com_channel_info"
	then do;
		declare temp_acc		 char (32);
		unspec (ascci) = ""b;
		ascci.version = AS_COM_CHANNEL_INFO_VERSION_1;
		call iox_$control (iocbp, "get_com_channel_info", addr (ascci), code);
		if code = 0
		then do;
			call rpt ("^a:^20tchannel:^40t^a", caller, ascci.channel_name);
			call rpt ("^20taccess_control.login:^40t^[on^;off^]", ascci.access_control.login);

			call rpt ("^20taccess_control.dial_slave:^40t^[on^;off^]", ascci.access_control.dial_slave);
			call rpt ("^20taccess_control.priv_attach:^40t^[on^;off^]",
			     ascci.access_control.priv_attach);
			call rpt ("^20taccess_control.dial_server:^40t^[on^;off^]",
			     ascci.access_control.dial_server);
			call rpt ("^20taccess_control.dial_out:^40t^[on^;off^]", ascci.access_control.dial_out);
			call rpt ("^20tattached_to_caller:^40t^[on^;off^]", ascci.attached_to_caller);
			call rpt ("^20tuser_authenticated:^40t^[on^;off^]", ascci.user_authenticated);
			call rpt ("^20tdialed_to_caller:^40t^[on^;off^]", ascci.dialed_to_caller);
			call rpt ("^20tservice_type:^40t^[ANS^;FTP^;MC^;SLAVE^;DIAL^;DIAL_OUT^;MPX^;TANDD^]",
			     ascci.service_type);
			call rpt (
			     "^20tcurrent_service_type:^40t^[ANS^;FTP^;MC^;SLAVE^;DIAL^;DIAL_OUT^;MPX^;TANDD^]",
			     ascci.current_service_type);
			call convert_access_class_$to_string_range_short (ascci.access_class, temp_acc, (0));
			if temp_acc = ""
			then temp_acc = "system_low";
			call rpt ("^20taccess_class:^40t^a", temp_acc);
			call convert_access_class_$to_string_short (ascci.current_access_class, temp_acc, (0));
			if temp_acc = ""
			then temp_acc = "system_low";
			call rpt ("^20tcurrent_access_class:^40t^a", temp_acc);
			call rpt ("^20tauth_user_name:^40t^a", ascci.auth_user_name);
		     end;
	     end;

/* end of not_open orders */
	else if not_open_sw
	then do;
		code = error_table_$not_open;
		call err (code, caller);
		go to RETURN;

	     end;

/* Info order */

	else if order = "info"
	then do;
		call iox_$control (iocbp, "info", addr (info), code);
		if code = 0
		then do;
			if info.type < lbound (tty_dev_type, 1) | info.type > hbound (tty_dev_type, 1)
			then call ioa_$rsnnl ("type^d", temp_type, (0), info.type);
			else temp_type = tty_dev_type (info.type);

			if af_sw
			then do;
				if n_args = 0
				then io_call_af_ret = rtrim (temp_type);
				else if io_call_info.args (1) = "id"
				then io_call_af_ret = rtrim (info.id);
				else if io_call_info.args (1) = "baud"
				then call ioa_$rsnnl ("^d", io_call_af_ret, (0), info.baudrate);
				else if io_call_info.args (1) = "type"
				then io_call_af_ret = rtrim (temp_type);
				else call err (error_table_$badopt, caller, "^a", io_call_info.args (1));
			     end;
			else call rpt ("^a: Terminal id=""^a"", baud rate=^d, type=^a.", caller, info.id,
				info.baudrate, temp_type);
		     end;
	     end;

/* Read_status order */

	else if order = "read_status"
	then do;
		call iox_$control (iocbp, "read_status", addr (read_status), code);
		if code = 0
		then do;
			if af_sw
			then if read_status.input_pending
			     then io_call_af_ret = "true";
			     else io_call_af_ret = "false";
			else call rpt ("^a: Event channel=^24.3b, input is ^[^;not ^]available.", caller,
				unspec (read_status.event_channel), read_status.input_pending);
		     end;
	     end;

/* Write_status order */

	else if order = "write_status"
	then do;
		call iox_$control (iocbp, "write_status", addr (write_status), code);
		if code = 0
		then do;
			if af_sw
			then if write_status.input_pending
			     then io_call_af_ret = "true";
			     else io_call_af_ret = "false";
			else call rpt ("^a: Event channel=^24.3b, output is ^[^;not ^]pending.", caller,
				unspec (write_status.event_channel), write_status.input_pending);
		     end;
	     end;

/* Store_id order */

	else if order = "store_id"
	then do;
		if af_sw
		then do;
not_af:
			call err (0, caller, "The ^a order is not valid as an active function.", order);
			code = 0;
		     end;
		if n_args ^> 0
		then do;
			call err (error_table_$noarg, caller, "ID.");
			code = 0;
		     end;
		else do;
			new_id = io_call_info.args (1);
			call iox_$control (iocbp, "store_id", addr (new_id), code);
		     end;
	     end;

/* Set_type order */

	else if order = "set_type" | order = "set_terminal_type"
	then do;
		if af_sw
		then go to not_af;
		if n_args ^> 0
		then do;
			call err (error_table_$noarg, caller, "Type.");
			code = 0;
		     end;
		else do;
			new_type = cv_dec_check_ ((io_call_info.args (1)), i);
			if i ^= 0
			then do;
				temp_type =
				     translate (io_call_info.args (1), "ABCDEFGHIJKLMNOPQRSTUVWXYZ",
				     "abcdefghijklmnopqrstuvwxyz");
				do new_type = lbound (tty_dev_type, 1) to hbound (tty_dev_type, 1);
				     if tty_dev_type (new_type) = temp_type
				     then do;	/* Got a match */
					     call iox_$control (iocbp, "set_type", addr (new_type), code);
					     return;
					end;
				end;
				call err (0, caller, "Invalid type: ^a", io_call_info.args (1));
				code = 0;
			     end;
			else call iox_$control (iocbp, "set_type", addr (new_type), code);
		     end;
	     end;

/* Modes order */

	else if order = "modes"
	then do;
		if af_sw
		then go to not_af;
		if n_args ^> 0
		then modes.str = "";
		else modes.str = io_call_info.args (1);
		modes.str_len = length (modes.str);
		call iox_$control (iocbp, "modes", addr (modes), code);
		if code = 0
		then call rpt ("^a: ^a", caller, modes.str);
	     end;

/* Set_line_type order */

	else if order = "set_line_type"
	then do;
		if af_sw
		then go to not_af;
		if n_args ^> 0
		then do;
			call err (error_table_$noarg, caller, "Line type.");
			code = 0;
		     end;
		else do;
			temp_type =
			     translate (io_call_info.args (1), "ABCDEFGHIJKLMNOPQRSTUVWXYZ",
			     "abcdefghijklmnopqrstuvwxyz");
			do new_type = lbound (line_types, 1) to hbound (line_types, 1);
			     if temp_type = line_types (new_type)
			     then go to set_line_type;
			end;
			new_type = cv_dec_check_ ((io_call_info.args (1)), i);
			if i ^= 0
			then do;
				call err (0, caller, "Invalid line type: ^a", io_call_info.args (1));
				code = 0;
			     end;
			else
set_line_type:
			     call iox_$control (iocbp, "set_line_type", addr (new_type), code);
		     end;
	     end;

/* Line length order */

	else if order = "line_length"
	then do;
		if af_sw
		then go to not_af;
		if n_args ^> 0
		then do;
			call err (error_table_$noarg, caller, "Line length.");
			code = 0;
		     end;
		else do;
			line_length = cv_dec_check_ ((io_call_info.args (1)), i);
			if i ^= 0
			then do;
				call err (0, caller, "Invalid line length: ^a", io_call_info.args (1));
				code = 0;
			     end;
			else call iox_$control (iocbp, "line_length", addr (line_length), code);
		     end;
	     end;

/* Terminal info order */

	else if order = "terminal_info"
	then do;
		terminal_info_ptr = addr (auto_terminal_info);
		terminal_info.version = 1;
		call iox_$control (iocbp, "terminal_info", terminal_info_ptr, code);
		if code = 0
		then do;
			if terminal_info.line_type < lbound (line_types, 1)
			     | terminal_info.line_type > hbound (line_types, 1)
			then call ioa_$rsnnl ("^d", temp_type, (0), terminal_info.line_type);
			else temp_type = line_types (terminal_info.line_type);
			if af_sw
			then do;
				if n_args = 0
				then io_call_af_ret = rtrim (terminal_info.term_type);
				else if io_call_info.args (1) = "id"
				then io_call_af_ret = rtrim (terminal_info.id);
				else if io_call_info.args (1) = "baud"
				then call ioa_$rsnnl ("^d", io_call_af_ret, (0), terminal_info.baud_rate);
				else if io_call_info.args (1) = "terminal_type"
				then io_call_af_ret = rtrim (terminal_info.term_type);
				else if io_call_info.args (1) = "line_type"
				then io_call_af_ret = rtrim (temp_type);
				else call err (error_table_$badopt, caller, "^a", io_call_info.args (1));
			     end;
			else call rpt ("^a: Terminal id=""^a"", baud_rate=^d, term type=""^a"", line type=""^a"".",
				caller, terminal_info.id, terminal_info.baud_rate, terminal_info.term_type,
				temp_type);
		     end;
	     end;

/* Set_term_type order */

	else if order = "set_term_type"
	then do;
		if af_sw
		then go to not_af;
		sttip = addr (auto_set_term_type_info);
		set_term_type_info.version = 1;
		set_term_type_info.name = "";
		string (set_term_type_info.flags) = "0"b;
		if n_args = 0
		then do;
			call err (error_table_$noarg, caller, "Terminal type.");
			code = 0;
		     end;
		else do;
			set_term_type_info.name = io_call_info.args (1);
			do i = 2 to n_args;
			     if io_call_info.args (i) = "-tabs" | io_call_info.args (i) = "-initial_string"
				| io_call_info.args (i) = "-istr"
			     then set_term_type_info.send_initial_string = "1"b;
			     else if io_call_info.args (i) = "-modes"
			     then set_term_type_info.set_modes = "1"b;
			     else if io_call_info.args (i) = "-ignore_line_type"
			     then set_term_type_info.ignore_line_type = "1"b;
			     else do;
				     call err (error_table_$badopt, caller, "^a", io_call_info.args (i));
				     code = 0;
				end;

			end;
			call iox_$control (iocbp, "set_term_type", sttip, code);
		     end;
	     end;


/* All other orders */

	else if af_sw
	then go to not_af;
	else do;					/* find out if it can just be passed on */
		do i = 1 to hbound (info_orders, 1) while (order ^= info_orders (i));
		end;
		if i <= hbound (info_orders, 1)	/* on the disapproved list */
		then do;
			call err (error_table_$undefined_order_request, caller, order);
			code = 0;
		     end;
		else call iox_$control (iocbp, (order), null (), code);
	     end;
RETURN:
	return;

     end tty_io_call_control_;






		    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
